CDECK  ID>, AMASCJ.
      FUNCTION AMASCJ(IDEN)
C     *********************
C-- GIVES MASS OF PARTICLE WITH CODE IDEN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      IDENA=ABS(IDEN)
      AMASCJ=0.
      IF(IDENA.GT.0.AND.IDENA.LE.6) THEN
        AMASCJ=QMAS(IDENA)
      ELSEIF(MOD(IDENA,100)/10.EQ.0) THEN
        IQ=MOD(IDENA,1000)/100
        IF(IQ.GT.0.AND.IQ.LE.6) AMASCJ=QMAS(IQ)
      ELSE
        IN=INIDCJ(IDENA)
        IF(IN.NE.0) AMASCJ=PMAS(IN)
      ENDIF
      RETURN
      END
CDECK  ID>, AMAWCJ.
      FUNCTION AMAWCJ(IDEN)
C     *********************
C-- GIVES MASS OF PARTICLE WITH CODE IDEN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      AMAWCJ=AMASCJ(IDEN)
      IF(NOBROA.EQ.1) RETURN
      INTC=INIDCJ(IDEN)
      IF(INTC.EQ.0) RETURN
      IF(WIDTHP(INTC).EQ.0.) RETURN
      AMAWCJ=AMAWCJ+.5*WIDTHP(INTC)*TAN((2.*RNCJ(0.)-1.)
     &       *ATAN(2.*WCUTP(INTC)/WIDTHP(INTC)))
      RETURN
      END
CDECK  ID>, ASIMCJ.
      FUNCTION ASIMCJ(A1,B1,EP,M,N,FUN)
C     *********************************
C-- ADAPTIVE SIMPSON INTEGRATION ROUTINE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      EXTERNAL FUN
      DIMENSION F2(30),FBP(30),EST2(30)
      INTEGER NRTR(30)
      DIMENSION AEST2(30),FTST(3),XB(30)
      IF(N.LE.0) GO TO 210
      IF(N.GT.3) GO TO 211
      A=A1
      B=B1
      EPS=EP*15.
      ESUM=0.
      TSUM=0.
      LVL=1
      DA=B-A
      FA=FUN(A)
      FM=FUN((A+B)*0.5)
      FB=FUN(B)
      M=3
      FMAX=ABS(FA)
      FTST(1)=FMAX
      FTST(2)=ABS(FM)
      FTST(3)=ABS(FB)
      DO 100 I=2,3
      IF(FMAX.GE.FTST(I)) GO TO 100
      FMAX=FTST(I)
100   CONTINUE
      EST=(FA+4.*FM+FB)*DA/6.
      ABSAR=(FTST(1)+4*FTST(2)+FTST(3))*DA/6.
      AEST=ABSAR
C     1=RECUR
1     SX=(DA/(2.**LVL))/6.
      F1=FUN((3.*A+B)/4.)
      F2(LVL)=FUN((A+3.*B)/4.)
      EST1=SX*(FA+4.*F1+FM)
      FBP(LVL)=FB
      XB(LVL)=B
      EST2(LVL)=SX*(FM+4.*F2(LVL)+FB)
      SUM=EST1+EST2(LVL)
      FTST(1)=ABS(F1)
      FTST(2)=ABS(F2(LVL))
      FTST(3)=ABS(FM)
      AEST1=SX*(ABS(FA)+4.*FTST(1)+FTST(3))
      AEST2(LVL)=SX*(FTST(3)+4.*FTST(2)+ABS(FB))
      ABSAR=ABSAR-AEST+AEST1+AEST2(LVL)
      M=M+2
      IF(N.EQ.1) GO TO 201
      IF(N.EQ.2) GO TO 200
      IF(N.EQ.3) GO TO 202
200   DELTA=ABSAR
      GO TO 205
210   WRITE(ITLIS,39)
39    FORMAT(20H ERROR RETURN-N.LT.0     )
      RETURN
211   WRITE(ITLIS,40)
40    FORMAT(20H ERROR RETURN-N.GT.3     )
      RETURN
201   DELTA=1.
      GO TO 205
202   DO 203 I=1,2
      IF(FMAX.GE.FTST(I)) GO TO 203
      FMAX=FTST(I)
203   CONTINUE
      DELTA=FMAX
205   DAFT=EST-SUM
      DIFF=ABS(DAFT)
      DAFT=DAFT/15.
      IF(DIFF-EPS*DELTA)6,6,3
3     IF(LVL-30)4,2,2
6     IF(LVL-1)2,4,2
C     2=UP
2     A=B
      ESUM=ESUM+DAFT
      TSUM=TSUM+SUM
9     LVL=LVL-1
      L=NRTR(LVL)
      IF(L.EQ.1) GO TO 11
      IF(L.EQ.2) GO TO 12
C     11=R1,12=R2
4     NRTR(LVL)=1
      EST=EST1
      AEST=AEST1
      FB=FM
      FM=F1
      B=(A+B)/2.
      EPS=EPS/2.
7     LVL=LVL+1
      GO TO 1
11    NRTR(LVL)=2
      FA=FB
      FM=F2(LVL)
      FB=FBP(LVL)
      B=XB(LVL)
      EST=EST2(LVL)
      AEST=AEST2(LVL)
      GO TO 7
12    EPS=2.*EPS
      IF(LVL-1)5,5,9
5     ASIMCJ=TSUM-ESUM
      RETURN
      END
CDECK  ID>, BETACJ.
      FUNCTION BETACJ(A,B)
C     ********************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      BETACJ=GAMMCJ(A)*GAMMCJ(B)/GAMMCJ(A+B)
      RETURN
      END
CDECK  ID>, CHRGCJ.
      FUNCTION CHRGCJ(IDEN)
C     *********************
C-- GIVES CHARGE OF PARTICLE WITH CODE IDEN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      IDENA=ABS(IDEN)
      CHRGCJ=0.
      IF(IDENA.GT.0.AND.IDENA.LE.6) THEN
        CHRGCJ=CHARGQ(IDENA)
        IF(IDEN.LT.0) CHRGCJ=-CHRGCJ
      ELSEIF(MOD(IDENA,100)/10.EQ.0) THEN
        IQ1=IDENA/1000
        IQ2=MOD(IDENA,1000)/100
        IF(IQ1.GT.0.AND.IQ1.LE.6.AND.IQ2.GT.0.AND.IQ2.LE.6)
     *  CHRGCJ=CHARGQ(IQ1)+CHARGQ(IQ2)
        IF(IDEN.LT.0) CHRGCJ=-CHRGCJ
      ELSE
        IN=INIDCJ(IDEN)
        IF(IN.NE.0) CHRGCJ=LCHARG(IN)
      ENDIF
      RETURN
      END
CDECK  ID>, CJALIA.
      SUBROUTINE CJALIA(L,S,ST,NPTS)
C     ******************************
C-- ORGANIZES ARRAYS FOR ALIAS METHOD GENERATION
C  INPUT TO SUBROUTINE: ARRAY OF S(I) I=1,...NPTS
C  OUTPUT: SAME ARRAY S(I) AND L(I)
C  ST ARRAY USED TO STACK INITIAL S(I).LT.1 (FORWARD)
C    AND S(I).GT.1 (BACKWARD)
C  ONE PLUS AND MINUS EPSILON
C  ST (integer) MADE AN ARGUMENT TO HAVE ADJUSTABLE DIMENSIONS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION S(NPTS)
      INTEGER L(NPTS),ST(NPTS)
      ONEM=1.-1.E-5
      ONEP=1.+1.E-5
C  INITIALIZE
      IG=NPTS+1
      IS=0
      DO 1 I=1,NPTS
      S(I)=FLOAT(NPTS)*S(I)
      IF(S(I)-1.) 2,1,5
5     IG=IG-1
      ST(IG)=I
      GO TO 1
2     IS=IS+1
      ST(IS)=I
1     CONTINUE
C  MAIN LOOP
3     IF(IS.EQ.0) RETURN
      IX=ST(IS)
      IY=ST(IG)
      L(IX)=IY
      S(IY)=S(IY)-1.+S(IX)
      IF(IG.EQ.NPTS.AND.IS.EQ.1) RETURN
      IS=IS-1
C  CONSTANT REALLY ONE, CHANGED TO ACCOUNT FOR ROUNDOFF
      IF(S(IY).LT.ONEM) GO TO 7
      IF(S(IY).LT.ONEP) GO TO 8
      GO TO 3
7     IS=IS+1
      ST(IS)=ST(IG)
8     IG=IG+1
      GO TO 3
      END
CDECK  ID>, CJBARY.
      SUBROUTINE CJBARY(IFQIN,IFDQIN,KEYSTR,KEYSPN,IDBARY,IFGEN)
C     **********************************************************
C-- GENERATES BARYON WITH ISAJET CODE IDBARY
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      DIMENSION  SU6OCT(6),SU6DEC(6)
      DATA SU6OCT/0.75,  0.5,   0., 0.1667, 0.0833, 0.1667/
      DATA SU6DEC/  0.,   0.,   1., 0.3333, 0.6667, 0.3333/
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 10
      ICALL=1
      FUD3=3.*PUD3
      FUS3=3.*PUS3
      FSS3=3.*PSS3
10    CONTINUE
C
C-- HANDLE QUARK AND DIQUARK IF GIVEN IN INPUT
      IFGEN=0
      IF(IFQIN.NE.0) THEN
        IQA=ABS(IFQIN)
        ISN=IFQIN/IQA
      ENDIF
      IF(IFDQIN.NE.0) THEN
        IFDQA=ABS(IFDQIN)
        ISN=IFDQIN/IFDQA
        IQB=IFDQA/1000
        IQC=MOD(IFDQA/100,10)
        ISPDQ=MOD(IFDQA,10)
      ENDIF
C
100   CONTINUE
C
C-- GENERATE QUARK IF NOT GIVEN IN INPUT, OTHERWISE HANDLE IT
      IF(IFQIN.EQ.0) THEN
        IQA=1+INT(RNCJ(0)*(2.+PSQRK*KEYSTR))
        IFGEN=ISN*IQA
      ENDIF
C
C-- GENERATE DIQUARK IF NOT GIVEN IN INPUT
      IF(IFDQIN.EQ.0) THEN
110     CONTINUE
        IQB=1+INT(RNCJ(0)*(2.+KEYSTR))
        IQC=1+INT(RNCJ(0)*(2.+KEYSTR))
        ISPDQ=0
        IF(IQC.GE.IQB) ISPDQ=1
        IQX=MAX(IQB,IQC)
        IQM=MIN(IQB,IQC)
        IF(ISPDQ.EQ.0.AND.IQX.EQ.3) THEN
          IF(RNCJ(0).GT.PUS1) GO TO 110
        ELSEIF(ISPDQ.EQ.1) THEN
          IF(IQX.LE.2) THEN
            IF(RNCJ(0).GT.FUD3) GO TO 110
          ELSEIF(IQM.LE.2) THEN
            IF(RNCJ(0).GT.FUS3) GO TO 110
          ELSE
            IF(RNCJ(0).GT.FSS3) GO TO 110
          ENDIF
        ENDIF
        IFGEN=ISN*(1000*IQM+100*IQX+ISPDQ)
      ENDIF
C
C-- REJECT ACCORDING TO SU(6) FACTORS FOR SYMMETRIC 3-QUARK STATE
      IF(ISPDQ.EQ.0) THEN
        KTAB=1
      ELSEIF(IQB.EQ.IQC) THEN
        KTAB=3
      ELSE
        KTAB=5
      ENDIF
      IF(IQA.NE.IQB.AND.IQA.NE.IQC) KTAB=KTAB+1
      IF(IQA.EQ.IQB.AND.IQA.EQ.IQC) THEN
        SU6TOT=SU6DEC(KTAB)
      ELSE
        SU6TOT=SU6OCT(KTAB)+SU6DEC(KTAB)*KEYSPN
      ENDIF
      IF(IFQIN.EQ.0.OR.IFDQIN.EQ.0) THEN
        IF(RNCJ(0).GT.SU6TOT) GO TO 100
      ENDIF
C
C-- DECIDE OCTET/DECUPLET, LAMBDA/SIGMA LIKE
      LQA=MIN(IQA,IQB,IQC)
      LQC=MAX(IQA,IQB,IQC)
      LQB=IQA+IQB+IQC-LQA-LQC
      ISPIN=0
      IF(SU6TOT*RNCJ(0).GT.SU6OCT(KTAB)) ISPIN=1
      LSINV=0
      IF(ISPIN.EQ.0.AND.LQA.NE.LQB.AND.LQB.NE.LQC) THEN
        IF(ISPDQ.EQ.0) THEN
          IF(IQA.EQ.LQC) THEN
            LSINV=1
          ELSE
            LSINV=INT(.25+RNCJ(0))
          ENDIF
        ELSEIF(IQA.NE.LQC) THEN
          LSINV=INT(.75+RNCJ(0))
        ENDIF
      ENDIF
C
C-- BARYON CODE
      IF(LSINV.EQ.0) THEN
        IDBARY=ISN*(1000*LQA+100*LQB+10*LQC+ISPIN)
      ELSE
        IDBARY=ISN*(1000*LQB+100*LQA+10*LQC+ISPIN)
      ENDIF
C
      RETURN
      END
CDECK  ID>, CJBASK.
      SUBROUTINE CJBASK(INOUT,ICODE)
C     ******************************
C-- HANDLES LEFTOVER FLAVORS FOR FINAL BALANCE BY MEANS OF (SOFT)
C-- PARTICLE GENERATION (ISAJET CODES ONLY)
C-- INOUT = 1  : COLLECTS LEFTOVER PARTON ICODE
C--              (IF ICODE=0 IN INPUT, RESET);
C-- INOUT.NE.1 : GENERATES A PARTICLE ICODE UNTIL BALANCE IS REACHED,
C--              AFTER THAT ICODE=0 IS RETURNED
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION KFLAV(6),IQ(3)
C
      IF(INOUT.NE.1) GO TO 100
C
C-- RESET
      IF(ICODE.EQ.0) THEN
        NBARYO=0
        DO 10 L=1,6
10      KFLAV(L)=0
        IFIRST=1
        RETURN
      ENDIF
C
C-- INPUT LEFTOVER
      IA=ABS(ICODE)
      ISN=ICODE/IA
      IF(IA.LT.10) THEN
        KFLAV(IA)=KFLAV(IA)+ISN
      ELSE
        NBARYO=NBARYO+ISN
        IA1=IA/1000
        IA2=MOD(IA/100,10)
        KFLAV(IA1)=KFLAV(IA1)+ISN
        KFLAV(IA2)=KFLAV(IA2)+ISN
      ENDIF
      RETURN
C
C-- GENERATE A PARTICLE CODE IF BALANCE IS NOT REACHED,
C-- OTHERWISE RETURN ICODE=0
100   CONTINUE
      IF(IFIRST.EQ.1) THEN
        IFIRST=0
        NL=0
        DO 114 L=1,6
114     IF(ABS(KFLAV(L)).NE.0) NL=L
        IF(NL.EQ.0) THEN
          ICODE=0
          RETURN
        ENDIF
      ENDIF
C
      NTOT=0
      DO 110 L=1,NL
      NFA=ABS(KFLAV(L))
      IF(NFA.NE.0) NLL=L
110   NTOT=NTOT+NFA
      NL=NLL
      IF(NTOT.EQ.0) THEN
        ICODE=0
        RETURN
      ENDIF
C
C-- GENERATE BARYON IF POSSIBLE
      IF(NBARYO.NE.0) THEN
        ISNBAR=NBARYO/ABS(NBARYO)
        NTOT=0
        DO 111 L=1,NL
111     IF(ISNBAR*KFLAV(L).GT.0) NTOT=NTOT+ABS(KFLAV(L))
        DO 112 K1=1,3
        N=1+INT(RNCJ(0)*NTOT)
        NR=0
        DO 113 L=1,NL
        IF(ISNBAR*KFLAV(L).GT.0) NR=NR+ABS(KFLAV(L))
        IF(NR.GE.N) THEN
          KFLAV(L)=KFLAV(L)-ISNBAR
          NTOT=NTOT-1
          IQ(K1)=L
          GO TO 112
        ENDIF
113     CONTINUE
112     CONTINUE
        IQA=MIN(IQ(1),IQ(2),IQ(3))
        IQC=MAX(IQ(1),IQ(2),IQ(3))
        IQB=IQ(1)+IQ(2)+IQ(3)-IQA-IQC
C-- FULL FLAVOR SYMMETRY --> DECUPLET
        IF(IQA.EQ.IQB.AND.IQB.EQ.IQC) THEN
          ICODE=ISNBAR*(1110*IQA+1)
C-- FORCE LAMBDA-LIKE COMBINATION WHEN APPROPRIATE
        ELSEIF(IQA.LT.IQB.AND.IQB.LT.IQC) THEN
          ICODE=ISNBAR*(1000*IQB+100*IQA+10*IQC+0)
C-- FORCE OCTET
        ELSE
          ICODE=ISNBAR*(1000*IQA+100*IQB+10*IQC+0)
        ENDIF
        NBARYO=NBARYO-ISNBAR
C
C-- GENERATE MESON OTHERWISE
      ELSE
        NTOT=NTOT/2
        DO 122 K1=1,2
        ISN=(-1)**K1
        N=1+INT(RNCJ(0)*NTOT)
        NR=0
        DO 123 L=1,NL
        IF(ISN*KFLAV(L).GT.0) NR=NR+ABS(KFLAV(L))
        IF(NR.GE.N) THEN
          KFLAV(L)=KFLAV(L)-ISN
          IQ(K1)=ISN*L
          GO TO 122
        ENDIF
123     CONTINUE
122     CONTINUE
C-- FORCE PSEUDOSCALARS, NEUTRAL PIONS WHEN POSSIBLE
        CALL CJMESO(IQ(1),IQ(2),0,0,ICODE)
      ENDIF
C
      RETURN
      END
CDECK  ID>, CJBGEV.
      SUBROUTINE CJBGEV
C     *****************
C-- HANDLES W AND Z (OR DRELL-YAN) EVENT GENERATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      LOGICAL ACCEPT
      DATA NACCPL/0/
      DATA ICALL/0/
C
      IF(ICALL.EQ.0) CALL CJBPRE
      ICALL=1
700   IFIREF=0
C
C-- INITIALIZATION
C-- EVOLUTION SCALE
      IF(IEVTYP.EQ.4) THEN
        QSQ=SXX
      ELSE
        QSQ=MAX(BIM2,BIML2)
      ENDIF
      ALQ=(LOG(QSQ)-ALLAM2)/ALQZM
      YQSQ=LOG(ALQ)
C-- GENERATE PAIR OF INITIAL PARTONS
      CALL CJBGPA
C-- GENERATE PARTON CASCADE (LLA QCD)
      JBOOK=2
      DO 12 IB=1,2
      NBOOK(IB)=1
      MBOOK(IB)=0
      ISTOP(IB)=0
12    IBACK(IB)=0
      IBEAM=1
      ZERO=0.
      CALL CJQSGE(IFLING(1),ZERO,YIN1,QSQIN1)
      CALL CJBOOK(IFLING(1),0,XMING(1),YIN1,XING(1),PXING(1),PYING(1)
     +,ZERO,YF)
      IBACK(IBEAM)=0
100   CONTINUE
      IBEAM=1
      CALL CJEVOL(1,YQSQ)
      MMBOOK=MAX(MMBOOK,MBOOK(1))
      IF(ISTOP(1).EQ.1) GO TO 200
      MBOOK(2)=0
      IBEAM=2
      CALL CJQSGE(IFLING(2),ZERO,YIN2,QSQIN2)
      CALL CJBOOK(IFLING(2),0,XMING(2),YIN2,XING(2),PXING(2),PYING(2)
     +,ZERO,YF)
      IBACK(IBEAM)=0
      ISTOP(IBEAM)=0
150   CONTINUE
      IFAIL=0
      IFLGHV=0
      CALL CJEVOL(1,YQSQ)
      MMBOOK=MAX(MMBOOK,MBOOK(2))
      IF(ISTOP(2).EQ.1) GO TO 100
C-- PREPARE TO ENTER HARD PROCESS
      IFLA1=PARACT(1,1,1)
      XM1=PARACT(1,3,1)
      XP1=PARACT(1,5,1)
      PX1=PARACT(1,6,1)
      PY1=PARACT(1,7,1)
      MFLA1=MIN(4,ABS(IFLA1))
      IFLA2=PARACT(1,1,2)
      XM2=PARACT(1,3,2)
      XP2=PARACT(1,5,2)
      PX2=PARACT(1,6,2)
      PY2=PARACT(1,7,2)
C
C-- CHECK IF RIGHT FLAVOR COMBINATION
      IF(IFLA1.EQ.LGLU.OR.IFLA2.EQ.LGLU) GO TO 150
      IF(IEVTYP.EQ.3) THEN
C-- W BOSON
        IF(IFLA1*IFLA2.GE.0) GO TO 150
        IIFLA=IMATBO(ABS(IFLA1),ABS(IFLA2))
        IF(IIFLA.EQ.0) GO TO 150
        IF(IIFLA.EQ.1) GO TO 310
        IF(RNCJ(IIFLA).GT.TG2CAB) GO TO 150
      ELSE
C-- Z BOSON
        IF((IFLA1+IFLA2).NE.0) GO TO 150
      ENDIF
C
310   SHAT=(XP1*XP2+XM1*XM2)*S-2.*(PX1*PX2+PY1*PY2)
C
      IF(IEVTYP.EQ.3) THEN
C-- W
        IF(SHAT.LT.BIML2) GO TO 150
        SX=SHAT
        SIG=SW(1)*SX/((SX-SW(2))**2+SW(3))
C-- CBR & FACTSW CALCULATION -- FROZEN IN CJBPRE IF NFLAV < 6
        IF(NFLAV.LT.6) GO TO 320
        FACTSW=0.
        DO 401 ICH=IDB(KINTWP),IDB(KINTWP)+NDECW-1
        ICHW=ICH-IDB(KINTWP)+1
        IF(KACTW(ICHW).EQ.0) GO TO 401
        ID1=ABS(KDP(1,ICH))
        ID2=ABS(KDP(2,ICH))
        IF(ID1.NE.6.AND.ID2.NE.6) THEN
          FACTSW=FACTSW+BRW(ICHW)
        ELSEIF(SX.GT.(QMAS(ID1)+QMAS(ID2)+1.)**2) THEN
          RHO1=QMAS(ID1)**2/SX
          RHO2=QMAS(ID2)**2/SX
          RHOP=RHO1+RHO2
          RHOM2=(RHO1-RHO2)**2
          FSTOP=(1.-.5*RHOP-.5*RHOM2)*SQRT(ABS(1.-2.*RHOP+RHOM2))
          FACTSW=FACTSW+BRW(ICHW)*FSTOP
        ENDIF
401     CBR(ICH)=FACTSW
320     CONTINUE
        SIG=SIG*FACTSW
C
        IF(SIGX*RNCJ(0).GT.SIG) GO TO 150
C
        CHARGT=CHRGCJ(IFLA1)+CHRGCJ(IFLA2)
        IF(CHARGT.GT.0.) THEN
          IDBOS=IDWP
        ELSE
          IDBOS=IDWM
        ENDIF
C
        IF(NFLAV.EQ.6) THEN
          DO 402 ICH=IDB(KINTWP),IDB(KINTWP)+NDECW-1
402       CBR(ICH)=CBR(ICH)/FACTSW
        ENDIF
C
      ELSE
C
C-- Z AND DY
        IF(SHAT.LT.BIML2.OR.SHAT.GT.BIMX2) GO TO 150
        SX=SHAT
        LXI=1
        IF(CHRGCJ(ABS(IFLA1)).LT.0) LXI=2
        LXF=NDECZ1
        RHO4=0.
        SIG=ZXSECJ(DUMMY)
        IF(KACTZ(IZTOP-IDB(KINTZ)+1).GT.0.AND.SHAT.GT.TPTHR2) THEN
          LXF=NDECZ
          RHO4=SZ(3)/SHAT
          SIG=SIG+ZXSECJ(DUMMY)
        ENDIF
C
        IF(SIGX*RNCJ(0).GT.SIG) GO TO 150
        IDBOS=IDZ
C
        TBR=0.
        DO 17 LXF=1,NDECZ
        ICH=IDB(KINTZ)-1+LXF
        IF(KACTZ(LXF).EQ.0) GO TO 17
        IF(LXF.EQ.IZTOP) THEN
          IF(SX.LE.TPTHR2) GO TO 17
          RHO4=SZ(3)/SHAT
          TBR=TBR+ZXSECJ(DUMMY)
        ELSE
          RHO4=0.
          TBR=TBR+ZXSECJ(DUMMY)
        ENDIF
17      CBR(ICH)=TBR
C
        DO 18 ICH=IDB(KINTZ),IDB(KINTZ)+NDECZ-1
18      CBR(ICH)=CBR(ICH)/TBR
C
      ENDIF
C
C-- GENERATE EVENT
      NHEP=0
      CALL CJTEVO(IACT1,IACT2)
C
      CALL CJBOSO(IDBOS,IACT1,IACT2)
      IF(IFAIL.EQ.1) GO TO 150
C
      NHEPF=NHEP
      IF(NOFRGM.EQ.0) CALL CJHADR(1,NHEPF,1)
      IF(IFAIL.EQ.1) GO TO 150
C
      DO 31 I=1,NHEP
      DO 31 J=1,4
31    VHEP(J,I)=0.
C
C-- DECAY UNSTABLE PARTICLES
      IF(NODECY.EQ.0) CALL CJDECY(1,0)
      IF(IFAIL.EQ.1) GO TO 150
      IF(IFLGHV.EQ.1) GO TO 150
      NEVGEN=NEVGEN+1
      MNHEP=MAX(MNHEP,NHEP)
C
      IF(KREPET.EQ.0) THEN
        IF(NOUNST.EQ.1) CALL CJSTAB
        IF(NOPDG.EQ.0) CALL CJPDG(1)
        NEVHEP=NEVHEP+1
        ACCEPT=.TRUE.
        CALL CJUSER(ACCEPT)
        IF(.NOT.ACCEPT) NEVHEP=NEVHEP-1
        IF(NEVHEP.NE.NACCPL) THEN
          IF(NEVHEP.LE.NDUMP.AND.
     &    (MOD(NEVHEP,NJUMP).EQ.1.OR.NJUMP.EQ.1))
     *    CALL CJDUMP
          NACCPL=NEVHEP
        ENDIF
      ELSE
        CALL CJREPT
      ENDIF
      IFIREF=1
      IF(NEVHEP.GE.NLEAVE) RETURN
      GO TO 150
C
C-- CHECK FOR EXIT
200   CONTINUE
      IF(IFIREF.EQ.0) GO TO 700
C
      RETURN
      END
CDECK  ID>, CJBGEX.
      SUBROUTINE CJBGEX(X,IX)
C     ***********************
C-- GENERATES ONE INITIAL PARTON -- CALLED BY CJBGPA
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
C
      IX=INT(NXBIN*RNCJ(1))+1
      IF(RNCJ(2).GT.TBXAL(IX)) IX=LBXAL(IX)
      X=XV(IX)+(XV(IX+1)-XV(IX))*RNCJ(3)
      RETURN
      END
CDECK  ID>, CJBGPA.
      SUBROUTINE CJBGPA
C     *****************
C-- GENERATES PAIR OF INITIAL PARTONS - CALLED BY CJBGEV
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER IXV(2)
      DATA ICALL/0/
C
C-- INITIALIZATION
      IF(ICALL.GT.0) GO TO 9
      ICALL=1
C-- CUMULATE TABQRK OVER FLAVORS AND NORMALIZE
      TBXT=0.
      DO 1 IX=1,NXBIN
      DO 2 J=2,7
2     TABQRK(IX,J)=TABQRK(IX,J)+TABQRK(IX,J-1)
      TBXAL(IX)=TABQRK(IX,7)
      TBXT=TBXT+TBXAL(IX)
      DO 1 J=1,7
1     TABQRK(IX,J)=TABQRK(IX,J)/TABQRK(IX,7)
C-- PREPARE ALIAS GENERATION OVER TOTAL X DISTRIBUTION
      DO 6 IX=1,NXBIN
6     TBXAL(IX)=TBXAL(IX)/TBXT
      CALL CJALIA(LBXAL,TBXAL,LWORKX,NXBIN)
C
9     CONTINUE
C
C-- INITIAL PARTON GENERATION
10    NGEX=NGEX+1
      DO 75 L=1,2
75    CALL CJBGEX(XING(L),IXV(L))
      SHAT=XING(1)*XING(2)*S
      IF(SHAT.LT.BIML2) GO TO 10
C
      DO 72 L=1,2
C-- PT
73    PT2=-PT2INT*LOG(RNCJ(L))
      XMING(L)=PT2/(XING(L)*S)
      IF(XMING(L).GT.XING(L)) GO TO 73
      PT=SQRT(PT2)
      PHI=PI2*RNCJ(L+1)
      PXING(L)=PT*COS(PHI)
      PYING(L)=PT*SIN(PHI)
C-- FLAVOR
      IX=IXV(L)
      RR=RNCJ(L+2)
      ICHING(L)=1
      DO 76 J=7,2,-1
      IF(RR.GT.TABQRK(IX,J-1)) THEN
        ICHING(L)=J
        GO TO 72
      ENDIF
76    CONTINUE
72    CONTINUE
      CALL CJGCOD(ICHING,IFLING)
C
      RETURN
      END
CDECK  ID>, CJBJET.
      SUBROUTINE CJBJET(IQRKFW,IPD,IDBOS,BOSMAS,IPD1,IPD2,COSROT,KROT)
C     ****************************************************************
C-- HANDLES NON-LEPTONIC DECAY MODES OF WEAK BOSON
C--  KROT = 0 : ROTATION IN Z/W CMS MADE ACCORDING TO INPUT COSROT
C--  KROT = 1 : ROTATION IN Z/W CMS MADE ACCORDING TO INTERNALLY
C--             GENERATED COSROT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
C-- INITIALIZATION FOR JET GENERATION (PARTONS)
      NHEPB=NHEP+1
      IDA1=ABS(IDHEP(IPD1))
      IDA2=ABS(IDHEP(IPD2))
      W2=BOSMAS**2
      PCM2X=(W2-(QZFL(IDA1)+QZFL(IDA2))**2)
     &*(W2-(QZFL(IDA1)-QZFL(IDA2))**2)/(4.*W2)
      QSQW1=PCM2X+QZFLSQ(IDA1)
      QSQW2=PCM2X+QZFLSQ(IDA2)
31    CONTINUE
      CALL CJQTGE(IDHEP(IPD1),QSQW1,QSQ1,IGO)
      CALL CJQTGE(IDHEP(IPD2),QSQW2,QSQ2,IGO)
      Q1=SQRT(QSQ1)
      Q2=SQRT(QSQ2)
      IF(Q1+Q2.GE.BOSMAS) GO TO 31
      PCM2=(W2-(Q1+Q2)**2)*(W2-(Q1-Q2)**2)/(4.*W2)
      PCM=SQRT(PCM2)
      E1=SQRT(QSQ1+PCM2)
      E2=SQRT(QSQ2+PCM2)
C
C-- 1ST JET (PARTONS)
      PHEP(1,IPD1)=0.
      PHEP(2,IPD1)=0.
      PHEP(3,IPD1)=PCM
      PHEP(4,IPD1)=E1
      PHEP(5,IPD1)=Q1
      JMOHEP(1,IPD1)=IPD
      JMOHEP(2,IPD1)=0
      JDAHEP(1,IPD1)=0
      JDAHEP(2,IPD1)=0
      ISTHEP(IPD1)=1
      CALL CJJETQ(IPD1)
C
C-- 2ND JET (PARTONS)
      PHEP(1,IPD2)=0.
      PHEP(2,IPD2)=0.
      PHEP(3,IPD2)=-PCM
      PHEP(4,IPD2)=E2
      PHEP(5,IPD2)=Q2
      JMOHEP(1,IPD2)=IPD
      JMOHEP(2,IPD2)=0
      JDAHEP(1,IPD2)=0
      JDAHEP(2,IPD2)=0
      ISTHEP(IPD2)=1
      CALL CJJETQ(IPD2)
C
C-- HADRONIZATION
      IF(NOFRGM.EQ.0) THEN
        NHEPI=NHEP+1
        CALL CJHADR(IPD1,IPD2,0)
        NHEPF=NHEP
        CALL CJHADR(NHEPB,NHEPF,0)
C-- CORRECT FOR EXACT BOSON MASS AFTER HADRONIZATION
        NHEPF=NHEP
        CALL CJHADC(BOSMAS,NHEPI,NHEPF)
        IF(IFAIL.EQ.1) RETURN
      ENDIF
C
C-- GENERATE COSROT IF KROT=1
      IF(KROT.EQ.1) THEN
        IF(IDHEP(IPD).EQ.IDZ) THEN
          CALL CJZANG(IQRKFW,IDHEP(IPD1),COSROT)
        ELSE
          CALL CJWANG(IQRKFW,IPD,IPD1,IPD2,COSROT)
        ENDIF
      ENDIF
C
C-- ROTATION
      CT=COSROT
      ST=SQRT(ABS(1.-CT**2))
      PHI=PI2*RNCJ(0.)
      CP=COS(PHI)
      SP=SIN(PHI)
      CALL CJROTP(IPD1,IPD2,CT,ST,CP,SP)
      NHEPF=NHEP
      CALL CJROTP(NHEPB,NHEPF,CT,ST,CP,SP)
C
      RETURN
      END
CDECK  ID>, CJBLBK.
      SUBROUTINE CJBLBK(IQRKFW,IPD,IDBOS,BOSMAS,IPD1,IPD2)
C     ****************************************************
C--  Z/W LEPTONIC DECAY WITH O(ALPHA) QED RADIATION ACCORDING TO
C--  BEREND & KLEISS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION QP(4),QM(4),QK(4),QE(4),QN(4)
C
C-- KINEMATICS
      AM1=AMASCJ(IDHEP(IPD1))
      AM2=AMASCJ(IDHEP(IPD2))
      WL=MAX(AM1,AM2)
C
      IF(IDBOS.NE.IDZ) GO TO 230
C
C--  Z DECAY
C    -------
      LQ=1
      IF(3.*CHRGCJ(ABS(IQRKFW)).LT.1.5) LQ=2
      CALL CJZDEC(BOSMAS**2,WL,AL(1),BL(1),AQ(LQ),BQ(LQ)
     &,CHRGCJ(ABS(IQRKFW)),ZMASS,ZGAMMA,ALFQED,GMCZW,QP,QM,QK)
      NP=3
      IF(QK(4).EQ.0.0) NP=2
      IF(IQRKFW.LT.0) GO TO 201
      QP(2)=-QP(2)
      QP(3)=-QP(3)
      QM(2)=-QM(2)
      QM(3)=-QM(3)
      QK(2)=-QK(2)
      QK(3)=-QK(3)
201   CONTINUE
      DO 202 J=1,4
202   PHEP(J,IPD1)=QM(J)
      PHEP(5,IPD1)=WL
      JMOHEP(1,IPD1)=IPD
      JMOHEP(2,IPD1)=0
      JDAHEP(1,IPD1)=0
      JDAHEP(2,IPD1)=0
      ISTHEP(IPD1)=1
      DO 205 J=1,4
205   PHEP(J,IPD2)=QP(J)
      PHEP(5,IPD2)=WL
      JMOHEP(1,IPD2)=IPD
      JMOHEP(2,IPD2)=0
      JDAHEP(1,IPD2)=0
      JDAHEP(2,IPD2)=0
      ISTHEP(IPD2)=1
C-- ADDITIONAL PHOTON
      IF(NP.EQ.2) RETURN
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      DO 204 J=1,4
204   PHEP(J,NHEP)=QK(J)
      PHEP(5,NHEP)=0.
      IDHEP(NHEP)=10
      JMOHEP(1,NHEP)=IPD
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      ISTHEP(NHEP)=1
      RETURN
C
C--  W DECAY
C    -------
230   CONTINUE
      CALL CJWDEC(BOSMAS**2,WMASS,WL,WGAMMA,ALFQED,GMCZW,QE,QN,QK)
      NP=3
      IF(QK(4).EQ.0.0) NP=2
      IF(IQRKFW.GT.0) GO TO 231
      QE(2)=-QE(2)
      QE(3)=-QE(3)
      QN(2)=-QN(2)
      QN(3)=-QN(3)
      QK(2)=-QK(2)
      QK(3)=-QK(3)
231   CONTINUE
      FCH=1.
      IF(IDBOS.EQ.IDWP) FCH=-1.
      DO 233 J=1,3
233   PHEP(J,IPD1)=FCH*QN(J)
      PHEP(4,IPD1)=QN(4)
      PHEP(5,IPD1)=0.
      JMOHEP(1,IPD1)=IPD
      JMOHEP(2,IPD1)=0
      JDAHEP(1,IPD1)=0
      JDAHEP(2,IPD1)=0
      ISTHEP(IPD1)=1
      DO 234 J=1,3
234   PHEP(J,IPD2)=FCH*QE(J)
      PHEP(4,IPD2)=QE(4)
      PHEP(5,IPD2)=WL
      JMOHEP(1,IPD2)=IPD
      JMOHEP(2,IPD2)=0
      JDAHEP(1,IPD2)=0
      JDAHEP(2,IPD2)=0
      ISTHEP(IPD2)=1
C-- ADDITIONAL PHOTON
      IF(NP.EQ.2) RETURN
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      DO 237 J=1,3
237   PHEP(J,NHEP)=-PHEP(J,IPD1)-PHEP(J,IPD2)
      PHEP(4,NHEP)=QK(4)
      IDHEP(NHEP)=10
      JMOHEP(1,NHEP)=IPD
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      ISTHEP(NHEP)=1
C
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS  ',I10
     1//1X,'***IN SUBROUTINE CJBLBK'
     1//1X,'***EVENT NO. =  ',I10
     3//1X,'***INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJBLEP.
      SUBROUTINE CJBLEP(IQRKFW,IPD,IDBOS,BOSMAS,IPD1,IPD2,COSINP,KROT)
C     ****************************************************************
C--  HANDLES LEPTONIC DECAY MODES OF WEAK BOSON INCLUDING QED
C--  RADIATION TREATED IN LLA WITH MATRIX ELEMENT CORRECTION
C--  KROT = 0 : ROTATION IN Z/W CMS MADE ACCORDING TO INPUT COSINP
C--             (TOP DECAY)
C--  KROT = 1 : ROTATION IN Z/W CMS MADE ACCORDING TO INTERNALLY
C--             GENERATED COSROT (DRELLYAN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      PARAMETER (MAXRAD=100)
      COMMON/CJZWRA/P(MAXRAD,5)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
C-- KINEMATICS
      AM1=AMASCJ(IDHEP(IPD1))
      AM2=AMASCJ(IDHEP(IPD2))
      WL=MAX(AM1,AM2)
C
      COSROT=COSINP
      IF(IDBOS.NE.IDZ) GO TO 130
C
C--  Z DECAY
C    -------
      IF(KYWQED.EQ.0) NORAD=1
      IF(ABS(CHRGCJ(IDHEP(IPD1))).LT..5.AND.
     &   ABS(CHRGCJ(IDHEP(IPD2))).LT..5) NORAD=1
      CALL CJZRAD(BOSMAS,WL,NP,NORAD)
      MNRAD=MAX(MNRAD,NP)
C-- 1ST ENTRY IN ARRAY FROM CJZRAD IS CHARGED LEPTON ALIGNED ALONG -Z.
C-- LAST ENTRY IS THE OTHER CHARGED LEPTON.
C-- INV=1 --> NEGATIVE LEPTON FIRST IN ARRAY
      INV=-1
      IF(NP.GT.2.AND.RNCJ(1).GT..5) INV=1
      IF(INV.GT.0) THEN
        IPAR1=IPD1
        IPAR2=IPD2
      ELSE
        IPAR1=IPD2
        IPAR2=IPD1
      ENDIF
      DO 11 J=1,5
11    PHEP(J,IPAR1)=P(1,J)
      JMOHEP(1,IPAR1)=IPD
      JMOHEP(2,IPAR1)=0
      JDAHEP(1,IPAR1)=0
      JDAHEP(2,IPAR1)=0
      ISTHEP(IPAR1)=1
      DO 12 J=1,5
12    PHEP(J,IPAR2)=P(NP,J)
      JMOHEP(1,IPAR2)=IPD
      JMOHEP(2,IPAR2)=0
      JDAHEP(1,IPAR2)=0
      JDAHEP(2,IPAR2)=0
      ISTHEP(IPAR2)=1
      NHEPG=NHEP+1
      IF(NP.EQ.2) THEN
C-- NO PHOTON EMISSION
        IF(KROT.EQ.1) CALL CJZANG(IQRKFW,IDHEP(IPD1),COSROT)
        GO TO 401
      ENDIF
C-- ADDITIONAL PHOTONS
      DO 108 I=2,NP-1
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      DO 13 J=1,5
13    PHEP(J,NHEP)=P(I,J)
      IDHEP(NHEP)=10
      JMOHEP(1,NHEP)=IPD
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      ISTHEP(NHEP)=1
108   CONTINUE
C-- ANGULAR DISTRIBUTION OF LEPTONS AS IN O(ALPHA) (NP > 2)
      IF(KROT.NE.1) GO TO 401
C-- NOTE: LXI,SX ETC. DEFINED FROM OUTSIDE
      LXF=1
      FS1=SX*DS*DEN
      FS2=SX**2*DEN
      ABW1=SZF(1,LXI,LXF)
     *    +SZF(2,LXI,LXF)*FS1
     *    +SZF(5,LXI,LXF)*FS2
      ABW2=(SZF(7,LXI,LXF)*FS1+SZF(8,LXI,LXF)*FS2)*.5
      F=1.
      IF(IQRKFW.LT.0) F=-F
      IF(INV.LT.0) F=-F
      C1=ABW1-F*ABW2
      C2=ABW1+F*ABW2
      EF=P(1,4)
      EL=P(NP,4)
      WGX=4.*(EF**2+EL**2)*(C1+C2)
C
103   CALL CJGROT(NP,PF3,PL3,COSROT,ST,CG,SG)
      WG=C1*((EF-PF3)**2+(EL+PL3)**2)
     &  +C2*((EF+PF3)**2+(EL-PL3)**2)
      IF(RNCJ(1).GT.WG/WGX) GO TO 103
C-- PRELIMINARY AZIMUTHAL ROTATION FOR NP > 2
      ONE=1.
      ZERO=0.
      CALL CJROTP(IPD1,IPD2,ONE,ZERO,CG,SG)
      NHEPF=NHEP
      CALL CJROTP(NHEPG,NHEPF,ONE,ZERO,CG,SG)
      GO TO 401
C
130   CONTINUE
C
C--  W DECAY
C    -------
      IF(KYWQED.EQ.0) NORAD=1
      CALL CJWRAD(BOSMAS,WL,NP,NORAD)
      MNRAD=MAX(MNRAD,NP)
      DO 21 J=1,5
21    PHEP(J,IPD1)=P(1,J)
      JMOHEP(1,IPD1)=IPD
      JMOHEP(2,IPD1)=0
      JDAHEP(1,IPD1)=0
      JDAHEP(2,IPD1)=0
      ISTHEP(IPD1)=1
      DO 22 J=1,5
22    PHEP(J,IPD2)=P(NP,J)
      JMOHEP(1,IPD2)=IPD
      JMOHEP(2,IPD2)=0
      JDAHEP(1,IPD2)=0
      JDAHEP(2,IPD2)=0
      ISTHEP(IPD2)=1
      NHEPG=NHEP+1
      IF(NP.EQ.2) THEN
C-- NO PHOTON EMISSION
        IF(KROT.EQ.1) CALL CJWANG(IQRKFW,IPD,IPD1,IPD2,COSROT)
C-- REFLECTION BECAUSE CJWRAD DIRECTS 1ST DECAY PARTICLE (NU)
C-- ALONG -Z
        COSROT=-COSROT
        GO TO 401
      ENDIF
C-- ADDITIONAL PHOTONS
      DO 136 I=2,NP-1
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      DO 23 J=1,5
23    PHEP(J,NHEP)=P(I,J)
      IDHEP(NHEP)=10
      JMOHEP(1,NHEP)=IPD
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      ISTHEP(NHEP)=1
136   CONTINUE
C
C-- ANGULAR DISTRIBUTION OF LEPTONS AS IN O(ALPHA) (NP > 2)
      IF(KROT.NE.1) GO TO 401
      EN=P(1,4)
      EC=P(NP,4)
      WGX=4.*(EN**2+EC**2)
      F=1.
      IF(IQRKFW.LT.0) F=-F
      IF(IDBOS.EQ.IDWM) F=-F
133   CALL CJGROT(NP,PN3,PC3,COSROT,ST,CG,SG)
      WG=(EN+F*PN3)**2+(EC-F*PC3)**2
      IF(RNCJ(1).GT.WG/WGX) GO TO 133
C-- PRELIMINARY AZIMUTHAL ROTATION FOR NP > 2
      ONE=1.
      ZERO=0.
      CALL CJROTP(IPD1,IPD2,ONE,ZERO,CG,SG)
      NHEPF=NHEP
      CALL CJROTP(NHEPG,NHEPF,ONE,ZERO,CG,SG)
C
401   CONTINUE
C
C--  FINAL ROTATION OF ARRAY
      SINROT=SQRT(ABS(1.-COSROT**2))
      PHI=PI2*RNCJ(1)
      CP=COS(PHI)
      SP=SIN(PHI)
      CALL CJROTP(IPD1,IPD2,COSROT,SINROT,CP,SP)
      NHEPF=NHEP
      CALL CJROTP(NHEPG,NHEPF,COSROT,SINROT,CP,SP)
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS  ',I10
     1//1X,'***IN SUBROUTINE CJBLEP'
     1//1X,'***EVENT NO. =  ',I10
     3//1X,'***INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJBOOK.
      SUBROUTINE CJBOOK(IFLA1,IBOOK,XM1,Y1,X1,PX1S,PY1S,YVI1,YVF1)
C     ************************************************************
C-- BOOKS SPACELIKE PARTONS GENERATED BY CJEVOL
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      NBK=NBOOK(IBEAM)
      IF(JBOOK.EQ.1)
     1NBK=NBK+1
      IF(NBK.GT.MXINQ) GO TO 500
      NBOOK(IBEAM)=NBK
      PARACT(NBK,1,IBEAM)=IFLA1
      PARACT(NBK,2,IBEAM)=IBOOK
      PARACT(NBK,3,IBEAM)=XM1
      PARACT(NBK,4,IBEAM)=Y1
      PARACT(NBK,5,IBEAM)=X1
      PARACT(NBK,6,IBEAM)=PX1S
      PARACT(NBK,7,IBEAM)=PY1S
      PARACT(NBK,8,IBEAM)=YVI1
      PARACT(NBK,9,IBEAM)=YVF1
      IBACK(IBEAM)=1
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) MXINQ,NEVOL
501   FORMAT(5(/),1X,'***NUMBER OF INITIAL STATE PARTONS EXCEEDS',I10
     1 //1X,'***CASCADE NO. =',I10
     2 //1X,'***IN SUBROUTINE CJBOOK'
     3 //1X,'***INCREASE MXINQ'
     5 )
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJBOSO.
      SUBROUTINE CJBOSO(IDBOS,IACT1,IACT2)
C     ************************************
C-- W AND Z BOSON (OR VIRTUAL DRELL-YAN PHOTON) KINEMATICS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION ACT1(4),ACT2(4)
C
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      IPD=NHEP
      DO 5 J=1,4
5     PHEP(J,IPD)=PHEP(J,IACT1)+PHEP(J,IACT2)
      PHEP(5,IPD)=SQRT(ABS(PHEP(4,IPD)**2-PHEP(1,IPD)**2
     &                    -PHEP(2,IPD)**2-PHEP(3,IPD)**2))
      IF(IEVTYP.NE.3) THEN
        IDHEP(IPD)=IDZ
      ELSE
        TCHARG=CHRGCJ(IDHEP(IACT1))+CHRGCJ(IDHEP(IACT2))
        IF(TCHARG.GT.0) THEN
          IDHEP(IPD)=IDWP
        ELSE
          IDHEP(IPD)=IDWM
        ENDIF
      ENDIF
      JMOHEP(1,IPD)=0
      JMOHEP(2,IPD)=0
      JDAHEP(1,IPD)=0
      JDAHEP(2,IPD)=0
      ISTHEP(IPD)=1
C
      IF(KDECAY(INIDCJ(IDHEP(IPD))).EQ.0) RETURN
C
      IQRKFW=IDHEP(IACT1)
C
C-- WEAK BOSON DECAY MODE
      IF(NHEP+2.GT.NMXHEP) GO TO 500
      IDCI=IDB(INIDCJ(IDBOS))
      TBR=RNCJ(0)
      IDC=IDCI-1
20    IDC=IDC+1
      IF(TBR.GT.CBR(IDC)) GO TO 20
      LXF=IDC-IDCI+1
      ID1=KDP(1,IDC)
      ID2=KDP(2,IDC)
      IPD1=NHEP+1
      IPD2=NHEP+2
      NHEP=NHEP+2
      IF(ID1.GT.0) THEN
        IDHEP(IPD1)=ID1
        IDHEP(IPD2)=ID2
      ELSE
        IDHEP(IPD1)=ID2
        IDHEP(IPD2)=ID1
      ENDIF
      IF(IDBOS.EQ.IDWM) THEN
        IDHEP(IPD1)=-IDHEP(IPD1)
        IDHEP(IPD2)=-IDHEP(IPD2)
      ENDIF
C
C-- GENERATION OF FINAL STATE
      IF(ABS(ID1).GT.6) THEN
C--     LEPTONIC DECAY MODES
        IF(KYWQED.EQ.2) THEN
          CALL CJBLBK(IQRKFW,IPD,IDHEP(IPD),PHEP(5,IPD),IPD1,IPD2)
        ELSE
          CALL CJBLEP(IQRKFW,IPD,IDHEP(IPD),PHEP(5,IPD),IPD1,IPD2,0.,1)
        ENDIF
        JDAHEP(1,IPD)=IPD1
        JDAHEP(2,IPD)=NHEP
        ISTHEP(IPD)=2
      ELSE
C--     HADRONIC DECAY MODES
        ZERO=0.
        CALL CJBJET(IQRKFW,IPD,IDHEP(IPD),PHEP(5,IPD),IPD1,IPD2,ZERO,1)
        IF(IFLGHV.EQ.1) RETURN
        IF(IFAIL.EQ.1) RETURN
        JDAHEP(1,IPD)=IPD1
        JDAHEP(2,IPD)=IPD2
        ISTHEP(IPD)=2
      ENDIF
C
C-- BOOST TO LAB SYSTEM
      DO 11 J=1,4
      ACT1(J)=PHEP(J,IACT1)
      ACT2(J)=PHEP(J,IACT2)
11    CONTINUE
      NHEPF=NHEP
      CALL CJLORL(ACT1,ACT2,IPD1,NHEPF)
C
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS  ',I10
     1//1X,'***IN SUBROUTINE CJBOSO'
     1//1X,'***EVENT NO. =  ',I10
     3//1X,'***INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJBPRE.
      SUBROUTINE CJBPRE
C     *****************
C-- W/Z (OR DRELL-YAN PAIR) PRODUCTION -- INITIALIZATION AND X-TABLES
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DATA ICALL/0/
      IF(ICALL.GT.0) RETURN
      ICALL=1
C
C
C-- INITIALIZATION
      NEVHEP=0
      S=ECM**2
      IF(IEVTYP.NE.3) GO TO 20
C
C-- W
      C2CAB=COSCAB**2
      TG2CAB=(1.-C2CAB)/C2CAB
      BIM=WMASS
      BIM2=BIM**2
      IF(ZWTHRS.LT.0.) ZWTHRS=WMASS-4.*WGAMMA
C-- AMN: MINIMUM ENERGY OF W DECAY CHANNELS
      AMN=ECM
      DO 40 ICH=IDB(KINTWP),IDB(KINTWP)+NDECW-1
      IF(KACTW(ICH-IDB(KINTWP)+1).EQ.0) GO TO 40
      A2=AMASCJ(KDP(1,ICH))+AMASCJ(KDP(2,ICH))
      IF(A2.LT.AMN) AMN=A2
40    CONTINUE
      AMN=(AMN+1.)*1.0001
      IF(ZWTHRS.LT.AMN)  ZWTHRS=AMN
      BIML2=ZWTHRS**2
C
      SW(1)=PI*ALFQED**2/(12.*SIN2W**2)/3.*C2CAB*UNITS
      SW(2)=BIM2
      SW(3)=BIM2*WGAMMA**2
C
C-- FACTSW AND CBR CALCULATION DONE & FROZEN HERE IF NFLAV < 6
      IF(NFLAV.EQ.6) GO TO 321
      FACTSW=0.
      DO 403 ICH=IDB(KINTWP),IDB(KINTWP)+NDECW-1
      ICHW=ICH-IDB(KINTWP)+1
      IF(KACTW(ICHW).EQ.0) GO TO 403
      ID1=ABS(KDP(1,ICH))
      ID2=ABS(KDP(2,ICH))
      IF(ID1.NE.6.AND.ID2.NE.6) FACTSW=FACTSW+BRW(ICHW)
403   CBR(ICH)=FACTSW
      DO 402 ICH=IDB(KINTWP),IDB(KINTWP)+NDECW-1
402   CBR(ICH)=CBR(ICH)/FACTSW
321   CONTINUE
C
C-- W SIGX
      DSX=BIM*WGAMMA
      SX=BIML2
      SIGOLD=0.
      DO 16 NITER=1,5
17    CONTINUE
      SIG=SW(1)*SX/((SX-SW(2))**2+SW(3))
C-- FACTSW CALCULATION DONE BEFORE OUT OF LOOP IF NFLAV < 6
      IF(NFLAV.LT.6) GO TO 320
      FACTSW=0.
      DO 401 ICH=IDB(KINTWP),IDB(KINTWP)+NDECW-1
      ICHW=ICH-IDB(KINTWP)+1
      IF(KACTW(ICHW).EQ.0) GO TO 401
      ID1=ABS(KDP(1,ICH))
      ID2=ABS(KDP(2,ICH))
      IF(ID1.NE.6.AND.ID2.NE.6) THEN
        FACTSW=FACTSW+BRW(ICHW)
      ELSEIF(SX.GT.(QMAS(ID1)+QMAS(ID2)+1.)**2) THEN
        RHO1=QMAS(ID1)**2/SX
        RHO2=QMAS(ID2)**2/SX
        RHOP=RHO1+RHO2
        RHOM2=(RHO1-RHO2)**2
        FSTOP=(1.-.5*RHOP-.5*RHOM2)*SQRT(ABS(1.-2.*RHOP+RHOM2))
        FACTSW=FACTSW+BRW(ICHW)*FSTOP
      ENDIF
401   CONTINUE
320   CONTINUE
C
      SIG=SIG*FACTSW
      IF(SIG.LE.SIGOLD) THEN
        SIGX=SIGOLD
        SIGOLD=0.
        SX=SX-2.*DSX
        IF(SX.LT.BIML2) SX=BIML2
        DSX=DSX*.1
        GO TO 16
      ELSE
        SIGOLD=SIG
        SX=SX+DSX
        GO TO 17
      ENDIF
16    CONTINUE
      FXSCT=SIGX
      GO TO 30
C
C-- Z
20    CONTINUE
      XW=SIN2W
      BIM=ZMASS
      BIM2=BIM**2
      TPTHR2=(2.*QMAS(6)+1.)**2
      IF(IEVTYP.EQ.2) THEN
        IF(ZWTHRS.LT.0.) ZWTHRS=ZMASS-4.*ZGAMMA
C-- AMN: MINIMUM ENERGY OF Z DECAY CHANNELS
        AMN=ECM
        DO 41 ICH=IDB(KINTZ),IDB(KINTZ)+NDECZ-1
        IF(KACTZ(ICH-IDB(KINTZ)+1).EQ.0) GO TO 41
        A2=AMASCJ(KDP(1,ICH))+AMASCJ(KDP(2,ICH))
        IF(A2.LT.AMN) AMN=A2
41      CONTINUE
        AMN=(AMN+1.)*1.0001
        IF(ZWTHRS.LT.AMN)  ZWTHRS=AMN
        BIML2=ZWTHRS**2
        BIMX2=ECM**2
      ELSE
        BIML2=BOMSMN**2
        BIMX2=BOMSMX**2
      ENDIF
      SZ(1)=BIM2
      SZ(2)=BIM2*ZGAMMA**2
      SZ(3)=4.*QMAS(6)**2
      DO 24 LL3=1,NDECZ1
      FACTSZ(LL3)=0.
      DO 24 LL2=1,2
      DO 24 LL=1,8
24    SZF(LL,LL2,LL3)=0.
C
      NXF=NDECZ
      FACTX=PI*ALFQED**2*2./9.*UNITS
      FXW=1./SQRT(ABS(XW*(1.-XW)))
      DO 23 LXF=1,NXF
      ICH=IDB(KINTZ)-1+LXF
      IF(KACTZ(LXF).EQ.0) GO TO 23
      ID1=ABS(KDP(1,ICH))
      IF(ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16) THEN
        QF=1.
        VF=AL(1)
        AF=BL(1)
        FCOLRS=1.
      ELSEIF(ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15) THEN
        QF=0.
        VF=AL(2)
        AF=BL(2)
        FCOLRS=1.
      ELSEIF(CHRGCJ(ID1).GT.0.) THEN
        QF=CHRGCJ(ID1)
        VF=AQ(1)
        AF=BQ(1)
        FCOLRS=3.
      ELSE
        QF=CHRGCJ(ID1)
        VF=AQ(2)
        AF=BQ(2)
        FCOLRS=3.
      ENDIF
      FACTSZ(LXF)=FACTX*FCOLRS
      VF=VF*FXW
      AF=AF*FXW
      DO 21 LXI=1,2
      QI=CHRGCJ(LXI)
      VI=AQ(LXI)*FXW
      AI=BQ(LXI)*FXW
      SZF(1,LXI,LXF)=QI**2*QF**2
      SZF(2,LXI,LXF)=-2.*QI*VI*QF*VF
      SZF(3,LXI,LXF)=2.*(VI**2+AI**2)*(VF**2+AF**2)
      SZF(4,LXI,LXF)=(VI**2+AI**2)*(VF**2-2.*AF**2)
      SZF(5,LXI,LXF)=.5*SZF(3,LXI,LXF)
      SZF(6,LXI,LXF)=(VI**2+AI**2)*(VF**2-AF**2)
      SZF(7,LXI,LXF)=-4.*QI*AI*QF*AF
      SZF(8,LXI,LXF)=8.*VI*AI*VF*AF
      IF(ICH.NE.IZTOP) THEN
        DO 25 LL=1,8
25      SZF(LL,LXI,NDECZ1)=SZF(LL,LXI,NDECZ1)+FCOLRS*SZF(LL,LXI,LXF)
      ENDIF
21    CONTINUE
23    CONTINUE
      FACTSZ(NDECZ1)=FACTX
C-- Z SIGX
      SIGX=0.
      DO 28 LXI=1,2
      DSX=BIM*ZGAMMA
      SX=BIML2
      SIGOLD=0.
      SXSTOP=BIMX2
      DO 14 NITER=1,5
15    CONTINUE
      LXF=NDECZ1
      RHO4=0.
      SIG=ZXSECJ(DUMMY)
      IF(KACTZ(IZTOP-IDB(KINTZ)+1).GT.0.AND.SX.GT.TPTHR2) THEN
        LXF=IZTOP-IDB(KINTZ)+1
        RHO4=SZ(3)/SX
        SIG=SIG+ZXSECJ(DUMMY)
      ENDIF
      IF(IEVTYP.EQ.2) THEN
        IF(SIG.LE.SIGOLD) THEN
          SIG=SIGOLD
          SIGOLD=0.
          SX=SX-2.*DSX
          IF(SX.LT.BIML2) SX=BIML2
          DSX=DSX*.1
          GO TO 14
        ELSE
          SIGOLD=SIG
          SX=SX+DSX
          GO TO 15
        ENDIF
      ELSE
        IF(SIG.GT.SIGOLD) THEN
          SIGOLD=SIG
          SXX=SX
        ENDIF
        SX=SX+DSX
        IF(SX.LT.SXSTOP) GO TO 15
        SIG=SIGOLD
        DSX=DSX*.1
        SX=SXX-10.*DSX
        IF(SX.LT.BIML2) SX=BIML2
        SXSTOP=SXX+10.*DSX
        IF(SXSTOP.GT.BIMX2) SXSTOP=BIMX2
        GO TO 14
      ENDIF
14    CONTINUE
      IF(SIG.GT.SIGX) SIGX=SIG
28    CONTINUE
      FXSCT=SIGX
30    CONTINUE
C
C-- INITIALIZE QCD STUFF
      JBOOK=1
      ALQZM=LOG((QZEVOL/ALAMBD)**2)
      ZSLW=EMCUT/ECM
      ZSUP=1.-ZSLW
      XMIN=(BIML2-5.*PT2INT)/ECM**2
      IF(IEVTYP.EQ.4) THEN
        ALQF=(LOG(SXX)-ALLAM2)/ALQZM
      ELSE
        ALQF=(LOG(MAX(BIM2,BIML2))-ALLAM2)/ALQZM
      ENDIF
      YF=LOG(ALQF)
      CALL CJQCDS
C
      CALL CJQCDT
C
C-- COMPLETE X-SECTION FACTOR
      FXSCT=FXSCT*(WGQ+WGG)**2
C
      RETURN
      END
CDECK  ID>, CJDATA.
      SUBROUTINE CJDATA
C     *****************
C-- OLD BLOCK DATA SETTINGS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJOVEC/SPYOVR,KOVER
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPMB/CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR(9)
      REAL CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR
      COMMON/CJPTHD/PTHARD,WEIGHT
      REAL PTHARD,WEIGHT
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION IMATCZ(7,7),IMATBZ(7,7)
      DATA IMATCZ/2,1,1,3*6,4, 1,2,1,3*6,4, 1,1,2,3*6,4,
     1            3*6,9,8,8,7, 3*6,8,9,8,7, 3*6,8,8,9,7,
     2            3*4,3*7,5/
      DATA IMATBZ/0,1,2,4*0, 1,2*0,2,3*0, 2,2*0,1,3*0,
     1            0,2,1,4*0, 5*0,1,0,     4*0,1,2*0,
     2            7*0/
C
C-- PROGRAM VERSION (*100, INTEGER)
      IDVER=623
      IDATVR=920210
      DAVERS='10 FEB 92'
C
C-- ELIMINATE UNSTABLE PARTICLES: TRUE/FALSE
      NOUNST=1
C
C-- SIN(THETA)**2 WEINBERG-SALAM, COS(CABIBBO ANGLE)
      SIN2W=.227
      COSCAB=.9737
C
C-- GENERAL PARAMETERS
C   ------------------
C- FACTK  = K FACTOR (FROM UA1)
C- ALAMBD = QCD LAMBDA (GEV)
C- PTCUT  = MIN PT CUTOFF FOR HARD PARTONS (GEV/C)
C- PTMIN  = IF PTMIN > PTCUT GENERATE ONLY HARD EVENTS WITH PT > PTMIN
C- PTMAX  = IF PTMAX > 0. GENERATE ONLY EVENTS WITH PT < PTMAX
C- PT2INT = MEAN KT**2 OF INITIAL PARTONS, BEFORE EVOLUTION ((GEV/C)**2)
C- EMCUT  = EMCUT/ECM IS INFRARED Z CUTOFF IN INITIAL SPLITTING FUNCTS
C- SIGINL = TOTAL INEL. X-SECTION (MILLIBARN) (DEFAULT SET IN CJHPRE)
C- KPBAR  = 1 ANTIPROTON-PROTON, OTHERWISE PROTON-PROTON
C- NFLAV  = NO. OF QUARK FLAVORS
C- IFUNCX = (UNEVOLVED) PARTON DENSITY PARAMETRIZATION
C- KPTWGT = 1 : EVENTS WEIGHTED BY FUNCTION PTWGCJ, = 0 : UNWEIGHTED
C- FRAGEH = APPROXIMATE FRACTION OF HARD EVENTS
C-          (IN INPUT ONLY FOR KPTWGT=1 AND PTMIN < PTCUT)
C-
C- TLEAVE = EVENT GENERATION STOPS WHEN TIME LEFT < TLEAVE
C- NLEAVE = EVENT GENERATION STOPS WHEN NO. OF GENERATED EVENTS > NLEAVE
C- NSIGMA = MIN NO. OF POINTS TO BE CALCULATED FOR THE X-SECTION
C-          DETERMINATION (TWOJET, MINBIAS)
C- NPRESH = MIN NO. OF INITIAL PARTON SHOWER PAIRS TO BE CALCULATED
C-          FOR THE X-SECTION  DETERMINATION (TWOJET, MINBIAS)
C- NDUMP  = NO. OF EVENTS TO DUMP
C- NJUMP  = NO. OF EVENTS JUMPED IN BETWEEN DUMPED EVENTS
C-
C- KYWQED = IF 0 E.M. RADIATIVE EFFECTS IN W/Z LEPTONIC DECAYS ARE
C-    NEGLECTED, IF 1 THEY ARE INCLUDED ACCORDING TO LAPORTA AND
C-    ODORICO, NP B266 (1986) 633 (O(ALPHA)+EXPONENTIATION), IF 2
C-    THEY ARE INCLUDED ACCORDING TO BERENDS AND KLEISS, LEIDEN
C-    PREPRINT (1983) (O(ALPHA) ONLY)
C- KEEQED = AS FOR KYWQED IN E+E-, WITH OPTION 1 MISSING
C- KYTQED = CONTROLS QED RADIATION IN TOP DECAYS. LIKE KYWQED.
C-
C- NOFRGM = IF 1 PARTICLE GENERATION IS INHIBITED, EXCEPT FOR
C-          Z/W/DY-LEPTONS
C- NODECY = IF 1 ALL PRIMARY PARTICLES ARE NOT LET TO DECAY
C- NOBROA = IF 1 NO MASS BROADENING FOR RESONANCES
C- NOPDG  = IF 1 FINAL PARTICLE ID'S ARE ISAJET ONES
      FACTK=2.
C
      ALAMBD=0.17
      PTCUT =4.001
      PTMIN =0.
      PTMAX =0.
      PT2INT=0.4
      EMCUT =1.
C
      SIGINL=0.
C
      KPBAR =1
      NFLAV =5
C
      IFUNCX=1
C
      TLEAVE=30.
      NLEAVE=1000000000
      NSIGMA=0
      NPRESH=0
      NDUMP =5
      NJUMP =1
C
      KPTWGT=0
      FRAGEH=.5
C
      KYWQED=1
      KEEQED=2
      KYTQED=1
C
      NOFRGM=0
      NODECY=0
      NOBROA=0
      NOPDG =0
C
      IVAL  =100
C
C-- QCD CASCADE PARAMETERS
C   ----------------------
C- QZEVOL = INITIAL SCALE FOR PARTON DENSITIES EVOLUTION (GEV)
C- QZ = NON-PERTURBATIVE CUTOFF FOR GLUONS AND LIGHT QUARKS
C- NCASC = MAX NO. OF CASCADES (PER PARTON CHANNEL) IN INITIAL PRETAB.
C- KYEVOL = 0 -- FULL QCD BREMS., 1 -- LONG. EFFECTS ONLY, 2 -- SCAL.
C-    VIOL. OF PARTON DENS. ONLY, 3 -- NO QCD BREMS. AT ALL
C- KYTQCD = CONTROLS QCD RADIATION IN TOP DECAYS. LIKE KYEVOL WITH
C-    THE VALUE 2 MISSING
      QZEVOL=4.
      QZ    =3.
      KYEVOL=0
      KYTQCD=0
C
C-- MAX (BOMSMX-BOMSMN)/BOMSMN RATIO ALLOWED IN INPUT (DY CONTINUUM)
      BRATIO=1.
C
C-- Z, W RADIATIVE DECAYS ACCORDING TO BERENDS ET AL.
C-- PHOTON ENERGY CUTOFF
      GMCZW =1.
C
C-- FRAGMENTATION PARAMETERS
C   ------------------------
C see W. Hoffmann, Ann. Rev. Nucl. Part. Sc. 1988.38: 279-322
C (with modifications: PUS1)
      PVMESO(1)=.41
      PVMESO(2)=.41
      PVMESO(3)=.46
      PVMESO(4)=.75
      PVMESO(5)=.75
      PVMESO(6)=.75
      PBARYO=.07
      PSQRK =.3
      PUS1  =.65
      PUD3  =.03
      PUS3  =.012
      PSS3  =.004
C
      SIGMAQ=.849
      SIGMAG=.849
      FRALOQ(1)=2.0
      FRALOQ(2)=30.5
      FRALOQ(3)=.003
      FRALOQ(4)=1.52
      FRALOQ(5)=1.50
      FRALOG(1)=2.2
      FRALOG(2)=46.6
      FRALOG(3)=.003
      FRALOG(4)=1.52
      FRALOG(5)=1.50
      FRAMAS(1)=10.
      FRAMAS(2)=.24
      FRAMAS(3)=.587
      FRAMAS(4)=1.76
C
      EFGMIN=0.2
C
      EPSPET(1)=.25
      EPSPET(2)=.001
      EPSPET(3)=.001
C
      CMIX(1,1)=0.5
      CMIX(2,1)=0.5
      CMIX(3,1)=1.
      CMIX(4,1)=0.5
      CMIX(5,1)=0.5
      CMIX(6,1)=1.
      CMIX(1,2)=0.25
      CMIX(2,2)=0.25
      CMIX(3,2)=0.5
      CMIX(4,2)=0.
      CMIX(5,2)=0.
      CMIX(6,2)=1.
C
C-- DECAY PARAMETERS
C   ----------------
C- CND1,CND2 = DETERMINE MEAN MULTIPLICITY IN DECAYS OF
C-             PARTON-ANTIPARTON SYSTEMS: <N> = CND1*LOG(MASS/CND2)
C-             WHERE MASS IS THE PARTICLE MASS
C- BZDMIX,BZSMIX = PROBABILITIES OF B0 AND B0S MIXINGS
C- DECCTX = MAX C*(INVARIANT MEAN LIFETIME) OF PARTICLE IN MILLIMETERS
C-          FOR DECAY TO TAKE PLACE
C-          (WITH THE DEFAULT VALUE OF 100 MM: K0S AND LAMBDA DO DECAY;
C-          WITH A VALUE OF 10 MM: CHARM AND BOTTOM DO DECAY; WEAKLY
C-          DECAYING STRANGE HADRONS ARE STABLE)
C- DECRX  = MAX DISTANCE FROM ORIGIN IN MILLIMETERS
C-          FOR DECAY TO TAKE PLACE
C- DECRTX = MAX DISTANCE FROM BEAMS AXIS IN MILLIMETERS
C-          FOR DECAY TO TAKE PLACE
C- DECZX  = MAX DISTANCE FROM ORIGIN ALONG BEAMS AXIS IN MILLIMETERS
C-          FOR DECAY TO TAKE PLACE
      CND1  =1.8
      CND2  =.8
      BZDMIX=.20
      BZSMIX=0.
C
      DECCTX=100.
      DECRX =1.E10
      DECRTX=1.E10
      DECZX =1.E10
C
C-- MINBIAS PARAMETERS
C   ------------------
      CLPRO =0.7
      PT2PRO=0.15
      FMULMB=1.
      FPTMB =1.
C
      RETPIZ=0.257
      RPAIR(1)=13.6
      RPAIR(2)=20.2
      RPAIR(3)=2.5
      RPAIR(4)=2.7
      RPAIR(5)=1.5
      RPAIR(6)=1.5
      RPAIR(7)=0.5
      RPAIR(8)=0.125
      RPAIR(9)=0.125
C
C-- DEFAULT TAPE UNITS
C   ------------------
      ITDKY =-1
      ITEVT =2
      ITCOM =5
      ITLIS =6
C
C-- DEFINE PROCEDURE IN CASE OF DIMENSION OVERFLOW
C-- (KOVER=1 -- PRINT DIAGNOSTICS, SET IFAIL=1, AND GO ON FOR UP TO
C--  100 OVERFLOWS, AFTER WHICH DO AS FOR KOVER=-1)
C-- (KOVER=-1 -- PRINT DIAGNOSTICS AND STOP THROUGH PROVOCATED ERROR
C--  TO ACTIVATE MEMORY DUMP)
      KOVER=1
C
C-- CODING ARRAYS
      DO 5 L2=1,7
      DO 5 L1=1,7
      IMATCH(L1,L2)=IMATCZ(L1,L2)
      IMATBO(L1,L2)=IMATBZ(L1,L2)
5     CONTINUE
C
C-- INITIAL SETTINGS
C-- NEVHEP: NO. OF ACCEPTED EVENTS, INCLUDING *NREPET
C-- NEVGEN: NO. OF GENERATED PRODUCTION EVENTS
C-- NHARD : NO. OF GENERATED HARD EVENTS (MINBIAS)
C-- NGEX  : NO. OF INITIAL QUARK PAIR GENERATIONS TO CALCULATE DRELLYAN
C           X-SECTION
C-- NEVOL : NO. OF INITIAL QCD PARTON SHOWERS CALCULATED (MONITORING)
C-- NHVREJ: NO. OF REJECTED PRODUCTION EVENTS (TWOJET, HEAVY QUARK
C           PRODUCTION FORCING)
C-- NKINPT: NO. OF KINEMATICAL POINTS CALCULATED FOR X-SECTION (TWOJET)
      NEVHEP=0
      NEVGEN=0
      NHARD =0
      NGEX  =0
      NEVOL =0
      NHVREJ=0
      NKINPT=0
C
      KREPET=0
      NREPET=10
      NFORCE=0
      NSTOPD=0
C
      XMIN  =1.
      ALQF  =0.
      WEIGHT=1.
      PTHARD=0.
C
      KFRFLA=0
      KPRHEV=0
C
      DO 1 L=1,352
      PMAS(L)  =0.
      WIDTHP(L)=0.
      WCUTP(L) =0.
      CTAU(L)  =0.
      IDB(L)   =0
      LCHARG(L)=0
      IDHEPF(L)=0
      KDECAY(L)=20
      KANTIP(L)=0
1     CONTINUE
      DO 2 L=1,6
      QMAS(L)  =0.
2     CONTINUE
      TOPMAS=-1.
C
      SPYOVR=-1.
C
      MNHEP =0
      MNBOOK=0
      MMBOOK=0
      MNRAD =0
      MNCUEV=0
      MNCUEJ=0
C
      ZWTHRS=-1.
      WMASS =-1
      ZMASS =-1
      WGAMMA=-1
      ZGAMMA=-1
C
      BTTHR2=0.
      TPTHR2=0.
      DO 3 L=1,MXDCZ
      KACTZ(L)=0
3     CONTINUE
      DO 4 L=1,MXDCW
      KACTW(L)=0
4     CONTINUE
C
      RETURN
      END
CDECK  ID>, CJDECP.
      SUBROUTINE CJDECP(IPD)
C     **********************
C-- DECAYS PARTICLE
C-- IPD = PARTICLE POSITION IN PARTICLE STREAM
C-- ADAPTED FROM T. SJOSTRAND, LUND PREPRINT LU TP 79-8 (1979)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      PARAMETER (MXQQB=10)
      DIMENSION KEXT(NPDECX),IFLQ(MXQQB),IFLR(MXQQB),VX(4)
      DIMENSION PM(10,5),RND(10),U(3),BE(3),WTCOR(10)
      PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
      FOUR(I,J)=PHEP(4,I)*PHEP(4,J)-PHEP(1,I)*PHEP(1,J)
     &         -PHEP(2,I)*PHEP(2,J)-PHEP(3,I)*PHEP(3,J)
C
      DATA WTCOR/16.,150.,2.,5.,15.,60.,250.,1500.,12000.,120000./
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 10
      ICALL=1
      PIG2=8.*ATAN(1.)
10    CONTINUE
C
C-- ID'S OF DECAY PARTICLE - RETURN IF STABLE OR DECAY CONDITIONS
C-- NOT MET
      IF(ISTHEP(IPD).NE.1) RETURN
      IDPD=IDHEP(IPD)
      KIPD=INIDCJ(IDPD)
      IF(KIPD.EQ.0) RETURN
      IF(IDB(KIPD).EQ.0) RETURN
      IF(KDECAY(KIPD).EQ.0) RETURN
      IF(CTAU(KIPD).GT.DECCTX) RETURN
      DO 9 J=1,4
9     VX(J)=VHEP(J,IPD)
      IF(CTAU(KIPD).GT.0.) THEN
        NODEC=0
        CTQ=CTAU(KIPD)*(-LOG(RNCJ(0.)))
        DO 8 J=1,4
8       VX(J)=VX(J)+CTQ*PHEP(J,IPD)/PHEP(5,IPD)
        IF(VX(1)**2+VX(2)**2+VX(3)**2.GT.DECRX**2) NODEC=1
        IF(VX(1)**2+VX(2)**2.GT.DECRTX**2) NODEC=1
        IF(ABS(VX(3)).GT.DECZX) NODEC=1
        IF(NODEC.EQ.1) RETURN
      ENDIF
C
      IDPDA=ABS(IDPD)
C
C-- GENERATE DECAY CHANNEL
      ITER1=0
400   ITER1=ITER1+1
      IF(ITER1.GT.1) THEN
        IF(ITER1.GT.100) THEN
          WRITE(ITLIS,401) IDHEP(IPD)
401   FORMAT(
     &/' ***MORE THAN 100 DECAY CHANNEL GENERATIONS FOR PARTICLE ',I8
     &/' ***JOB ABORT'
     &)
          STOP
        ELSE
          WRITE(ITLIS,402) ITER1,IDHEP(IPD),(KDP(L,IDC),L=1,5)
402   FORMAT(
     &/' ***WARNING: ',I5,' DECAY CHANNEL GENERATIONS FOR PARTICLE ',I8
     &/' ***LAST DECAY CHANNEL: ',5I8
     &/' ***EXECUTION CONTINUES'
     &)
        ENDIF
      ENDIF
      TBR=RNCJ(0)
      IDC=IDB(KIPD)-1
100   IDC=IDC+1
      IF(TBR.GT.CBR(IDC)) GOTO 100
C
C-- FOR PSEUDOSCALAR TOP BRANCH TO CJTDCY
      IF(IDPDA.EQ.6) THEN
        CALL CJTDCY(IPD,IDC)
        RETURN
      ENDIF
C
C-- INPUT DECAY PRODUCTS
      NDIN=0
      NP=0
      DO 180 I1=1,NPDECX
      KEXT(I1)=KDP(I1,IDC)
      IF(KEXT(I1).NE.0) THEN
        NDIN=I1
        IF(MOD(ABS(KEXT(I1))/10,10).NE.0) NP=NP+1
      ENDIF
180   CONTINUE
      IF(NDIN.EQ.0) RETURN
C
C-- PRODUCT CHARGE CONJUGATION FOR DECAYING ANTIPARTICLE
C-- BZD,BZS MIXINGS
      IDEN=IDPD
      IF(ABS(IDEN).EQ.250.AND.RNCJ(0.).LT.BZDMIX) IDEN=-IDEN
      IF(ABS(IDEN).EQ.350.AND.RNCJ(0.).LT.BZSMIX) IDEN=-IDEN
      IF(IDEN*MOTHER(IDC).LT.0) THEN
        DO 181 I1=1,NDIN
        KINT=INIDCJ(KEXT(I1))
        IF(KINT.EQ.0) THEN
          KEXT(I1)=-KEXT(I1)
        ELSEIF(KANTIP(KINT).EQ.1) THEN
          KEXT(I1)=-KEXT(I1)
        ENDIF
181     CONTINUE
      ENDIF
C
C-- SET ID'S AND MASSES OF (INPUT) DECAY PARTICLES
      IF(NP+NHEP+1.GT.NMXHEP) GO TO 500
111   PSUMP=0.
      DO 110 I1=1,NP
      N1=NHEP+I1
      IDHEP(N1)=KEXT(I1)
      PHEP(5,N1)=AMAWCJ(KEXT(I1))
      PSUMP=PSUMP+PHEP(5,N1)
110   CONTINUE
      PSUM=PSUMP
      IF(NDIN.GT.1.AND.PSUMP.GE.PHEP(5,IPD)) GO TO 111
      ND=NP
      IF(NP.EQ.NDIN) GOTO 170
C
C-- Q-QBAR OR DIQUARK-QUARK DECAYS
      ITER2=0
410   ITER2=ITER2+1
      IF(ITER2.GT.100) GO TO 400
      IQ=0
      DO 122 I1=1,NDIN
      IF(MOD(ABS(KEXT(I1))/10,10).EQ.0) THEN
        IF(KEXT(I1).NE.9) THEN
          IQ=IQ+1
          IFLQ(IQ)=KEXT(I1)
        ELSE
          IFLGEN=1+INT(RNCJ(0)*(2.+PSQRK))
          IQ=IQ+1
          IFLQ(IQ)=IFLGEN
          IQ=IQ+1
          IFLQ(IQ)=-IFLGEN
        ENDIF
      ENDIF
122   CONTINUE
      IF(IQ.GT.MXQQB) GOTO 502
      NQ=IQ/2
      ND=NP+NQ
C
      CND=CND1*LOG(PHEP(5,IPD)/CND2)
120   GAUSS=SQRT(-2.*CND*LOG(RNCJ(1)))*SIN(PIG2*RNCJ(2))
      ND=.5+.5*(NP+NQ)+CND+GAUSS
      IF(ND.LT.NP+NQ.OR.ND.LT.2.OR.ND.GT.10) GOTO 120
121   CONTINUE
      IF(ND+NHEP+1.GT.NMXHEP) GO TO 500
C
C-- GENERATION AND PAIRING OFF OF Q-QB AND Q-DIQUARK PAIRS
      KEYBAR=1
      DO 130 L=1,IQ
      IF(ABS(IFLQ(L)).GT.10) KEYBAR=0
130   IFLR(L)=IFLQ(L)
      IF(ND.EQ.NP+NQ) GO TO 150
      DO 140 I1=NP+1,ND-NQ
      N1=I1+NHEP
      IQ1=1+INT(2*NQ*RNCJ(0))
C-- GENERATED CONSTITUENT CAN BE DIQUARK IF NO DIQUARK AROUND (KEYBAR=0)
      IF(ABS(IFLR(IQ1)).LT.10) THEN
        IF(KEYBAR.GT.0.AND.RNCJ(1).LT.PBARYO) THEN
C-- QUARK + GENERATED DIQUARK
          CALL CJBARY(IFLR(IQ1),0,1,1,IDHEP(N1),IFLGEN)
          KEYBAR=0
        ELSE
C-- QUARK + ANTIQUARK
          IFLGEN=SIGN(1+INT(RNCJ(2)*(2.+PSQRK)),-IFLR(IQ1))
          CALL CJMESO(IFLR(IQ1),IFLGEN,1,1,IDHEP(N1))
        ENDIF
      ELSE
C-- DIQUARK + GENERATED QUARK
        CALL CJBARY(0,IFLR(IQ1),1,1,IDHEP(N1),IFLGEN)
        KEYBAR=1
      ENDIF
140   IFLR(IQ1)=-IFLGEN
150   CONTINUE
      DO 151 LQ=1,NQ
      M1=LQ-1
      M2=2*M1
      IF(ABS(IFLR(1+M2)).GT.10.) THEN
        CALL CJBARY(IFLR(2+M2),IFLR(1+M2),1,1,IDHEP(ND-M1+NHEP),IFLDUM)
      ELSEIF(ABS(IFLR(2+M2)).GT.10) THEN
        CALL CJBARY(IFLR(1+M2),IFLR(2+M2),1,1,IDHEP(ND-M1+NHEP),IFLDUM)
      ELSE
        CALL CJMESO(IFLR(1+M2),IFLR(2+M2),1,1,IDHEP(ND-M1+NHEP))
      ENDIF
151   CONTINUE
C
C-- CALCULATE PARTICLE MASSES -- CHECK IF TOTAL MASS TOO LARGE
      PSUM=PSUMP
      DO 160 I1=NP+1,ND
      N1=I1+NHEP
      PHEP(5,N1)=AMAWCJ(IDHEP(N1))
      PSUM=PSUM+PHEP(5,N1)
160   CONTINUE
      IF(PSUM.GE.PHEP(5,IPD)*.9) GO TO 410
C
170   CONTINUE
C
C-- ONE-PARTICLE DECAY
      IF(ND.EQ.1) THEN
        N1=1+NHEP
        DO 190 J=1,4
190     PHEP(J,N1)=PHEP(J,IPD)
        GOTO 330
      ENDIF
C
C-- START ND-PARTICLE DECAY
      DO 200 J=1,5
200   PM(1,J)=PHEP(J,IPD)
      PM(ND,5)=PHEP(5,ND+NHEP)
      IF(ND.EQ.2) GOTO 260
C
C-- KROLL-WADA MASS DISTRIBUTION FOR PI0, ETA DALITZ DECAYS
      IF(MATRX(IDC).EQ.3) THEN
        E2M=2.*PHEP(5,2+NHEP)
201     EEM=E2M*(PHEP(5,IPD)/E2M)**RNCJ(0)
        REEM=(E2M/EEM)**2
        WTEE=(1.-(EEM/PHEP(5,IPD))**2)**3
     &      *SQRT(ABS(1.-REEM))*(1.+.5*REEM)
        IF(WTEE.LT.RNCJ(0)) GO TO 201
        PM(2,5)=EEM
        GO TO 260
      ENDIF
C
C-- CALCULATION OF MAXIMUM WEIGHT
      WTMAX=1./WTCOR(ND)
      PMAX=PM(1,5)-PSUM+PHEP(5,ND+NHEP)
      PMIN=0.
      DO 210 IL=ND-1,1,-1
      NL=IL+NHEP
      PMAX=PMAX+PHEP(5,NL)
      PMIN=PMIN+PHEP(5,NL+1)
      DARG=PHEP(5,NL)
210   WTMAX=WTMAX*PAWT(PMAX,PMIN,DARG)
C-- M-GENERATOR GIVES WEIGHT, IF REJECTED TRY AGAIN
      ITER3=0
220   ITER3=ITER3+1
      IF(ITER3.GT.1000) GO TO 410
      RND(1)=1.
      DO 240 IL1=2,ND-1
      RAN=RNCJ(0)
      DO 230 IL2=IL1-1,1,-1
      IF(RAN.LE.RND(IL2)) GOTO 240
230   RND(IL2+1)=RND(IL2)
240   RND(IL2+1)=RAN
      RND(ND)=0.
      WT=1.
      DO 250 IL=ND-1,1,-1
      NL=IL+NHEP
      PM(IL,5)=PM(IL+1,5)+PHEP(5,NL)+(RND(IL)-RND(IL+1))
     &         *(PHEP(5,IPD)-PSUM)
      DARG=PHEP(5,NL)
250   WT=WT*PAWT(PM(IL,5),PM(IL+1,5),DARG)
      IF(WT.LT.RNCJ(0)*WTMAX) GOTO 220
C
C-- TWO-PARTICLE DECAY IN CM
260   CONTINUE
      DO 280 IL=1,ND-1
      NL=IL+NHEP
      DARG=PHEP(5,NL)
      PA=PAWT(PM(IL,5),PM(IL+1,5),DARG)
      U(3)=2.*RNCJ(0)-1.
      PHI=PIG2*RNCJ(0)
      U(1)=SQRT(ABS(1.-U(3)**2))*COS(PHI)
      U(2)=SQRT(ABS(1.-U(3)**2))*SIN(PHI)
      DO 270 J=1,3
      PHEP(J,NL)=PA*U(J)
270   PM(IL+1,J)=-PA*U(J)
      PHEP(4,NL)=SQRT(PA**2+PHEP(5,NL)**2)
280   PM(IL+1,4)=SQRT(PA**2+PM(IL+1,5)**2)
C
C-- DECAY PRODUCTS LORENTZ TRANSFORMED TO LAB SYSTEM
      DO 290 J=1,4
290   PHEP(J,ND+NHEP)=PM(ND,J)
      DO 320 IL=ND-1,1,-1
      DO 300 J=1,3
300   BE(J)=PM(IL,J)/PM(IL,4)
      GA=PM(IL,4)/PM(IL,5)
      DO 320 I1=IL,ND
      N1=I1+NHEP
      BEP=BE(1)*PHEP(1,N1)+BE(2)*PHEP(2,N1)+BE(3)*PHEP(3,N1)
      DO 310 J=1,3
310   PHEP(J,N1)=PHEP(J,N1)+GA*(GA/(1.+GA)*BEP+PHEP(4,N1))*BE(J)
320   PHEP(4,N1)=GA*(PHEP(4,N1)+BEP)
C
      IF(MATRX(IDC).EQ.1) THEN
C-- V-A MATRIX ELEMENT FOR WEAK DECAYS.
C-- NU 1ST IN C AND T DECAYS, CH. LEPTON 1ST IN B DECAYS
        IF(ND.EQ.3) THEN
          IH=3+NHEP
        ELSE
          IH=ND+1+NHEP
          IF(IH.GT.NMXHEP) GO TO 500
          DO 311 J=1,4
          PHEP(J,IH)=0.
          DO 311 I3=3+NHEP,ND+NHEP
          PHEP(J,IH)=PHEP(J,IH)+PHEP(J,I3)
311       CONTINUE
        ENDIF
        WT=FOUR(IPD,2+NHEP)*FOUR(1+NHEP,IH)
        SW=PHEP(5,1+NHEP)**2+PHEP(5,2+NHEP)**2+2.*FOUR(1+NHEP,2+NHEP)
        SWX=PHEP(5,IPD)**2
        WT=WT*((SWX-WMASS**2)**2+(WMASS*WGAMMA)**2)
     &       /((SW -WMASS**2)**2+(WMASS*WGAMMA)**2)
        IF(WT.LT.RNCJ(0)*PHEP(5,IPD)**4/WTCOR(1)) GOTO 220
      ELSEIF(MATRX(IDC).EQ.2) THEN
C-- MATRIX ELEMENT FOR OMEGA AND PHI DECAYS
        WT=(PHEP(5,1+NHEP)*PHEP(5,2+NHEP)*PHEP(5,3+NHEP))**2
     &  -(PHEP(5,1+NHEP)*FOUR(2+NHEP,3+NHEP))**2
     &  -(PHEP(5,2+NHEP)*FOUR(1+NHEP,3+NHEP))**2
     &  -(PHEP(5,3+NHEP)*FOUR(1+NHEP,2+NHEP))**2
     &  +2.*FOUR(1+NHEP,2+NHEP)*FOUR(1+NHEP,3+NHEP)*FOUR(2+NHEP,3+NHEP)
        IF(WT.LT.RNCJ(0)*PHEP(5,IPD)**6/WTCOR(2)) GOTO 220
      ELSEIF(MATRX(IDC).EQ.4) THEN
C-- MATRIX ELEMENT FOR TAU --> NEUTRINO + HADRONS
        WTF=2.*FOUR(IPD,1+NHEP)/PHEP(5,IPD)**2
        WT=8.*WTF*(3.-2.*WTF)/9.
        IF(WT.LT.RNCJ(0)) GOTO 220
      ENDIF
330   CONTINUE
C
C-- FINAL SETTINGS
      JDAHEP(1,IPD)=NHEP+1
      JDAHEP(2,IPD)=NHEP+ND
      ISTHEP(IPD)=2
      DO 331 L=1,ND
      NL=L+NHEP
      ISTHEP(NL)=1
      JMOHEP(1,NL)=IPD
      JMOHEP(2,NL)=0
      JDAHEP(1,NL)=0
      JDAHEP(2,NL)=0
331   CONTINUE
C-- VHEP
      DO 332 J=1,4
      DO 332 L=1,ND
      NL=L+NHEP
      VHEP(J,NL)=VX(J)
332   CONTINUE
C
      NHEP=NHEP+ND
C
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS',I10
     1//1X,'***IN SUBROUTINE CJDECP'
     1//1X,'***EVENT NO. =',I10
     3//1X,'***INCREASE NMXHEP'
     5)
      CALL CJOVER
      RETURN
502   WRITE(ITLIS,503)
503   FORMAT(5(/),1X,'***INCREASE DIMENSION PARAMETER MXQQB'
     1//1X,'***IN SUBROUTINE CJDECP'
     3//1X,'***JOB ABORT'
     5)
      STOP
      END
CDECK  ID>, CJDECY.
      SUBROUTINE CJDECY(IPDI,IPDF)
C     ****************************
C-- DECAYS PARTICLES BETWEEN IPDI AND IPDF IN PARTICLE STREAM
C-- IF IPDF=0, END OF DECAY CASCADE IS REACHED
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
C-- REGULAR DECAY LOOP
      IPD=IPDI-1
100   IPD=IPD+1
      IF(IPDF.GT.0) THEN
        IF(IPD.GT.IPDF) GO TO 101
      ELSE
        IF(IPD.GT.NHEP) GO TO 101
      ENDIF
      IF(ISTHEP(IPD).NE.1) GO TO 100
      KIPD=INIDCJ(IDHEP(IPD))
      IF(KIPD.EQ.0) GO TO 100
C-- SKIP POTENTIALLY FORCED PARTICLES
      IF(KDECAY(KIPD).LT.0) GO TO 100
      CALL CJDECP(IPD)
      GO TO 100
101   CONTINUE
C
      RETURN
      END
CDECK  ID>, CJDMAT.
      SUBROUTINE CJDMAT(NR,ICHR,IFL)
C     ******************************
C-- MATCHES FORCED DECAYS WITH TABLE
C-- NR   = FORCE ENTRY
C-- ICHR = MATCHED DECAY CHANNEL
C-- IFL SET TO 1 IF NO MATCH FOUND (WARNING PRINTED)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
C
C-- FIND MATCH
      ICHI=IDB(INIDCJ(KFORCE(1,NR)))
      IF(ICHI.EQ.0) GO TO 10
      ICHR=ICHI-1
1     ICHR=ICHR+1
      IF(ICHR.GT.NDECT) GO TO 10
      IF(MOTHER(ICHR).NE.KFORCE(1,NR)) GO TO 10
      DO 2 L=1,NPDECX
      IF(KFORCE(L+1,NR).EQ.KDP(L,ICHR)) GO TO 2
      GO TO 1
2     CONTINUE
      RETURN
C-- NO MATCH FOUND -- SET FLAG FOR ABORT
10    IFL=1
      WRITE(ITLIS,11) (KFORCE(L,NR),L=1,NDFORC)
11    FORMAT(/' ***NO MATCH FOR FORCE DECAY'//4X,6I10
     *//' ***JOB WILL BE ABORTED')
      RETURN
      END
CDECK  ID>, CJDSDT.
      SUBROUTINE CJDSDT(IM,MFLA1,MFLA2,S,T,U,WTDSDT,WFDSDT)
C     *****************************************************
C-- DSIGMA/DT OF HARD PROCESSES
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      DIMENSION WFDSDT(6)
C
      DO 1 L=1,6
1     WFDSDT(L)=0.
      WTDSDT=0.
      S2=S**2
      T2=T**2
      U2=U**2
      IF(IM.GT.5) GO TO 300
      IF(KPRHEV.EQ.1) GO TO 100
      GO TO(10,20,30,40,50),IM
C
C-- Q-Q --> Q-Q NON-ID.
10    WFDSDT(1)=(4./9.)*(S2+U2)/T2
      WTDSDT=WFDSDT(1)
      RETURN
C
C-- Q-Q --> Q-Q ID.
20    WFDSDT(1)=(4./9.)*((S2+U2)/T2+(S2+T2)/U2)-(8./27.)*S2/(U*T)
      WFDSDT(1)=.5*WFDSDT(1)
      WTDSDT=WFDSDT(1)
      RETURN
C
C-- QB-Q --> QB-Q ANNIH. F=I
30    WFDSDT(1)=(4./9.)*((S2+U2)/T2+(T2+U2)/S2)-(8./27.)*U2/(S*T)
C-- QB-Q --> QB-Q ANNIH. F.NE.I
      WFDSDT(2)=(4./9.)*(T2+U2)/S2*2.
C-- QB-Q --> G-G
      WFDSDT(3)=(32./27.)*(U2+T2)/(U*T)-(8./3.)*(U2+T2)/S2
      WFDSDT(3)=.5*WFDSDT(3)
C-- QB-Q --> HEAVY QUARKS
      LF=3
      DO 31 L=4,6
      IF(NFLAV.LT.L) GO TO 35
      IF(S.LE.THRFLA(L)) GO TO 35
      LF=L
      WFDSDT(L)=DHVQCJ(AM2HEV(L),S,T,U)
31    CONTINUE
35    CONTINUE
      WTDSDT=0.
      DO 36 L=1,LF
36    WTDSDT=WTDSDT+WFDSDT(L)
      RETURN
C
C-- Q-G --> Q-G
40    WFDSDT(1)=-(4./9.)*(U2+S2)/(U*S)+(U2+S2)/T2
      WTDSDT=WFDSDT(1)
      RETURN
C
C-- G-G --> G-G
50    WFDSDT(1)=(9./2.)*(3.-U*T/S2-U*S/T2-S*T/U2)
      WFDSDT(1)=.5*WFDSDT(1)
C-- G-G --> Q-QB
      WFDSDT(2)=(1./6.)*(U2+T2)/(U*T)-(3./8.)*(U2+T2)/S2
      WFDSDT(2)=WFDSDT(2)*3.
C-- G-G --> HEAVY QUARKS
      LF=2
      DO 51 L=4,6
      IF(NFLAV.LT.L) GO TO 55
      IF(S.LE.THRFLA(L)) GO TO 55
      LF=L
      WFDSDT(L)=DHVGCJ(AM2HEV(L),S,T,U)
51    CONTINUE
55    CONTINUE
      WTDSDT=0.
      DO 56 L=1,LF
56    WTDSDT=WTDSDT+WFDSDT(L)
      RETURN
C
C-- FORCING PRODUCTION OF HEAVY FLAVOR KFRFLA (FUSION PART)
100   IF(S.LE.THRFLA(KFRFLA)) RETURN
      IF(IM.EQ.3) THEN
        WFDSDT(KFRFLA)=DHVQCJ(AM2HEV(KFRFLA),S,T,U)
      ELSEIF(IM.EQ.5) THEN
        WFDSDT(KFRFLA)=DHVGCJ(AM2HEV(KFRFLA),S,T,U)
      ENDIF
      WTDSDT=WFDSDT(KFRFLA)
200   RETURN
C
C-- FLAVOR EXCITATION SECTOR
300   CONTINUE
      MFLAX=0
      IF(MFLA1.NE.LGLU) MFLAX=MFLA1
      IF(MFLA2.NE.LGLU) MFLAX=MAX(MFLAX,MFLA2)
      IF(IM.EQ.6) GO TO 360
      IF(IM.EQ.7) GO TO 370
      A2=AM2HEV(MFLA1)
      B2=AM2HEV(MFLA2)
      IF(IM.EQ.8) GO TO 380
      IF(IM.EQ.9) GO TO 390
      IF(IM.EQ.10) GO TO 400
C
C-- Q-QH --> Q-QH
360   IF(S.LE.AM2HEV(MFLAX)) RETURN
      WFDSDT(1)=DEXQCJ(AM2HEV(MFLAX),S,T,U)
      WTDSDT=WFDSDT(1)
      RETURN
C
C-- G-QH --> G-QH
370   IF(S.LE.AM2HEV(MFLAX)) RETURN
      WFDSDT(1)=DEXGCJ(AM2HEV(MFLAX),S,T,U)
      WTDSDT=WFDSDT(1)
      RETURN
C
C
C-- QH-QH --> QH-QH NON-ID.
380   IF(S.LE.(AMHEV(MFLA1)+AMHEV(MFLA2))**2) RETURN
      WFDSDT(1)=DHNICJ(A2,B2,S,T,U)
      WTDSDT=WFDSDT(1)
      RETURN
C
C-- QH-QH --> QH-QH ID.
390   IF(S.LE.THRFLA(MFLA1)) RETURN
      WFDSDT(1)=DHIDCJ(A2,S,T,U)
      WFDSDT(1)=.5*WFDSDT(1)
      WTDSDT=WFDSDT(1)
      RETURN
C
C-- QHB-QH --> ANNIHILATION
400   CONTINUE
C-- QHB-QH --> QHB-Q  F=I
      WFDSDT(1)=DHFICJ(A2,S,T,U)
C-- QHB-QH --> QB-Q F=LIGHT
      WFDSDT(2)=(4./9.)*(T2+U2)/S2 *3.
C-- QHB-QH --> G-G
      WFDSDT(3)=(32./27.)*(U2+T2)/(U*T)
     1         -(8./3.)*(U2+T2)/S2
      WFDSDT(3)=.5*WFDSDT(3)
C-- QHB-QH --> HEAVY QUARKS F.NE.I
      DO 431 L=4,6
      IF(NFLAV.LT.L) GO TO 435
      IF(S.LE.THRFLA(L)) GO TO 435
      IF(L.NE.MFLA1) WFDSDT(L)=DHVQCJ(AM2HEV(L),S,T,U)
431   CONTINUE
435   CONTINUE
      WTDSDT=0.
      DO 436 L=1,6
436   WTDSDT=WTDSDT+WFDSDT(L)
      RETURN
      END
CDECK  ID>, CJDUMP.
      SUBROUTINE CJDUMP
C     *****************
C-- DUMPS EVENT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      CHARACTER*8 LABLCJ
C
      WRITE(ITLIS,1) NEVHEP
1     FORMAT(5(/),' EVENT #',I7/1X,14('-'))
      WRITE(ITLIS,2)
2     FORMAT(//1X
     &,'    I  IST  LABEL         ID ORIG DAUGHTERS       PX       PY'
     &,'       PZ        E        M'/)
      IF(NHEP.EQ.0) RETURN
      DO 10 I=1,NHEP
      IF(ISTHEP(I).NE.1.AND.ISTHEP(I).NE.2) GO TO 10
      ID=IDHEP(I)
      IF(NOPDG.EQ.0) THEN
        ISAID=ISACJ(IDHEP(I))
      ELSE
        ISAID=IDHEP(I)
      ENDIF
      WRITE(ITLIS,3)
     & I,ISTHEP(I),LABLCJ(ISAID),ID,JMOHEP(1,I),(JDAHEP(L,I),L=1,2)
     &,(PHEP(L,I),L=1,5)
3     FORMAT(1X,2I5,2X,A8,I8,3(I5),5F9.1)
10    CONTINUE
      RETURN
      END
CDECK  ID>, CJEB.
      SUBROUTINE CJEB(X,TC)
C     *********************
C-- CHEBYSHEV POLINOMIALS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TC(6)
      X2=X*X
      X3=X*X2
      X4=X2*X2
      X5=X2*X3
      TC(1)=1.
      TC(3)=-1.+2.*X2
      TC(5)=1.-8.*X2+8.*X4
      TC(2)=X
      TC(4)=-3.*X+4.*X3
      TC(6)=5.*X-20.*X3+16.*X5
      RETURN
      END
CDECK  ID>, CJEGEV.
      SUBROUTINE CJEGEV
C     *****************
C-- HANDLES E+E- EVENT GENERATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      LOGICAL ACCEPT
      DIMENSION ACT1(4),ACT2(4)
C
      DATA NACCPL/0/
      DATA ICALL/0/
C
      IF(ICALL.EQ.0) CALL CJEPRE
      ICALL=1
C
C-- EVENT GENERATION
1     CONTINUE
      IFAIL=0
      IFLGHV=0
      NHEP=0
C
      IF(KEEQED.EQ.0) THEN
        NGEX=NGEX+1
      ENDIF
C
C-- FINAL CHANNEL GENERATION
      IF(NHEP+2.GT.NMXHEP) GO TO 500
      IDCI=IDB(INIDCJ(IDZ))
      TBR=RNCJ(0)
      IDC=IDCI-1
10    IDC=IDC+1
      IF(TBR.GT.CBR(IDC)) GO TO 10
      LXF=IDC-IDCI+1
      ID1=KDP(1,IDC)
      ID2=KDP(2,IDC)
C
C-- GENERATE FINAL STATE
      IF(KEEQED.EQ.2) CALL BKJEVE(LXF,ACT1,ACT2)
      CALL CJEQRK(-1,ID1,ID2,ACT1,ACT2)
      IF(IFAIL.EQ.1) GO TO 1
      IF(IFLGHV.EQ.1) GO TO 1
C
C-- DECAY UNSTABLE PARTICLES
      IF(NODECY.EQ.0) CALL CJDECY(1,0)
      IF(IFAIL.EQ.1) GO TO 1
      IF(IFLGHV.EQ.1) GO TO 1
      NEVGEN=NEVGEN+1
      MNHEP=MAX(MNHEP,NHEP)
C
      IF(KREPET.EQ.0) THEN
        IF(NOUNST.EQ.1) CALL CJSTAB
        IF(NOPDG.EQ.0) CALL CJPDG(1)
        NEVHEP=NEVHEP+1
        ACCEPT=.TRUE.
        CALL CJUSER(ACCEPT)
        IF(.NOT.ACCEPT) NEVHEP=NEVHEP-1
        IF(NEVHEP.NE.NACCPL) THEN
          IF(NEVHEP.LE.NDUMP.AND.
     &    (MOD(NEVHEP,NJUMP).EQ.1.OR.NJUMP.EQ.1))
     *    CALL CJDUMP
          NACCPL=NEVHEP
        ENDIF
      ELSE
        CALL CJREPT
      ENDIF
C
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS  ',I10
     1//1X,'***IN SUBROUTINE CJEGEV'
     1//1X,'***EVENT NO. =  ',I10
     3//1X,'***INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJEPRE.
      SUBROUTINE CJEPRE
C     *****************
C-- INITIALIZATION FOR E+E- ANNIHILATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DATA ICALL/0/
      IF(ICALL.GT.0) RETURN
      ICALL=1
C
C
C-- INITIALIZATION
      NEVHEP=0
      MNBOOK=1
      S=ECM**2
C
      CALL CJQCDT
C
C-- Z PARAMETERS
20    CONTINUE
      XW=SIN2W
      BIM=ZMASS
      BIM2=BIM**2
      BTTHR2=(2.*QMAS(5)+1.)**2
      TPTHR2=(2.*QMAS(6)+1.)**2
      SZ(1)=BIM2
      SZ(2)=BIM2*ZGAMMA**2
      SZ(3)=4.*QMAS(6)**2
      DO 24 LL3=1,NDECZ1
      FACTSZ(LL3)=0.
      DO 24 LL2=1,2
      DO 24 LL=1,8
24    SZF(LL,LL2,LL3)=0.
C
      LI=1
      FACTX=PI*ALFQED**2*2./3.*UNITS
      FXW=1./SQRT(ABS(XW*(1.-XW)))
      IDBI=IDB(INIDCJ(IDZ))
      DO 23 LXF=1,NDECZ
      ICH=IDBI-1+LXF
      IF(KACTZ(LXF).EQ.0) GO TO 23
      ID1=ABS(KDP(1,ICH))
      IF(ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16) THEN
        QF=1.
        VF=AL(1)
        AF=BL(1)
        FCOLRS=1.
      ELSEIF(ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15) THEN
        QF=0.
        VF=AL(2)
        AF=BL(2)
        FCOLRS=1.
      ELSEIF(CHRGCJ(ID1).GT.0.) THEN
        QF=CHRGCJ(ID1)
        VF=AQ(1)
        AF=BQ(1)
        FCOLRS=3.
      ELSE
        QF=CHRGCJ(ID1)
        VF=AQ(2)
        AF=BQ(2)
        FCOLRS=3.
      ENDIF
      FACTSZ(LXF)=FACTX*FCOLRS
      VF=VF*FXW
      AF=AF*FXW
      QI=1.
      VI=AL(LI)*FXW
      AI=BL(LI)*FXW
      SZF(1,LI,LXF)=QI**2*QF**2
      SZF(2,LI,LXF)=-2.*QI*VI*QF*VF
      SZF(3,LI,LXF)=2.*(VI**2+AI**2)*(VF**2+AF**2)
      SZF(4,LI,LXF)=(VI**2+AI**2)*(VF**2-2.*AF**2)
      SZF(5,LI,LXF)=.5*SZF(3,LI,LXF)
      SZF(6,LI,LXF)=(VI**2+AI**2)*(VF**2-AF**2)
      SZF(7,LI,LXF)=-4.*QI*AI*QF*AF
      SZF(8,LI,LXF)=8.*VI*AI*VF*AF
      IF(ICH.NE.IZTOP) THEN
        DO 25 LL=1,8
25      SZF(LL,LI,NDECZ1)=SZF(LL,LI,NDECZ1)+FCOLRS*SZF(LL,LI,LXF)
      ENDIF
23    CONTINUE
      FACTSZ(NDECZ1)=FACTX
C
C-- BKJ QED RADIATION ACTIVATED
C-- CALCULATE X-SECTION AND CUMULATIVE FINAL CHANNELS PROBABILITIES
      IF(KEEQED.EQ.2) THEN
        CALL BKJSTA
      ENDIF
C
C-- INITIAL QED RADIATION NOT ACTIVATED
C-- INITIAL STATE (FIXED) SET-UP
C-- CALCULATE X-SECTION AND CUMULATIVE FINAL CHANNELS PROBABILITIES
      IF(KEEQED.EQ.0) THEN
CCCCCCCCCCCCCCCCC    dble must be used here!!!!!!!!!!!!
        CALL CJESIG(dble(ECM**2),SIG)
c        print *,'sig',sig
        FXSCT=SIG
      ENDIF
C
      RETURN
      END
CDECK  ID>, CJEQRK.
      SUBROUTINE CJEQRK(IQRKFW,ID1,ID2,ACT1,ACT2)
C     *******************************************
C-- HANDLES Q-QBAR FINAL STATE IN E+E-
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION ACT1(4),ACT2(4)
C
C-- PARTON CMS KINEMATICS
      IFLAB=ABS(ID1)
      IF(KEEQED.EQ.0) THEN
        ECMF=ECM
      ELSE
        ECMF2=(ACT1(4)+ACT2(4))**2-(ACT1(1)+ACT2(1))**2
     &       -(ACT1(2)+ACT2(2))**2-(ACT1(3)+ACT2(3))**2
        ECMF=SQRT(ABS(ECMF2))
      ENDIF
      IF(ECMF.LE.2.*QZFL(IFLAB)) THEN
        IFAIL=1
        RETURN
      ENDIF
      XQSQ=(ECMF-QZFL(IFLAB))**2
1     CALL CJQTGE(IFLAB,XQSQ,PSQJET,IGO)
      AM=SQRT(PSQJET)
      S=ECMF**2
      PCMSQ=(S-(AM+QZFL(IFLAB))**2)*(S-(AM-QZFL(IFLAB))**2)/(4.*S)
      IF(PCMSQ.GT.0.) THEN
        PCM=SQRT(PCMSQ)
      ELSE
        PCM=0.
      ENDIF
C
C-- COMPLETE BOOKING OF QUARK & ANTIQUARK
      NHEPI=NHEP+1
      IPD1=NHEP+1
      IPD2=NHEP+2
      NHEP=NHEP+2
      IF(NHEP.GT.NMXHEP) GOTO 560
      IF(ID1.GT.0) THEN
        IDHEP(IPD1)=ID1
        IDHEP(IPD2)=ID2
      ELSE
        IDHEP(IPD1)=ID2
        IDHEP(IPD2)=ID1
      ENDIF
      PHEP(1,IPD1)=0.
      PHEP(1,IPD2)=0.
      PHEP(2,IPD1)=0.
      PHEP(2,IPD2)=0.
      PHEP(3,IPD1)=PCM
      PHEP(3,IPD2)=-PCM
      JMOHEP(1,IPD1)=0
      JMOHEP(2,IPD1)=0
      JMOHEP(1,IPD2)=0
      JMOHEP(2,IPD2)=0
      JDAHEP(1,IPD1)=0
      JDAHEP(2,IPD1)=0
      ISTHEP(IPD1)=1
      JDAHEP(1,IPD2)=0
      JDAHEP(2,IPD2)=0
      ISTHEP(IPD2)=1
C-- RANDOMIZE EMISSION BY QUARK OR ANTIQUARK
      IF(RNCJ(0.).LT..5) THEN
        PHEP(4,IPD1)=SQRT(PSQJET+PCMSQ)
        PHEP(4,IPD2)=SQRT(QZFLSQ(IFLAB)+PCMSQ)
        PHEP(5,IPD1)=SQRT(PSQJET)
        PHEP(5,IPD2)=SQRT(QZFLSQ(IFLAB))
        CALL CJJETQ(IPD1)
      ELSE
        PHEP(4,IPD1)=SQRT(QZFLSQ(IFLAB)+PCMSQ)
        PHEP(4,IPD2)=SQRT(PSQJET+PCMSQ)
        PHEP(5,IPD1)=SQRT(QZFLSQ(IFLAB))
        PHEP(5,IPD2)=SQRT(PSQJET)
        CALL CJJETQ(IPD2)
      ENDIF
C
C-- ALIGN THRUST AXIS (QUARK) ALONG POSITIVE Z AXIS
      NHEPF=NHEP
      IF(NHEP.GT.IPD2) CALL CJTHRS(IPD1,IPD1,NHEPF)
C
C-- HADRONIZATION
40    CONTINUE
      IF(NOFRGM.EQ.0) THEN
        NHEPL=NHEP
        IFAIL=0
        CALL CJBASK(1,0)
        NHEPF=NHEP
        CALL CJHADR(1,NHEPF,0)
        IF(IFAIL.EQ.1) RETURN
        IF(IFLGHV.EQ.1) RETURN
        NHEPF=NHEP
        CALL CJFLAC(NHEPL+1,NHEPF)
        IF(IFAIL.EQ.1) RETURN
        NHEPF=NHEP
        CALL CJHADC(ECMF,NHEPL+1,NHEPF)
        IF(IFAIL.EQ.1) RETURN
      ENDIF
C
      IF(KEEQED.EQ.0) THEN
C-- NO QED RADIATION: ROTATE ACCORDING TO W-S
        CALL CJZANG(IQRKFW,ID1,COSROT)
        CT=COSROT
        ST=SQRT(ABS(1.-CT**2))
        PHI=2*PI*RNCJ(1.)
        CP=COS(PHI)
        SP=SIN(PHI)
        NHEPF=NHEP
        CALL CJROTP(NHEPI,NHEPF,CT,ST,CP,SP)
      ELSE
C-- ELSE: BOOST TO LAB SYSTEM
        NHEPF=NHEP
        CALL CJLORL(ACT1,ACT2,NHEPI,NHEPF)
      ENDIF
C
      DO 31 I=1,NHEP
      DO 31 J=1,4
31    VHEP(J,I)=0.
C
      RETURN
C
C-- ABNORMAL EXIT
560   WRITE(ITLIS,561) NMXHEP,NEVGEN+1
561   FORMAT(5(/),1X,'NHEP EXCEEDS',I10
     *//1X,11HEVENT NO. =    ,I10,10X,'(SUB. CJEQRK)'
     1//1X,'INCREASE NMXHEP')
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJESIG.
      SUBROUTINE CJESIG(SHAT,SIG)
C     ***************************
C-- CALCULATES TOTAL X-SECTION AND CHANNEL X-SECTION RATIOS IN E+E-
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
C
C-- CALCULATE CHANNEL AND TOTAL X-SECTIONS
      LXI=1
      SX=SHAT
      SIG=0.
      IDBI=IDB(INIDCJ(IDZ))
      DO 17 LXFC=1,NDECZ
      LXF=LXFC
      ICH=IDBI-1+LXF
      IF(KACTZ(LXF).EQ.0) GO TO 17
      ID1=ABS(KDP(1,ICH))
      IF(ID1.LE.6.AND.ID1.GT.4) THEN
        IF(ID1.EQ.5.AND.SHAT.LE.BTTHR2) GO TO 17
        IF(ID1.EQ.6.AND.SHAT.LE.TPTHR2) GO TO 17
        RHO4=4.*QMAS(ID1)**2/SHAT
        SIG=SIG+ZXSECJ(DUMMY)
c        print *,'zxsec',sig
      ELSE
        RHO4=0.
        SIG=SIG+ZXSECJ(DUMMY)
c        print *,'zxsec',sig
      ENDIF
17    CBR(ICH)=SIG
C
      DO 18 ICH=IDBI,IDBI+NDECZ-1
18    CBR(ICH)=CBR(ICH)/SIG
C
      RETURN
      END
CDECK  ID>, CJEVOL.
      SUBROUTINE CJEVOL(NBK,YQSQ)
C     ***************************
C-- GENERATES INITIAL LLA CASCADES
C...Notes:
C...i) Algorithm was originally developed without history information.
C...The latter has been added on later. When called by CJMATC, for
C...pretabulation, only the (double) PARACT stream is used to store all
C...spacelike partons for all Q**2 values of WGALQ tables. When called
C...from CJHGEV, for event generation, originally only 1st elements of
C...PARACT were used, containing information on the interacting partons,
C...while the (double) stream PARSPE contains the parameters of timelike
C...partons emitted in the evolution of the interacting partons.
C...Subsequently, the other elements of PARACT have been used to store
C...intermediate spacelike partons (with a different arrangement from
C...the interacting ones), in order to have history information.
C...ii) The parton shower evolution is not developed within a single
C...call to CJEVOL. Evolution steps are controlled by calling routines,
C...which use information on the shower trees as they evolve and also
C...prune branches which are too soft to yield interactions.
C...iii) During event generation, information on chain from the initial
C...spacelike to the final (interacting) spacelike parton, with all the
C...intermediary spacelike partons and the emitted timelike partons, is
C...stored as follows. The IBOOK parameter, stored in PARACT(1,2,IBEAM),
C...gives the position MBK in PARSPE of the timelike sister of the
C...interacting parton. Position of the previous timelike parton in
C...chain is given by PARSPE(MBK,4,IBEAM), recursively. The spacelike
C...sister of a timelike parton stored at MBK has its parameters stored
C...in PARACT at MBKS=MBK+1; they are stored only for history. The
C...parameters of the initial spacelike parton are taken from /CJENTR/.
C...To carry on the event generation, the only spacelike parton
C...information used is that contained in the 1st elements of PARACT,
C...referring to the interacting partons. The initial parton cascade
C...information is stored in /HEPEVT/by routine CJTEVO, which also
C...steers the timelike evolution of timelike partons.
C...iv) For proper counting, each branching must be counted twice for
C...the two possible timelike-spacelike assignments to the parton
C...secondaries.
C...v) Shower trees are developed with a dept-first (rather than a
C...breadth-first) algorithm, branches left to develop being put in a
C...stack (CUEV) for proper backtracking. Branches which are too soft
C...or which move backwards are pruned away immediately.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MXCUEV=50,MXCUEJ=50)
      COMMON/CJCUES/CUEV(MXCUEV,10,2),CUE(MXCUEJ,6)
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      INTEGER NCUE(2)
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 10
      ICALL=1
      IBOOK=1
      IBOOK1=1
      IBOOK2=1
10    CONTINUE
C
      IF(IBACK(IBEAM).EQ.1) GO TO 462
      NEVOL=NEVOL+1
C
C-- RESET
      NCUE(IBEAM)=0
C
C-- SETTING PARAMETERS OF INITIAL LEG
      IF(KYEVOL.GE.3) GO TO 100
      Y=PARACT(NBK,4,IBEAM)
      IF(Y.GT.YQSQ) GO TO 100
      IFLA=PARACT(NBK,1,IBEAM)
      IBOOK=PARACT(NBK,2,IBEAM)
      QSQ=EXP(EXP(Y)*ALQZM+ALLAM2)
      XM=PARACT(NBK,3,IBEAM)
      X=PARACT(NBK,5,IBEAM)
      PX=PARACT(NBK,6,IBEAM)
      PY=PARACT(NBK,7,IBEAM)
      YVI=PARACT(NBK,8,IBEAM)
      YVF=PARACT(NBK,9,IBEAM)
      IF(JBOOK.EQ.2) GO TO 200
      ICANC(IBEAM)=ICANC(IBEAM)+1
      NBKCNC(ICANC(IBEAM),IBEAM)=NBK
      GO TO 200
C
100   IBACK(IBEAM)=1
      RETURN
C
C-- BRANCHING LOOP
C   ==============
C
C
C-- GENERATE Z AND Q.N. OF SECONDARIES
C   ----------------------------------
200   CONTINUE
      IF(IFLA.EQ.LGLU) GO TO 210
C-- QUARK BRANCHING
201   CALL CJZGES(1,Z,IFLAQ)
      Z1=1.-Z
      IFLA1=IFLA
      IFLA2=LGLU
      GO TO 300
C
C-- GLUON BRANCHING, GENERATE DECAY CHANNEL
210   CONTINUE
      IF(RNCJ(0.).GT.PROGLS) GO TO 230
C
C-- GLUON BRANCHES INTO TWO GLUONS
      CALL CJZGES(2,Z,IFLAQ)
      Z1=1.-Z
      IFLA1=LGLU
      IFLA2=LGLU
      GO TO 300
C
C-- GLUON BRANCHES INTO Q-QB
230   CONTINUE
      CALL CJZGES(3,Z,IFLAQ)
      Z1=1.-Z
      IFLA1=IFLAQ
      IFLA2=-IFLAQ
C
C-- GENERATE PT OF SECONDARIES
C   --------------------------
300   CONTINUE
      X1=X*Z
      X2=X*Z1
      PTR=SQRT(Z*Z1*QSQ)
      IF(KYEVOL.GE.1) PTR=0.
      PHI=PI2*RNCJ(0)
      PXR=PTR*COS(PHI)
      PYR=PTR*SIN(PHI)
      PX1=PXR+Z*PX
      PY1=PYR+Z*PY
      PX2=-PXR+Z1*PX
      PY2=-PYR+Z1*PY
C
C-- GENERATE MASSES OF SECONDARIES
C   ------------------------------
      S=ECM**2
      IF(X1.LT.XMIN) GO TO 301
      CALL CJQSGE(IFLA1,Y,Y1,QSQ1)
      YVI1=YVI
      YVF1=YVF
C-- KINEMATIC CONSTRAINT FOR 1ST HEAVY QUARK
      IF(IFLA1.NE.-IFLA2) GO TO 302
      IF(IFLA1.LT.4) GO TO 302
      QSQS=QSQ1
      IF(Y1.GT.YQSQ) QSQS=EXP(EXP(YQSQ)*ALQZM+ALLAM2)
      IF(Z1*QSQS.GT.AM2HEV(IFLA1)) GO TO 302
      IF(JBOOK.EQ.2) GO TO 305
      QSQF=QSQ1
      IF(YVF.LT.Y1) QSQF=EXP(EXP(YVF)*ALQZM+ALLAM2)
      IF(Z1*QSQF.GT.AM2HEV(IFLA1)) GO TO 303
305   YVF1=-100.
      YVFG=YVF
      YVIG=YVI
      GO TO 304
303   YVC=LOG((LOG(AM2HEV(IFLA1)/Z1)-ALLAM2)/ALQZM)
      YVI1=MAX(YVI,YVC)
      YVFG=MIN(YVF,YVC)
      YVIG=YVI
304   IF(RNCJ(QSQS).GT..5) GO TO 302
      NCUE(IBEAM)=NCUE(IBEAM)+1
      MNCUEV=MAX(MNCUEV,NCUE(IBEAM))
      NC=NCUE(IBEAM)
      IF(NC.GE.MXCUEV) GO TO 500
      CALL CJQSGE(IFLA,Y,YS,QSQS)
      CUEV(NC,1,IBEAM)=IFLA
      CUEV(NC,2,IBEAM)=YS
      CUEV(NC,3,IBEAM)=X
      CUEV(NC,4,IBEAM)=IBOOK
      CUEV(NC,5,IBEAM)=PX
      CUEV(NC,6,IBEAM)=PY
      CUEV(NC,7,IBEAM)=QSQS
      CUEV(NC,8,IBEAM)=XM
      CUEV(NC,9,IBEAM)=YVIG
      CUEV(NC,10,IBEAM)=YVFG
302   CONTINUE
C
      PX1S=PX1
      PY1S=PY1
      TMSQ1=PX1S**2+PY1S**2
      XM1=TMSQ1/(S*X1)
      IF(JBOOK.EQ.1) GO TO 301
      QSQS1=QSQ1
      IF(Y1.GT.YQSQ) QSQS1=EXP(EXP(YQSQ)*ALQZM+ALLAM2)
      TPSQ1=Z1*QSQS1
      PX1T=PX2
      PY1T=PY2
301   CONTINUE
C
      IF(X2.LT.XMIN) GO TO 400
      CALL CJQSGE(IFLA2,Y,Y2,QSQ2)
      YVI2=YVI
      YVF2=YVF
C-- KINEMATIC CONSTRAINT FOR 2ND HEAVY QUARK
      IF(IFLA1.NE.-IFLA2) GO TO 306
      IF(IFLA1.LT.4) GO TO 306
      QSQS=QSQ2
      IF(Y2.GT.YQSQ) QSQS=EXP(EXP(YQSQ)*ALQZM+ALLAM2)
      IF(Z*QSQS.GT.AM2HEV(IFLA1)) GO TO 306
      IF(JBOOK.EQ.2) GO TO 309
      QSQF=QSQ2
      IF(YVF.LT.Y2) QSQF=EXP(EXP(YVF)*ALQZM+ALLAM2)
      IF(Z*QSQF.GT.AM2HEV(IFLA1)) GO TO 307
309   YVF2=-100.
      YVFG=YVF
      YVIG=YVI
      GO TO 308
307   YVC=LOG((LOG(AM2HEV(IFLA1)/Z)-ALLAM2)/ALQZM)
      YVI2=MAX(YVI,YVC)
      YVFG=MIN(YVF,YVC)
      YVIG=YVI
308   IF(RNCJ(QSQS).GT..5) GO TO 306
      NCUE(IBEAM)=NCUE(IBEAM)+1
      MNCUEV=MAX(MNCUEV,NCUE(IBEAM))
      NC=NCUE(IBEAM)
      IF(NC.GE.MXCUEV) GO TO 500
      CALL CJQSGE(IFLA,Y,YS,QSQS)
      CUEV(NC,1,IBEAM)=IFLA
      CUEV(NC,2,IBEAM)=YS
      CUEV(NC,3,IBEAM)=X
      CUEV(NC,4,IBEAM)=IBOOK
      CUEV(NC,5,IBEAM)=PX
      CUEV(NC,6,IBEAM)=PY
      CUEV(NC,7,IBEAM)=QSQS
      CUEV(NC,8,IBEAM)=XM
      CUEV(NC,9,IBEAM)=YVIG
      CUEV(NC,10,IBEAM)=YVFG
306   CONTINUE
C
      PX2S=PX2
      PY2S=PY2
      TMSQ2=PX2S**2+PY2S**2
      XM2=TMSQ2/(S*X2)
      IF(JBOOK.EQ.1) GO TO 310
      QSQS2=QSQ2
      IF(Y2.GT.YQSQ) QSQS2=EXP(EXP(YQSQ)*ALQZM+ALLAM2)
      TPSQ2=Z*QSQS2
      PX2T=PX1
      PY2T=PY1
310   CONTINUE
C
C-- DECIDE WHICH IS NEXT TO CASCADE, ADD TO CUE, BOOK
C   -------------------------------------------------
400   CONTINUE
      IF(X1.LT.XMIN) GO TO 452
      IF(X1.LT.XM1) GO TO 452
      IF(YVF1.LT.0.) GO TO 452
      IF(X2.LT.XMIN) GO TO 450
      IF(X2.LT.XM2) GO TO 450
      IF(YVF2.LT.0.) GO TO 450
      NCUE(IBEAM)=NCUE(IBEAM)+1
      MNCUEV=MAX(MNCUEV,NCUE(IBEAM))
      NC=NCUE(IBEAM)
      IF(NC.GE.MXCUEV) GO TO 500
      IF(JBOOK.EQ.2) CALL CJTBK1(IBOOK,IFLA1,TPSQ2,X1,PX2T,PY2T,IBOOK2)
      IF(JBOOK.EQ.2) CALL CJTBK2(IFLA2,QSQ2,X2,PX2S,PY2S)
      CUEV(NC,1,IBEAM)=IFLA2
      CUEV(NC,2,IBEAM)=Y2
      CUEV(NC,3,IBEAM)=X2
      CUEV(NC,4,IBEAM)=IBOOK2
      CUEV(NC,5,IBEAM)=PX2S
      CUEV(NC,6,IBEAM)=PY2S
      CUEV(NC,7,IBEAM)=QSQ2
      CUEV(NC,8,IBEAM)=XM2
      CUEV(NC,9,IBEAM)=YVI2
      CUEV(NC,10,IBEAM)=YVF2
450   CONTINUE
      IF(JBOOK.EQ.2) CALL CJTBK1(IBOOK,IFLA2,TPSQ1,X2,PX1T,PY1T,IBOOK1)
      IF(JBOOK.EQ.2) CALL CJTBK2(IFLA1,QSQ1,X1,PX1S,PY1S)
      IF(Y1.GT.YQSQ) GO TO 402
      IFLA=IFLA1
      Y=Y1
      X=X1
      PX=PX1S
      PY=PY1S
      IBOOK=IBOOK1
      QSQ=QSQ1
      YVI=YVI1
      YVF=YVF1
      GO TO 200
402   CONTINUE
      CALL CJBOOK(IFLA1,IBOOK1,XM1,Y1,X1,PX1S,PY1S,YVI1,YVF1)
      IF(JBOOK.EQ.1) GO TO 462
      RETURN
452   IF(X2.LT.XMIN) GO TO 462
      IF(X2.LT.XM2) GO TO 462
      IF(YVF2.LT.0.) GO TO 462
      IF(JBOOK.EQ.2) CALL CJTBK1(IBOOK,IFLA1,TPSQ2,X1,PX2T,PY2T,IBOOK2)
      IF(JBOOK.EQ.2) CALL CJTBK2(IFLA2,QSQ2,X2,PX2S,PY2S)
      IF(Y2.GT.YQSQ) GO TO 460
      IFLA=IFLA2
      Y=Y2
      X=X2
      PX=PX2S
      PY=PY2S
      IBOOK=IBOOK2
      QSQ=QSQ2
      YVI=YVI2
      YVF=YVF2
      GO TO 200
460   CONTINUE
      CALL CJBOOK(IFLA2,IBOOK2,XM2,Y2,X2,PX2S,PY2S,YVI2,YVF2)
      IF(JBOOK.EQ.1) GO TO 462
      RETURN
C
C-- PICK UP NEXT IN CUE
C   -------------------
462   IF(NCUE(IBEAM).EQ.0) GO TO 480
      NC=NCUE(IBEAM)
      IFLA=CUEV(NC,1,IBEAM)
      Y=CUEV(NC,2,IBEAM)
      X=CUEV(NC,3,IBEAM)
      IBOOK=CUEV(NC,4,IBEAM)
      PX=CUEV(NC,5,IBEAM)
      PY=CUEV(NC,6,IBEAM)
      QSQ=CUEV(NC,7,IBEAM)
      XM=CUEV(NC,8,IBEAM)
      YVI=CUEV(NC,9,IBEAM)
      YVF=CUEV(NC,10,IBEAM)
      MBOOK(IBEAM)=IBOOK
      NCUE(IBEAM)=NCUE(IBEAM)-1
      IF(Y.GT.YQSQ) GO TO 465
      GO TO 200
465   CONTINUE
      CALL CJBOOK(IFLA,IBOOK,XM,Y,X,PX,PY,YVI,YVF)
      IF(JBOOK.EQ.1) GO TO 462
      RETURN
C
C-- EXIT
C   ----
480   CONTINUE
      ISTOP(IBEAM)=1
      IBACK(IBEAM)=0
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) MXCUEV,NEVOL
501   FORMAT(1H1,'***NUMBER OF PARTONS IN CUEV (/CJCUES/) EXCEEDS',I10
     1//1X,'***CASCADE NO. =',I10
     &//1X,'***IN SUBROUTINE CJEVOL'
     2//1X,'***INCREASE MXCUEV'
     3//1X,'***JOB ABORT'
     4  )
      STOP
      END
CDECK  ID>, CJFLAC.
      SUBROUTINE CJFLAC(NHEPI,NHEPF)
C     ******************************
C-- CORRECTS FOR FLAVOR CONSERVATION USING PARTON LEFTOVERS IN BASKET
C-- ADDED PARTICLES ARE GIVEN MOMENTA SO AS TO REDUCE MOMENTUM UNBALANCE
C-- (E+E-)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION PTOT(3),PSMEAR(3),PLEFT(3)
C
C-- BALANCE FLAVORS & BARYON NUMBER BY USING PARTON LEFTOVERS IN BASKET
      NADD=0
1     CALL CJBASK(0,ID)
      IF(ID.NE.0) THEN
        NADD=NADD+1
        IF(NHEP+NADD.GT.NMXHEP) GO TO 500
        IDHEP(NHEP+NADD)=ID
        PHEP(5,NHEP+NADD)=AMAWCJ(ID)
        GO TO 1
      ENDIF
      IF(NADD.EQ.0) RETURN
C
C-- TOTAL 3-MOMENTUM
30    CONTINUE
      DO 29 J=1,3
29    PTOT(J)=0.
      DO 31 IP=NHEPI,NHEPF
      IF(ISTHEP(IP).NE.1) GO TO 31
      DO 39 J=1,3
      PTOT(J)=PTOT(J)+PHEP(J,IP)
39    CONTINUE
31    CONTINUE
      PTOTM=SQRT(ABS(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2))
C
C-- RANDOM PARTITION OF 3-MOMENTUM UNBALANCE (VHEP USED AS BUFFER)
      VHEP(1,NHEP+NADD)=1.
      IF(NADD.EQ.1) GO TO 100
      NHEP1=NHEP+1
      DO 40 IADD=1,NADD-1
      RC=RNCJ(IADD)
      IF(IADD.EQ.1) THEN
        VHEP(1,NHEP1)=RC
      ELSE
        DO 41 IC=NHEP+IADD-1,NHEP1,-1
        IF(RC.GT.VHEP(1,IC)) THEN
          VHEP(1,IC+1)=RC
          GO TO 40
        ELSE
          VHEP(1,IC+1)=VHEP(1,IC)
          IF(IC.EQ.NHEP1) VHEP(1,IC)=RC
        ENDIF
41      CONTINUE
      ENDIF
40    CONTINUE
      DO 42 I=NHEP+NADD,NHEP+2,-1
42    VHEP(1,I)=VHEP(1,I)-VHEP(1,I-1)
C
C-- SET MOMENTA OF PARTICLES ADDING A SMEARING MOMENTUM
C-- <PSMEAR**2>=0.1
100   CONTINUE
      DO 103 J=1,3
103   PLEFT(J)=0.
C
      DO 102 IADD=1,NADD
      I=NHEP+IADD
      IF(IADD.LT.NADD.OR.(NADD.EQ.1.AND.PTOTM.LT.1.E-3)) THEN
        PPISQ=-0.1*LOG(RNCJ(0.))
        PPI=SQRT(PPISQ)
        COSTH=-1.+2.*RNCJ(0.)
        SINTH=SQRT(ABS(1.-COSTH**2))
        PHI=2.*PI*RNCJ(0.)
        PSMEAR(1)=PPI*SINTH*COS(PHI)
        PSMEAR(2)=PPI*SINTH*SIN(PHI)
        PSMEAR(3)=PPI*COSTH
      ELSE
        PSMEAR(1)=0.
        PSMEAR(2)=0.
        PSMEAR(3)=0.
      ENDIF
      PHEP(1,I)=PSMEAR(1)+PLEFT(1)-VHEP(1,I)*PTOT(1)
      PHEP(2,I)=PSMEAR(2)+PLEFT(2)-VHEP(1,I)*PTOT(2)
      PHEP(3,I)=PSMEAR(3)+PLEFT(3)-VHEP(1,I)*PTOT(3)
      PHEP(4,I)=
     &SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2+PHEP(5,I)**2)
      ISTHEP(I)=1
      JMOHEP(1,I)=0
      JMOHEP(2,I)=0
      JDAHEP(1,I)=0
      JDAHEP(2,I)=0
      DO 101 J=1,4
101   VHEP(J,I)=0.
      DO 104 J=1,3
104   PLEFT(J)=-PSMEAR(J)
102   CONTINUE
C
      NHEP=NHEP+NADD
C
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),' ***NUMBER OF PARTICLES EXCEEDS',I10
     1//' ***EVENT NO. =',I10 ,10X,'(SUB. CJFLAC)'
     3//' ***INCREASE NMXHEP'
     5)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJFRCE.
      SUBROUTINE CJFRCE(IFL)
C     **********************
C-- SET FORCING OF DECAYS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
C-- TREAT FORCE DECAYS
      IF(NFORCE.EQ.0) GO TO 110
      DO 113 N=1,NFORCE
      IF(KFORCE(1,N).LT.0) GO TO 113
      MOTH=KFORCE(1,N)
      KFLAWZ=0
      IF(MOTH.EQ.IDZ) KFLAWZ=1
      IF(MOTH.EQ.IDWP.OR.MOTH.EQ.IDWM) KFLAWZ=2
      NR=N
C-- FIND MATCHING CHANNEL -- REVERSE CBR
      CALL CJDMAT(NR,IMATCH,IFL)
      IF(IFL.EQ.1) GO TO 113
      IF(KFLAWZ.EQ.0) THEN
        CBR(IMATCH)=-CBR(IMATCH)
      ELSE
        CBR(IMATCH)=-1.
      ENDIF
C-- LOOK FOR OTHER FORCINGS OF SAME PARTICLE
118   NR=NR+1
      IF(NR.GT.NFORCE) GO TO 119
      IF(KFORCE(1,NR).NE.MOTH) GO TO 118
      CALL CJDMAT(NR,IMATCH,IFL)
      IF(IFL.EQ.1) GO TO 113
      KFORCE(1,NR)=-KFORCE(1,NR)
      IF(KFLAWZ.EQ.0) THEN
        CBR(IMATCH)=-CBR(IMATCH)
      ELSE
        CBR(IMATCH)=-1.
      ENDIF
      GO TO 118
119   CONTINUE
C-- GO FORWARD TO FIND FINAL DECAY CHANNEL OF PARTICLE
      ICHI=IDB(INIDCJ(MOTH))
      ICHR=ICHI
120   ICHR=ICHR+1
      IF(ICHR.GT.NDECT) GO TO 125
      IF(MOTHER(ICHR).EQ.MOTH) GO TO 120
125   ICHF=ICHR-1
C-- GO BACKWARDS, CONVERT CUMULATIVE BR TO BR
      IF(KFLAWZ.EQ.0) THEN
        ICHR=ICHF+1
121     ICHR=ICHR-1
        IF(ICHR.EQ.ICHI) GO TO 122
        CBR(ICHR)=SIGN(ABS(CBR(ICHR))-ABS(CBR(ICHR-1)),CBR(ICHR))
      ENDIF
C-- GO FORWARD, GET TCBR FOR SELECTED CHANNELS
122   TCBR=0.
      ICHR=ICHI-1
123   ICHR=ICHR+1
      IF(CBR(ICHR).LT.0.) THEN
        IF(KFLAWZ.EQ.0) THEN
          CBR(ICHR)=ABS(CBR(ICHR))
          TCBR=TCBR+CBR(ICHR)
        ELSEIF(KFLAWZ.EQ.1) THEN
          KACTZ(ICHR-IDB(KINTZ)+1)=1
          CBR(ICHR)=0.
        ELSEIF(KFLAWZ.EQ.2) THEN
          KACTW(ICHR-IDB(KINTWP)+1)=1
          CBR(ICHR)=0.
        ENDIF
      ELSEIF(KFLAWZ.EQ.0) THEN
          CBR(ICHR)=0.
      ENDIF
      IF(ICHR.LT.ICHF) GO TO 123
C-- GO FORWARD, SET FINAL CBR'S
      IF(KFLAWZ.EQ.0) THEN
        ICHR=ICHI
        CBR(ICHR)=CBR(ICHR)/TCBR
124     ICHR=ICHR+1
        CBR(ICHR)=CBR(ICHR)/TCBR+CBR(ICHR-1)
        IF(ICHR.LT.ICHF) GO TO 124
      ENDIF
113   CONTINUE
C-- RESET KFORCE
      DO 115 N=1,NFORCE
115   KFORCE(1,N)=ABS(KFORCE(1,N))
110   IF(IFL.EQ.1) RETURN
C
C-- TREAT HEAVYREP
      IF(KREPET.EQ.0) RETURN
C-- LOOP ON PARTICLES -- LOOK FOR OPEN KREPET FLAVOR PARTICLES
C-- (AS HEAVIEST FLAVOR) OR, IN THE CASE OF TOP, FOR TOP QUARK
C-- DECAYS
      DO 201 IP=1,352
      IF(KDECAY(IP).EQ.0) GO TO 201
      IF(IDB(IP).EQ.0) GO TO 201
      ID=IDEXCJ(IP)
      IF(KREPET.LE.5) THEN
        IF(ID.LT.110) GO TO 201
        IH=MOD(ID,100)/10
        IF(ID/1000.EQ.0.AND.ID/100.EQ.IH) IH=0
      ELSE
        IH=ID
      ENDIF
      IF(IH.EQ.KREPET) THEN
        KDECAY(IP)=-1
        IF(KANTIP(IP).EQ.1) KDECAY(INIDCJ(-IDEXCJ(IP)))=KDECAY(IP)
      ENDIF
201   CONTINUE
      RETURN
      END
CDECK  ID>, CJGCOD.
      SUBROUTINE CJGCOD(ICHING,IFLING)
C     ********************************
C-- CHANNEL --> PARTON PAIR FLAVORS CODE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
      INTEGER ICHING(2),IFLING(2)
C
      IFLING(1)=KODTBX(ICHING(1))
      IFLING(2)=KODTBX(ICHING(2))
      IF(KPBAR.EQ.1) THEN
        IF(IFLING(1).LT.LGLU) IFLING(1)=-IFLING(1)
      ENDIF
      RETURN
      END
CDECK  ID>, CJGEQ.
      SUBROUTINE CJGEQ(ALQ,IALQ)
C     **************************
C-- GENERATES HARD QSQ (TWOJET)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      INTEGER IHALF(6)
      DATA IHALF/32,16,8,4,2,1/
      VR=RNCJ(0)
      IF(VR.LT.WGALQT(1)) GO TO 30
      IC=64
      DO 10 IH=1,6
      ICL=IC
      ID=IHALF(IH)
      IF(VR.LT.WGALQT(IC)) ID=-ID
      IC=ICL+ID
10    CONTINUE
      ICL=IC
      ID=1
      IF(VR.LT.WGALQT(IC)) ID=-1
      IC=ICL+ID
      IF(ABS(WGALQT(IC)-WGALQT(ICL)).LT.1.E-30) GO TO 20
      ALQ1=ALQI+DALQ*FLOAT(IC)
      ALQ2=ALQI+DALQ*FLOAT(ICL)
      ALQ=((VR-WGALQT(IC))*ALQ2+(WGALQT(ICL)-VR)*ALQ1)
     1 /(WGALQT(ICL)-WGALQT(IC))
      IALQ=MAX(IC,ICL)
      RETURN
20    IALQ=MIN(IC,ICL)
      ALQ=ALQI+DALQ*FLOAT(IALQ)
      RETURN
30    ALQ=ALQI+DALQ*VR/WGALQT(1)
      IALQ=1
      RETURN
      END
CDECK  ID>, CJGEVE.
      SUBROUTINE CJGEVE
C     *****************
C-- STEERS EVENT GENERATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      IF(IEVTYP.GT.1) GO TO 201
C-- PURELY JET EVENTS - SINGLE PARTON SCATTERING
10    CONTINUE
      CALL CJTLFT(TLEFT)
      IF(TLEFT.LT.TLEAVE.OR.NEVHEP.GE.NLEAVE) GO TO 900
      CALL CJHGEV
      GO TO 10
C
C-- W/Z, DRELL-YAN EVENTS
201   IF(IEVTYP.GT.4) GO TO 251
200   CONTINUE
      CALL CJTLFT(TLEFT)
      IF(TLEFT.LT.TLEAVE.OR.NEVHEP.GE.NLEAVE) GO TO 900
      CALL CJBGEV
      GO TO 200
C
C-- E+E- EVENTS
251   CONTINUE
250   CONTINUE
      CALL CJTLFT(TLEFT)
      IF(TLEFT.LT.TLEAVE.OR.NEVHEP.GE.NLEAVE) GO TO 900
      CALL CJEGEV
      GO TO 250
C
900   CONTINUE
      RETURN
      END
CDECK  ID>, CJGEX.
      SUBROUTINE CJGEX(ICH,X,XM,PX,PY)
C     ********************************
C-- GENERATES ONE INITIAL PARTON (CALLED BY CJGPAR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
      INTEGER IHALF(NXHALF)
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 9
      ICALL=1
      IHALF(NXHALF)=1
      DO 8 IH=NXHALF-1,1,-1
8     IHALF(IH)=IHALF(IH+1)*2
      ISTART=IHALF(1)*2
9     CONTINUE
C
C-- X  TABLE SEARCHING
      RR=RNCJ(0.)
      IX=ISTART
      DO 10 IH=1,NXHALF
      IF(RR.GT.TABQRK(IX,ICH)) THEN
        IX=IX+IHALF(IH)
      ELSEIF(IX.EQ.1) THEN
        GO TO 11
      ELSEIF(RR.GT.TABQRK(IX-1,ICH)) THEN
        GO TO 11
      ELSE
        IX=IX-IHALF(IH)
      ENDIF
10    CONTINUE
11    IF(IX.NE.1) THEN
        X=((RR-TABQRK(IX-1,ICH))*XV(IX+1)
     &    +(TABQRK(IX,ICH)-RR)  *XV(IX)  )
     &    /(TABQRK(IX,ICH)-TABQRK(IX-1,ICH))
      ELSE
        X=(RR*XV(IX+1)+(TABQRK(IX,ICH)-RR)*XV(IX))/TABQRK(IX,ICH)
      ENDIF
C
300   PT2=-PT2INT*LOG(RNCJ(0))
      XM=PT2/(X*S)
      IF(XM.GT.X) GO TO 300
      PT=SQRT(PT2)
      PHI=PI2*RNCJ(0)
      PX=PT*COS(PHI)
      PY=PT*SIN(PHI)
      RETURN
      END
CDECK  ID>, CJGEXM.
      SUBROUTINE CJGEXM(ICH,IFLA,X,PX,PY,WG)
C     **************************************
C-- GENERATES ONE INITIAL PARTON (CALLED BY CJHPRE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
      DATA ICALL/0/
C
C-- INITIALIZATION - PREPARE  X  TABLES
      IF(ICALL.GT.0) GO TO 50
      ICALL=1
C-- CUMULATE QUARK DISTRIBUTIONS OVER FLAVOR
      DO 1 IX=1,NXBIN
      DO 1 J=2,6
1     TABQRK(IX,J)=TABQRK(IX,J)+TABQRK(IX,J-1)
C-- QUARKS
      AQLIAS=0.
      DO 3 IX=1,NXBIN
      TQLIAS(IX)=TABQRK(IX,6)
3     AQLIAS=AQLIAS+TQLIAS(IX)
      DO 6 IX=1,NXBIN
6     TQLIAS(IX)=TQLIAS(IX)/AQLIAS
      CALL CJALIA(LQLIAS,TQLIAS,LWORKX,NXBIN)
C-- GLUONS
      AGLIAS=0.
      DO 5 IX=1,NXBIN
      TGLIAS(IX)=TABQRK(IX,7)
5     AGLIAS=AGLIAS+TGLIAS(IX)
      DO 7 IX=1,NXBIN
7     TGLIAS(IX)=TGLIAS(IX)/AGLIAS
      CALL CJALIA(LGLIAS,TGLIAS,LWORKX,NXBIN)
C
50    CONTINUE
C
C-- GENERATION OF PARTON INITIATING INITIAL CASCADE - X AND FLAVOR FIRST
      IF(ICH.EQ.LGLU) GO TO 200
C
C-- QUARK
      IX=INT(RNCJ(1)*NXBIN)+1
      IF(RNCJ(2).GT.TQLIAS(IX)) IX=LQLIAS(IX)
      X=XV(IX)+(XV(IX+1)-XV(IX))*RNCJ(13)
C-- QUARK FLAVOR
      RR=RNCJ(5)*TABQRK(IX,6)
      DO 115 J=1,6
      IF(RR.LT.TABQRK(IX,J)) THEN
        IFLA=KODTBX(J)
        GO TO 116
      ENDIF
115   CONTINUE
116   CONTINUE
C
      WG=WGQ
      GO TO 310
C
C-- GLUON
200   CONTINUE
      IX=INT(RNCJ(7)*NXBIN)+1
      IF(RNCJ(8).GT.TGLIAS(IX)) IX=LGLIAS(IX)
      X=XV(IX)+(XV(IX+1)-XV(IX))*RNCJ(14)
      IFLA=LGLU
      WG=WGG
C
C-- TRANSVERSE MOMENTUM
310   PT2=-PT2INT*LOG(RNCJ(11))
      IF(PT2/(X*S).GT.X) GO TO 310
      PT=SQRT(PT2)
      PHI=PI2*RNCJ(12)
      PX=PT*COS(PHI)
      PY=PT*SIN(PHI)
      RETURN
      END
CDECK  ID>, CJGPAR.
      SUBROUTINE CJGPAR
C     *****************
C-- GENERATES PAIR OF INITIAL PARTONS (CALLED BY CJHGEV)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION WQQ(6),WQAQ(3)
      INTEGER INV(2)
      DATA ICALL/0/,WQAQ/3*0./,INV/2,1/
C-- INITIALIZATION
      IF(ICALL.GT.0) GO TO 9
      ICALL=1
C-- DECUMULATE QUARK PART OF TABQRK OVER FLAVOR
      DO 101 J=6,2,-1
      DO 101 IX=1,NXBIN
101   TABQRK(IX,J)=TABQRK(IX,J)-TABQRK(IX,J-1)
C-- CUMULATE TABQRK OVER X AND NORMALIZE
      DO 8 J=1,7
      DO 7 IX=2,NXBIN
7     TABQRK(IX,J)=TABQRK(IX,J)+TABQRK(IX-1,J)
      WGQV(J)=TABQRK(NXBIN,J)
      DO 8 IX=1,NXBIN
      TABQRK(IX,J)=TABQRK(IX,J)/TABQRK(NXBIN,J)
8     CONTINUE
C-- CHANNEL PAIR PROBABILITIES
      DO 1 J=1,6
1     WQQ(J)=WGQV(J)**2
      DO 2 J=2,6
2     WQQ(J)=WQQ(J)+WQQ(J-1)
      DO 3 J=1,6
3     WQQ(J)=WQQ(J)/WQQ(6)
      DO 6 J=1,6,2
      JN=(J+1)/2
6     WQAQ(JN)=WGQV(J)*WGQV(J+1)
      WQAQ(2)=WQAQ(1)+WQAQ(2)
      WQAQ(3)=WQAQ(2)+WQAQ(3)
      WQAQ(1)=WQAQ(1)/WQAQ(3)
      WQAQ(2)=WQAQ(2)/WQAQ(3)
      WQAQ(3)=1.
      DO 4 J=2,6
4     WGQV(J)=WGQV(J)+WGQV(J-1)
      DO 5 J=1,6
5     WGQV(J)=WGQV(J)/WGQV(6)
9     CONTINUE
C
C-- CHANNEL BRANCHING - TRANSLATE INTO PARTON FLAVORS
C-- IPACH = 1 Q-Q OR Q-QB DIFFERENT FLAVORS, 2 Q-Q SAME FLAVORS,
C--         3 Q-QB SAME FLAVORS, 4 Q-G, 5 G-G
      GO TO(10,20,30,40,50),IPACH
C
10    CONTINUE
      DO 11 L=1,2
14    RR=RNCJ(L)
      DO 12 J=1,6
      JOUT=J
      IF(RR.LT.WGQV(J)) GO TO 13
12    CONTINUE
13    ICHING(L)=JOUT
11    CONTINUE
      CALL CJGCOD(ICHING,IFLING)
      IF(ABS(IFLING(1)).EQ.ABS(IFLING(2))) GO TO 10
      GO TO 60
C
20    IF(KPBAR.EQ.1) GO TO 35
25    CONTINUE
      RR=RNCJ(0)
      DO 21 J=1,6
      JOUT=J
      IF(RR.LT.WQQ(J)) GO TO 22
21    CONTINUE
22    ICHING(1)=JOUT
      ICHING(2)=JOUT
      CALL CJGCOD(ICHING,IFLING)
      GO TO 60
C
30    IF(KPBAR.EQ.1) GO TO 25
35    CONTINUE
      L1=1.5+RNCJ(0)
      L2=INV(L1)
      RR=RNCJ(0)
      DO 31 J=1,3
      JOUT=J
      IF(RR.LT.WQAQ(J)) GO TO 32
31    CONTINUE
32    ICHING(L1)=2*JOUT-1
      ICHING(L2)=ICHING(L1)+1
      CALL CJGCOD(ICHING,IFLING)
      GO TO 60
C
40    L1=1.5+RNCJ(0)
      L2=INV(L1)
      ICHING(L1)=7
      RR=RNCJ(0)
      DO 41 J=1,6
      JOUT=J
      IF(RR.LT.WGQV(J)) GO TO 42
41    CONTINUE
42    ICHING(L2)=JOUT
      CALL CJGCOD(ICHING,IFLING)
      GO TO 60
C
50    ICHING(1)=7
      ICHING(2)=7
      IFLING(1)=LGLU
      IFLING(2)=LGLU
C
C-- GENERATE X'S AND PT'S FOR INITIAL PARTON PAIR
60    CONTINUE
      DO 71 L=1,2
      CALL CJGEX(ICHING(L),XING(L),XMING(L),PXING(L),PYING(L))
71    CONTINUE
C
C-- CHECK WHETHER SHAT IS ENOUGH FOR QSQ
      SHAT=(XING(1)*XING(2)+XMING(1)*XMING(2))*S
     1 -2.*(PXING(1)*PXING(2)+PYING(1)*PYING(2))
      IF(SHAT.LT.3.*QSQ) GO TO 9
C
      RETURN
      END
CDECK  ID>, CJGROT.
      SUBROUTINE CJGROT(N,PF3,PL3,COSTH,SINTH,CG,SG)
C     **********************************************
C-- PERFORMS ROTATION FOR WEIGHT CALCULATIONS IN CJBLEP
C-- (GENERATES RANDOM EULER ROTATION AND EXPLOITS ALINGNMENT ALONG
C-- -Z OF FIRST PARTICLE IN ARRAY P)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      PARAMETER (MAXRAD=100)
      COMMON/CJZWRA/P(MAXRAD,5)
C
      PHIG=PI2*RNCJ(1)
      CG=COS(PHIG)
      SG=SIN(PHIG)
      COSTH=-1.+2.*RNCJ(2)
      SINTH=SQRT(ABS(1.-COSTH**2))
      PL1=P(N,1)*CG-P(N,2)*SG
      PL3=P(N,3)*COSTH-PL1*SINTH
      PF3=P(1,3)*COSTH
      RETURN
      END
CDECK  ID>, CJHADC.
      SUBROUTINE CJHADC(TOTMAS,NHEPI,NHEPF)
C     *************************************
C-- CORRECTS SYSTEM OF STABLE PARTICLES BETWEEN NHEPI AND NHEPF
C-- SO THAT IT IS LEFT IN ITS CMS WITH TOTAL MASS TOTMAS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION A(4),V1(4),V2(4)
      DIMENSION PJTOT(5)
C
      DATA ERRMAX/1.E-3/,NITERX/100/
C
      IF(NHEPI.GT.NHEPF) RETURN
      IF(NHEPI.EQ.NHEPF) THEN
        IFAIL=1
        RETURN
      ENDIF
C
C-- BALANCE 4-MOMENTUM
30    CONTINUE
      DO 29 J=1,5
29    PJTOT(J)=0.
      DO 31 IP=NHEPI,NHEPF
      IF(ISTHEP(IP).NE.1) GO TO 31
      DO 39 J=1,5
      PJTOT(J)=PJTOT(J)+PHEP(J,IP)
39    CONTINUE
31    CONTINUE
      IF(PJTOT(5).GE.TOTMAS) THEN
        IFAIL=1
        RETURN
      ENDIF
      PJTOT(5)=PJTOT(4)**2-PJTOT(1)**2-PJTOT(2)**2-PJTOT(3)**2
      IF(PJTOT(5).LE.0) THEN
        IFAIL=1
        RETURN
      ENDIF
      PJTOT(5)=SQRT(PJTOT(5))
C-- BOOST TO REST FRAME
      DO 32 J=1,3
32    A(J)=-PJTOT(J)
      A(4)=PJTOT(4)
      NEW=1
      DO 33 IP=NHEPI,NHEPF
      DO 34 J=1,4
34    V1(J)=PHEP(J,IP)
      CALL CJLOR4(A,V1,V2,NEW)
      NEW=0
      DO 35 J=1,4
35    PHEP(J,IP)=V2(J)
33    CONTINUE
C-- RESCALE
      F=TOTMAS/PJTOT(5)
      DO 36 NITER=1,NITERX
      PJTOT(4)=0.
      DO 37 IP=NHEPI,NHEPF
      IF(ISTHEP(IP).NE.1) GO TO 37
      DO 38 J=1,3
38    PHEP(J,IP)=PHEP(J,IP)*F
      PHEP(4,IP)=SQRT(PHEP(1,IP)**2+PHEP(2,IP)**2
     *                 +PHEP(3,IP)**2+PHEP(5,IP)**2)
      PJTOT(4)=PJTOT(4)+PHEP(4,IP)
37    CONTINUE
      F=TOTMAS/PJTOT(4)
      IF(ABS(F-1.).LT.ERRMAX) GO TO 40
36    CONTINUE
40    CONTINUE
C
      RETURN
      END
CDECK  ID>, CJHADR.
      SUBROUTINE CJHADR(NHEP1,NHEP2,IMBIAS)
C     *************************************
C-- FRAGMENTS PARTONS FROM NHEP1 TO NHEP2 INCLUDED
C-- FOR IMBIAS.NE.0 ADDS BEAM JETS, CONSERVING TOTAL 4-MOMENTUM
C-- IF NHEP1=0, PARTON FRAGMENTATION IS IGNORED AND ONLY BEAM JETS
C--             ARE ADDED
C-- IF NHEP2=0, IT IS SET NHEP2=NHEP
C-- (UNSTABLE PARTICLES ARE NOT DECAYED HERE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJEEMS/FLOG(NMXHEP),TOTLOG
     &,NHEPC1,NHEPC2
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      DIMENSION PMBIAS(5)
C
      IF(NHEP1.EQ.0) GO TO 125
      IF(NHEP2.EQ.0) NHEP2=NHEP
      IF(NHEP1.GT.NHEP2) GO TO 125
C
      NHEPL=NHEP
C
C-- STORE LOG(E/QE) OF PARTONS & SUM
      TOTLOG=0.
      QE=FRAMAS(4)
      IF(QE.LE.0.) QE=1.E-3
      IF(QE.GT.QZ*.75) QE=QZ*.75
      NHEPC1=NHEP1
      NHEPC2=NHEP2
      DO 101 I=NHEPC1,NHEPC2
      IPD=I
      FLOG(IPD)=0.
      IF(ISTHEP(IPD).NE.1) GO TO 101
      IDA=ABS(IDHEP(IPD))
      L2=MOD(IDA/10,10)
      IF(IDA.GE.10.AND.L2.NE.0) GO TO 101
C-- INCLUDE LIGHT PARTONS ONLY IF WITH E > QZ
      IF(IDA.LT.10) THEN
        IDH=IDA
      ELSE
        IDH=MOD(IDA/100,10)
      ENDIF
      IF(PHEP(4,IPD).GE.QZ.OR.(IDH.GE.4.AND.IDH.LE.6)
     &.OR.IEVTYP.EQ.5) THEN
C-- CALCULATE PARTON LOG(E/QE)
        FLOG(IPD)=LOG(PHEP(4,IPD)/QE)
        IF(IDA.EQ.IDGL) THEN
          FLOG(IPD)=FLOG(IPD)
        ELSE
          FLOG(IPD)=FRAMAS(3)*FLOG(IPD)
        ENDIF
        TOTLOG=TOTLOG+FLOG(IPD)
      ENDIF
101   CONTINUE
C
C-- LOOP IF LEFTOVER ENERGY FOR CJMBIA IS INSUFFICIENT
      NIT=0
15    CONTINUE
      NIT=NIT+1
      IF(NIT.GT.10) THEN
        IFAIL=1
        RETURN
      ENDIF
      NHEP=NHEPL
C
C-- LOOP OVER STABLE PARTONS
      DO 100 I=NHEP1,NHEP2
      IPD=I
      IF(ISTHEP(IPD).NE.1) GO TO 100
      IDA=ABS(IDHEP(IPD))
C-- DO NOT FRAGMENT TOP QUARK (IT WILL DECAY)
      IF(IDA.EQ.6) GO TO 100
      L2=MOD(IDA/10,10)
      IF(IDA.GE.10.AND.L2.NE.0) GO TO 100
C-- FRAGMENT LIGHT PARTONS ONLY IF WITH E > QZ
      IF(IDA.LT.10) THEN
        IDH=IDA
      ELSE
        IDH=MOD(IDA/100,10)
      ENDIF
      IF(PHEP(4,IPD).GE.QZ.OR.(IDH.GE.4.AND.IDH.LE.6)
     &.OR.IEVTYP.EQ.5) THEN
C-- FRAGMENT PARTON
        CALL CJJETG(IPD)
      ELSE
C-- SET ISTHEP=2 FLAG ON PARTON
        ISTHEP(IPD)=2
        IF(JMOHEP(1,IPD).EQ.0) THEN
          WRITE(ITLIS,2)
2     FORMAT(//' ***WARNING: FINAL PRIMARY PARTONS TOO LOW IN ENERGY'
     &//' ***INCREASE MIN PT CUTOFF OR MIN W/Z MASS'
     &//' ***THIS EVENT IS IGNORED, EXECUTION CONTINUES'
     &)
          IFAIL=1
          RETURN
        ENDIF
      ENDIF
100   CONTINUE
C
C-- PREPARE TO CALL CJMBIA
125   IF(IMBIAS.EQ.0) RETURN
      DO 200 J=1,3
200   PMBIAS(J)=0.
      PMBIAS(4)=ECM
      PMBIAS(5)=PMBIAS(4)
      IF(NHEP.EQ.0) GO TO 105
      DO 201 J=1,4
      DO 201 IH=1,NHEP
201   IF(ISTHEP(IH).EQ.1) PMBIAS(J)=PMBIAS(J)-PHEP(J,IH)
C
C-- IF NO ENERGY IS LEFT, START FRAGMENTATION ALL OVER AGAIN
      IF(PMBIAS(4).LT.0.) GO TO 15
      AM2=PMBIAS(4)**2-PMBIAS(1)**2-PMBIAS(2)**2-PMBIAS(3)**2
      IF(AM2.LT.0.) GO TO 15
      PMBIAS(5)=SQRT(AM2)
      IF(PMBIAS(5).LT.5.) GO TO 15
105   CALL CJMBIA(PMBIAS)
C
      RETURN
      END
CDECK  ID>, CJHARD.
      SUBROUTINE CJHARD(IACT1,IACT2,IFLAF1,IFLAF2,IM,LF,SHAT,T)
C     *********************************************************
C-- HANDLES KINEMATICS AND QCD EVOLUTION OF FINAL HARD PARTONS
C-- FOR TWOJET
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION PCMV1(4),PCMV2(4),ACT1(4),ACT2(4)
C
C-- PARTON CMS KINEMATICS
      MFLAF1=ABS(IFLAF1)
      MFLAF2=ABS(IFLAF2)
      XQSQ=.75*QSQ
      ICOUNT=0
20    CONTINUE
      ICOUNT=ICOUNT+1
      IF(ICOUNT.GT.10) THEN
        IFAIL=1
        RETURN
      ENDIF
      CALL CJQTGE(IFLAF1,XQSQ,QSQ1,IGO)
      CALL CJQTGE(IFLAF2,XQSQ,QSQ2,IGO)
      Q1=SQRT(QSQ1)
      Q2=SQRT(QSQ2)
      IF((Q1+Q2)**2.GE.SHAT) GO TO 20
      LHEAV=0
      IF(MFLAF1.NE.LGLU.AND.MFLAF1.GT.3) LHEAV=LHEAV+1
      IF(MFLAF2.NE.LGLU.AND.MFLAF2.GT.3) LHEAV=LHEAV+1
C
      IF(LHEAV.EQ.0) THEN
        COSCM=T/(.5*SHAT)+1.
      ELSEIF(LHEAV.EQ.1) THEN
        IF(MFLAF1.NE.LGLU.AND.MFLAF1.GT.3) A2=AM2HEV(MFLAF1)
        IF(MFLAF2.NE.LGLU.AND.MFLAF2.GT.3) A2=AM2HEV(MFLAF2)
        COSCM=T/(.5*(SHAT-A2))+1.
      ELSEIF(LHEAV.EQ.2) THEN
        A2=AM2HEV(MFLAF1)
        B2=AM2HEV(MFLAF2)
        AB2=.5*(A2+B2)
        AM=AMHEV(MFLAF1)
        BM=AMHEV(MFLAF2)
        QCM2=(SHAT-(AM-BM)**2)*(SHAT-(AM+BM)**2)/(4.*SHAT)
        QCM=SQRT(ABS(QCM2))
        QICM=SQRT(SHAT)/2.
        EA=SQRT(A2+QCM2)
        TTRUE=T+AB2
        COSCM=(TTRUE-A2+2.*EA*QICM)/(2.*QCM*QICM)
      ENDIF
C
      PCM2=(SHAT-(Q1+Q2)**2)*(SHAT-(Q1-Q2)**2)/(4.*SHAT)
      PCM=SQRT(ABS(PCM2))
      PCMV1(4)=SQRT(PCM2+QSQ1)
      PCMV1(3)=PCM*COSCM
      SINCM=SQRT(ABS(1.-COSCM**2))
      PHI=PI2*RNCJ(0)
      PCMV1(1)=PCM*SINCM*COS(PHI)
      PCMV1(2)=PCM*SINCM*SIN(PHI)
      DO 10 J=1,3
10    PCMV2(J)=-PCMV1(J)
      PCMV2(4)=SQRT(PCM2+QSQ2)
C
C-- BOOK PRIMARY PARTONS (PARTON CMS)
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      NHEP1=NHEP
      DO 31 J=1,4
31    PHEP(J,NHEP1)=PCMV1(J)
      PHEP(5,NHEP1)=Q1
      IDHEP(NHEP1)=JDENCJ(IFLAF1)
      JMOHEP(1,NHEP1)=0
      JMOHEP(2,NHEP1)=0
      JDAHEP(1,NHEP1)=0
      JDAHEP(2,NHEP1)=0
      ISTHEP(NHEP1)=1
C
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      NHEP2=NHEP
      DO 32 J=1,4
32    PHEP(J,NHEP2)=PCMV2(J)
      PHEP(5,NHEP2)=Q2
      IDHEP(NHEP2)=JDENCJ(IFLAF2)
      JMOHEP(1,NHEP2)=0
      JMOHEP(2,NHEP2)=0
      JDAHEP(1,NHEP2)=0
      JDAHEP(2,NHEP2)=0
      ISTHEP(NHEP2)=1
C
C-- BOOST PRIMARY PARTONS TO LAB SYSTEM
      DO 11 J=1,4
      ACT1(J)=PHEP(J,IACT1)
      ACT2(J)=PHEP(J,IACT2)
11    CONTINUE
      CALL CJLORL(ACT1,ACT2,NHEP1,NHEP2)
C
C-- QCD EVOLVE PRIMARY PARTONS
      CALL CJJETQ(NHEP1)
      CALL CJJETQ(NHEP2)
C
C-- FOR GENERAL HEAVY FLAVOR FORCING, REJECT IF HEAVY QUARKS ABSENT
      IF(KPRHEV.LT.3) RETURN
      NQHEV=0
      DO 62 I=1,NHEP
      IF(PHEP(5,I).LT.0.) GO TO 62
      IF(ABS(IDHEP(I)).NE.KFRFLA) GO TO 62
      NQHEV=NQHEV+1
62    CONTINUE
      IF(KPRHEV.EQ.3.AND.NQHEV.EQ.0) IFLGHV=1
      IF(KPRHEV.EQ.4) THEN
        IF(IM.GT.5) THEN
          IF(NQHEV.LE.2) IFLGHV=1
        ELSEIF((IM.EQ.3.OR.IM.EQ.5).AND.LF.GE.4) THEN
          IF(NQHEV.LE.2) IFLGHV=1
        ELSE
          IF(NQHEV.EQ.0) IFLGHV=1
        ENDIF
      ENDIF
      IF(IFLGHV.EQ.1) NHVREJ=NHVREJ+1
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS',I10
     1//1X,'***IN SUBROUTINE CJHARD'
     1//1X,'***EVENT NO. =  ',I10
     3//1X,'***INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJHEAB.
      SUBROUTINE CJHEAB
C     *****************
C-- DRELLYAN EVENT PART OF HEADING
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      COMMON/CJTOTA/SIGTOT
      REAL SIGTOT
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      CHARACTER*8 LABLCJ
      CHARACTER*2 WEAKCH,ZHCH,WHCH
      CHARACTER*8 CH8(NPDECX),BLANK
      DATA ZHCH,WHCH/'Z ','W '/
      DATA BLANK/'        '/
C
      IF(IEVTYP.NE.3) THEN
        IDBO=IDZ
        WEAKCH=ZHCH
        WIDTH=ZGAMMA
      ELSE
        IDBO=IDWP
        WEAKCH=WHCH
        WIDTH=WGAMMA
      ENDIF
      IF(IEVTYP.NE.4) THEN
        WRITE(ITLIS,25) WEAKCH
      ELSE
        WRITE(ITLIS,40)
      ENDIF
      WRITE(ITLIS,21) ALAMBD,CUTJET,QZEVOL,FACTK,PT2INT
C-- Z/W BOSON, WIDTH
      WRITE(ITLIS,65) WEAKCH,AMASCJ(IDBO)
      WRITE(ITLIS,64) WEAKCH,WIDTH
C-- DECAY
      KINTBO=INIDCJ(IDBO)
      IF(KDECAY(KINTBO).EQ.0) THEN
        WRITE(ITLIS,31) WEAKCH
      ELSE
        IF(IEVTYP.NE.4) THEN
          WRITE(ITLIS,33) WEAKCH
        ELSE
          WRITE(ITLIS,41)
        ENDIF
        I=0
        ND=IDB(KINTBO)-1
32      I=I+1
        ND=ND+1
        IF(MOTHER(ND).NE.IDBO) GO TO 34
        IF(IDBO.EQ.IDZ) THEN
          IF(KACTZ(I).EQ.0) GO TO 32
        ELSE
          IF(KACTW(I).EQ.0) GO TO 32
        ENDIF
        DO 36 LD=1,NPDECX
        IF(KDP(LD,ND).NE.0) THEN
          CH8(LD)=LABLCJ(KDP(LD,ND))
        ELSE
          CH8(LD)=BLANK
        ENDIF
36      CONTINUE
        WRITE(ITLIS,35) CH8
        GO TO 32
34      CONTINUE
      ENDIF
C-- X-SECTION
      IF(NEVGEN.EQ.0) THEN
        SIGTOT=0.
        WRITE(ITLIS,102)
        GO TO 101
      ENDIF
      SIGTOT=FXSCT*FLOAT(NEVHEP)/FLOAT(NGEX)*FACTK
      IF(IEVTYP.NE.4) THEN
        IF(KDECAY(KINTBO).NE.0) THEN
          IF(KREPET.NE.0) SIGTOT=SIGTOT/FLOAT(NREPET)
          WRITE(ITLIS,27) WEAKCH,SIGTOT
          WRITE(ITLIS,84) WEAKCH
          IF(KREPET.NE.0) WRITE(ITLIS,82) LABLCJ(KREPET),NREPET
        ELSE
          WRITE(ITLIS,27) WEAKCH,SIGTOT
        ENDIF
      ELSE
        WRITE(ITLIS,60) SIGTOT,BOMSMN,BOMSMX
      ENDIF
      IF(KREPET.EQ.0) THEN
        NRJTP=NEVGEN-NEVHEP
      ELSE
        NRJTP=NEVGEN*NREPET-NEVHEP
      ENDIF
      WRITE(ITLIS,85) NRJTP
      WRITE(ITLIS,83) FACTK
101   CONTINUE
      WRITE(ITLIS,16) NEVHEP
      IF(KREPET.NE.0) WRITE(ITLIS,17) NREPET
C-- QED RADIATION IN LEPTONIC DECAY MODES
      IF(KDECAY(KINTBO).NE.0.AND.KYWQED.EQ.0) WRITE(ITLIS,75)
      IF(KDECAY(KINTBO).NE.0.AND.KYWQED.EQ.1) WRITE(ITLIS,76)
      IF(KDECAY(KINTBO).NE.0.AND.KYWQED.EQ.2) WRITE(ITLIS,77)
C-- OTHER
      WRITE(ITLIS,74) NFLAV
      IF(IEVTYP.NE.4) WRITE(ITLIS,11) QMAS(6)
      IF(IFUNCX.EQ.0) WRITE(ITLIS,72)
      IF(IFUNCX.GE.1.AND.IFUNCX.LE.2) WRITE(ITLIS,73) IFUNCX
C
25    FORMAT(T2,1H*,10X,A2,'-PRODUCTION',T121,1H*/T2,1H*,T121,1H*)
40    FORMAT(T2,1H*,10X,'DRELLYAN CONTINUUM PRODUCTION'
     &,T121,1H*/T2,1H*,T121,1H*)
21    FORMAT(
     *T2,1H*,3X,'ALAMBD   =',E10.3,' GEV',T36,'CUTJET =',E10.3,' GEV'
     *,T66,'QZEVOL = ',E10.3,' GEV'
     *,T121,1H*/T2,1H*,T121,1H*/
     *T2,1H*,3X,'K FACTOR =',E10.3,T36,'PT2INT =',E10.3,' GEV**2'
     *,T121,1H*/T2,1H*,T121,1H*)
64    FORMAT(
     3T2,1H*,3X,A1,1X,'WIDTH = ',E10.3,' (GEV)'
     4,T121,1H*/T2,1H*,T121,1H*)
65    FORMAT(T2,1H*,3X,A2,' MASS = ',E10.3,' (GEV)'
     1,T121,1H*/T2,1H*,T121,1H*)
27    FORMAT(T2,1H*,3X,
     *A2,1X,'X-SECTION =',E10.3,' (MILLIBARN)'
     *,T121,1H*/T2,1H*,T121,1H*)
82    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES THE EFFECTS OF EVENT REPETITION'
     *,' (CHANGING DECAYS OF OPEN ',A8,'PARTICLES) :'
     *,T121,1H*/T2,1H*,T121,1H*
     *      /T2,1H*,3X,
     *'      NREPET =',I5
     *,T121,1H*/T2,1H*,T121,1H*)
83    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES K-FACTOR =',E10.3
     *,T121,1H*/T2,1H*,T121,1H*)
84    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES BR OF SELECTED ',A2
     *,' DECAY CHANNEL(S) (BR VARYING OVER BREIT-WIGNER)'
     *,T121,1H*/T2,1H*,T121,1H*)
85    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES EFFECTS FROM USER SELECTIONS'
     *,' - REJECTED EVENTS =',I10
     *,T121,1H*/T2,1H*,T121,1H*)
60    FORMAT(T2,1H*,3X,'DRELL-YAN X-SECTION = ' ,
     1E10.3,' (MILLIBARN)','   FOR ',E10.3,' < DILEPTON MASS (GEV) < '
     1,E10.3,
     2T121,1H*/T2,1H*,T121,1H*)
33    FORMAT(T2,1H*,3X,A2,1X,'DECAY CHANNELS ACTIVATED:',T121,1H*
     */T2,1H*,T121,1H*)
41    FORMAT(T2,1H*,3X,'FINAL CHANNEL ACTIVATED:',T121,1H*
     */T2,1H*,T121,1H*)
35    FORMAT(T2,1H*,3X,5(3X,A8),T121,1H*
     */T2,1H*,T121,1H*)
75    FORMAT(T2,1H*,3X,'QED RADIATION EFFECTS IN LEPTONIC'
     *,' DECAYS OF W/Z ARE NEGLECTED'
     *,T121,1H*/T2,1H*,T121,1H*)
76    FORMAT(T2,1H*,3X,'QED RADIATION EFFECTS IN LEPTONIC'
     *,' DECAYS OF W/Z ARE CALCULATED AT O(ALPHA) + LPA'
     *,T121,1H*/T2,1H*,T121,1H*)
77    FORMAT(T2,1H*,3X,'QED RADIATION EFFECTS IN LEPTONIC'
     *,' DECAYS OF W/Z ARE CALCULATED AT O(ALPHA)'
     *,T121,1H*/T2,1H*,T121,1H*)
74    FORMAT(T2,1H*,3X,'NO. OF QUARK FLAVORS =',I3
     *,T121,1H*/T2,1H*,T121,1H*)
11    FORMAT(T2,1H*,3X,'TOP QUARK MASS = ',E10.3,' (GEV)',T121,1H*
     */T2,1H*,T121,1H*)
31    FORMAT(T2,1H*,3X,A2,' W/Z LEFT UNDECAYED'
     *,T121,1H*/T2,1H*,T121,1H*)
72    FORMAT(T2,1H*,3X,'NA3 STRUCTURE FUNCTIONS USED'
     *,T121,1H*/T2,1H*,T121,1H*)
73    FORMAT(T2,1H*,3X,'EHLQ STRUCTURE FUNCTIONS SET ',I1
     *,' USED'
     *,T121,1H*/T2,1H*,T121,1H*)
16    FORMAT(T2,1H*,3X,'TOTAL NO. OF EVENTS ',I10,T121,1H*
     */T2,1H*,T121,1H*)
17    FORMAT(T2,1H*,3X,'(INCLUDING EVENT REPETITION, NREPET =',I5,')'
     *,T121,1H*/T2,1H*,T121,1H*)
102   FORMAT(T2,1H*,3X,'***NO EVENTS GENERATED***'
     *,T121,1H*/T2,1H*,T121,1H*)
C
      RETURN
      END
CDECK  ID>, CJHEAE.
      SUBROUTINE CJHEAE
C     *****************
C-- E+E- EVENT PART OF HEADING
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      COMMON/CJTOTA/SIGTOT
      REAL SIGTOT
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      CHARACTER*8 LABLCJ
      CHARACTER*8 CH8(NPDECX),BLANK
      CHARACTER*2 WEAKCH
      DATA WEAKCH/'Z '/
      DATA BLANK/'        '/
C
      WRITE(ITLIS,12) ALAMBD,CUTJET
C-- Z MASS AND WIDTH
      WRITE(ITLIS,13) WEAKCH,ZMASS
      WRITE(ITLIS,14) WEAKCH,ZGAMMA
C-- DECAY
      WRITE(ITLIS,33) WEAKCH
      I=0
      ND=IDB(INIDCJ(IDZ))-1
32    I=I+1
      IF(I.GT.NDECZ) GO TO 34
      ND=ND+1
      IF(MOTHER(ND).NE.IDZ) GO TO 32
      IF(KACTZ(I).EQ.0) GO TO 32
      DO 36 LD=1,NPDECX
      IF(KDP(LD,ND).NE.0) THEN
        CH8(LD)=LABLCJ(KDP(LD,ND))
      ELSE
        CH8(LD)=BLANK
      ENDIF
36    CONTINUE
      WRITE(ITLIS,35) CH8
      GO TO 32
34    CONTINUE
C-- X-SECTION
      IF(NEVGEN.EQ.0) THEN
        SIGTOT=0.
        WRITE(ITLIS,18)
        GO TO 100
      ENDIF
      print *,'setting',FXSCT,NEVHEP,NEVGEN,NREPET
      SIGTOT=FXSCT*FLOAT(NEVHEP)/FLOAT(NEVGEN)
      IF(KREPET.NE.0) SIGTOT=SIGTOT/FLOAT(NREPET)
      WRITE(ITLIS,19) SIGTOT
      WRITE(ITLIS,20)
      IF(KREPET.NE.0) WRITE(ITLIS,21) LABLCJ(KREPET),NREPET
C-- NUMBER OF EVENTS
      IF(KREPET.EQ.0) THEN
        NRJTP=NEVGEN-NEVHEP
      ELSE
        NRJTP=NEVGEN*NREPET-NEVHEP
      ENDIF
      WRITE(ITLIS,22) NRJTP
      WRITE(ITLIS,23) NEVHEP
      IF(KREPET.NE.0) WRITE(ITLIS,25) NREPET
100   CONTINUE
C-- INITIAL QED RADIATION
      IF(KEEQED.EQ.0) THEN
        WRITE(ITLIS,24)
      ELSEIF(KEEQED.EQ.2) THEN
        WRITE(ITLIS,30)
      ENDIF
C-- OTHER
      WRITE(ITLIS,28) NFLAV
      IF(NFLAV.GE.6) WRITE(ITLIS,29) QMAS(6)
C
12    FORMAT(T2,1H*,3X,'ALAMBD =',E10.3,' GEV'
     *,T36,'CUTJET =',E10.3,' GEV'
     *,T121,1H*/T2,1H*,T121,1H*)
13    FORMAT(T2,1H*,3X,A2,'MASS = ',E10.3,6H (GEV)
     1,T121,1H*/T2,1H*,T121,1H*)
14    FORMAT(T2,1H*,3X,A2,'WIDTH = ',E10.3,6H (GEV)
     *,T121,1H*/T2,1H*,T121,1H*)
17    FORMAT(T2,1H*,3X,1H(,'E+E-',10H   --->   ,A4,2X,A4,1H),T121,1H*
     */T2,1H*,T121,1H*)
18    FORMAT(T2,1H*,3X,'***NO EVENTS GENERATED***'
     *,T121,1H*/T2,1H*,T121,1H*)
33    FORMAT(T2,1H*,3X,A2,1X,'FINAL CHANNELS ACTIVATED:',T121,1H*
     */T2,1H*,T121,1H*)
35    FORMAT(T2,1H*,3X,5(3X,A8),T121,1H*
     */T2,1H*,T121,1H*)
19    FORMAT(T2,1H*,3X,
     *'X-SECTION =',E10.3,' (MILLIBARN)'
     *,T121,1H*/T2,1H*,T121,1H*)
20    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES THE EFFECTS OF FINAL CHANNEL'
     *,' SELECTION'
     *,T121,1H*/T2,1H*,T121,1H*)
21    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES THE EFFECTS OF EVENT REPETITION'
     *,' (CHANGING DECAYS OF OPEN ',A8,'PARTICLES), NREPET =',I5
     *)
22    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES EFFECTS FROM USER SELECTIONS'
     *,' - REJECTED EVENTS =',I10
     *,T121,1H*/T2,1H*,T121,1H*)
23    FORMAT(T2,1H*,3X,'TOTAL NO. OF EVENTS ',I10,T121,1H*
     */T2,1H*,T121,1H*)
25    FORMAT(T2,1H*,3X,'(INCLUDING EVENT REPETITION, NREPET =',I5,')'
     *,T121,1H*/T2,1H*,T121,1H*)
24    FORMAT(T2,1H*,3X,'INITIAL QED RADIATION NOT ACTIVE'
     *,T121,1H*/T2,1H*,T121,1H*)
28    FORMAT(T2,1H*,3X,'NO. OF QUARK FLAVORS =',I3
     *,T121,1H*/T2,1H*,T121,1H*)
29    FORMAT(T2,1H*,3X,16HTOP QUARK MASS = ,E10.3,6H (GEV),T121,1H*
     */T2,1H*,T121,1H*)
30    FORMAT(T2,1H*,3X,'QED RADIATION ACTIVE ACCORDING TO BKJ'
     *,T121,1H*/T2,1H*,T121,1H*)
C
      RETURN
      END
CDECK  ID>, CJHEAH.
      SUBROUTINE CJHEAH
C     *****************
C-- TWOJET & MINBIAS EVENTS PART OF HEADING
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      COMMON/CJTOTA/SIGTOT
      REAL SIGTOT
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      CHARACTER*8 LABLCJ
      CHARACTER*6 CHFLA(3),CHFLA2(3)
      DATA CHFLA/'CHARM','BOTTOM','TOP'/
      DATA CHFLA2/'C-CB','B-BB','T-TB'/
C
C-- BASIC CONSTANTS
      WRITE(ITLIS,21) ALAMBD,PTCUT,PT2INT,SIGINL
      WRITE(ITLIS,71) CUTJET,QZEVOL,FACTK
C-- CROSS SECTION
      IF(NEVGEN.EQ.0) THEN
        SIGTOT=0.
        WRITE(ITLIS,102)
        GO TO 101
      ENDIF
      IF(KPRHEV.EQ.0) THEN
        IF(PTMIN.LE.PTCUT) THEN
          SIGTOT=SIGINL*FLOAT(NEVHEP)/FLOAT(NEVGEN)
          WRITE(ITLIS,31) FRHARD
          WRITE(ITLIS,34) SIGTOT
        ELSE
          SIGTOT=SIGHRD*FLOAT(NEVHEP)/FLOAT(NEVGEN)
          WRITE(ITLIS,30) PTMIN,PTMAX,SIGTOT
        ENDIF
C-- FORCING OF HEAVY QUARK PRODUCTION
      ELSE
        IF(KPRHEV.EQ.1) WRITE(ITLIS,28) CHFLA(KFRFLA-3)
        IF(KPRHEV.EQ.2) WRITE(ITLIS,58) CHFLA(KFRFLA-3)
        IF(KPRHEV.EQ.3) WRITE(ITLIS,57) CHFLA(KFRFLA-3)
        IF(KPRHEV.EQ.4) WRITE(ITLIS,59) CHFLA(KFRFLA-3)
        IF(PTMIN.LE.PTCUT) THEN
          SIGTOT=FRHARD*SIGINL*FLOAT(NEVHEP)/FLOAT(NEVGEN+NHVREJ)
          IF(KREPET.NE.0) SIGTOT=SIGTOT/FLOAT(NREPET)
          WRITE(ITLIS,29) CHFLA2(KFRFLA-3),SIGTOT
          IF(KPRHEV.EQ.1) THEN
            IF(PTCUT.LE.QMAS(KFRFLA)) THEN
              WRITE(ITLIS,35) CHFLA2(KFRFLA-3)
            ELSE
              WRITE(ITLIS,36) CHFLA2(KFRFLA-3),PTCUT,LABLCJ(KFRFLA)
     &        ,QMAS(KFRFLA)
            ENDIF
          ENDIF
        ELSE
          SIGTOT=SIGHRD*FLOAT(NEVHEP)/FLOAT(NEVGEN+NHVREJ)
          IF(KREPET.NE.0) SIGTOT=SIGTOT/FLOAT(NREPET)
          WRITE(ITLIS,30) PTMIN,PTMAX,SIGTOT
        ENDIF
      ENDIF
      IF(KREPET.EQ.0) THEN
        NRJTP=NEVGEN-NEVHEP
      ELSE
        NRJTP=NEVGEN*NREPET-NEVHEP
      ENDIF
      WRITE(ITLIS,85) NRJTP
      WRITE(ITLIS,83) FACTK
      IF(KREPET.NE.0) WRITE(ITLIS,82) LABLCJ(KREPET),NREPET
      IF(NFLAV.EQ.6) WRITE(ITLIS,32) QMAS(6)
C
101   CONTINUE
      WRITE(ITLIS,25) NSIGMA,NPRESH,TPRETB
      IF(KPRHEV.GE.3) WRITE(ITLIS,26) NHVREJ
      IF(PTMIN.GT.PTCUT) THEN
        WRITE(ITLIS,75) NEVHEP
        IF(KREPET.NE.0) WRITE(ITLIS,17) NREPET
      ELSE
        WRITE(ITLIS,74) NEVHEP,NHARD
      ENDIF
C
      IF(KPTWGT.EQ.1) THEN
        IF(PTMIN.LE.PTCUT) THEN
          WRITE(ITLIS,23) FRAGEH*100.
        ELSE
          WRITE(ITLIS,24)
        ENDIF
      ENDIF
C
      WRITE(ITLIS,27) NFLAV
      IF(IFUNCX.EQ.0) WRITE(ITLIS,72)
      IF(IFUNCX.GE.1.AND.IFUNCX.LE.2) WRITE(ITLIS,73) IFUNCX
21    FORMAT(T2,1H*,3X,'ALAMBD = ',E10.3,' GEV',3X,'PTCUT = ',
     *E10.3,' GEV ',3X,'PT2INT = ',E10.3,' GEV**2',3X,
     *'SIGINL = ',E10.3,' MILLIBARN ',T121,1H*/T2,1H*,T121,1H*)
23    FORMAT(T2,1H*,3X,'***WEIGHTED EVENTS -- HARD EVENTS > ',F4.0,
     *' PER CENT (APPROX)',T121,1H*/T2,1H*,T121,1H*)
24    FORMAT(T2,1H*,3X,'***WEIGHTED EVENTS',T121,1H*/T2,1H*,T121,
     +1H*)
71    FORMAT(T2,1H*,3X,'CUTJET = ',E10.3,' GEV'
     *,3X,'QZEVOL = ',E10.3,' GEV',3X,'K FACTOR = ',E10.3
     *,T121,1H*/T2,1H*,T121,1H*)
25    FORMAT(T2,1H*,3X,'NO. OF KINEMATIC POINTS TO CALCULATE X-SECTION'
     *,'    =',I10,T121,1H*/T2,1H*,T121,1H*/
     *T2,1H*,3X,'NO. OF PARTON SHOWER PAIRS TO CALCULATE X-SECTION'
     *,' =',I10,T121,1H*/T2,1H*,T121,1H*/
     *T2,1H*,3X,'(TIME SPENT TO CALCULATE X-SECTION = ',E10.3,' SEC)'
     *,T121,1H*/T2,1H*,T121,1H*)
26    FORMAT(T2,1H*,3X,'NO. OF REJECTED KINEMATIC POINTS TO CALCULATE'
     *,' X-SECTION',' =',I10,T121,1H*/
     *T2,1H*,3X,'    (X-SECTION ACCURACY IS DETERMINED BY THE'
     *,' NO. OF ACCEPTED EVENTS/NREPET)'
     *,T121,1H*/T2,1H*,T121,1H*)
27    FORMAT(T2,1H*,3X,'NO. OF QUARK FLAVORS ',I3,T121,1H*/T2,1H*,
     *T121,1H*)
28    FORMAT(T2,1H*,3X,'FORCED FUSION PRODUCTION OF ',A6
     *   ,T121,1H*/T2,1H*,T121,1H*)
58    FORMAT(T2,1H*,3X,'FORCED FLAVOR EXCITATION PRODUCTION OF ',A6
     *   ,T121,1H*/T2,1H*,T121,1H*)
59    FORMAT(T2,1H*,3X,'FORCED GLUON SPLITTING PRODUCTION OF ' ,A6
     *   ,T121,1H*/T2,1H*,T121,1H*)
57    FORMAT(T2,1H*,3X,'FORCED PRODUCTION OF  ',A6
     *   ,T121,1H*/T2,1H*,T121,1H*)
29    FORMAT(T2,1H*,3X,'X-SECTION FOR ',A6,E10.3,' (MILLIBARN)'
     &,T121,1H*/T2,1H*,T121,1H*)
35    FORMAT(T2,1H*,3X,'THIS IS THE TOTAL FUSION X-SECTION FOR ',A6
     &,T121,1H*/T2,1H*,T121,1H*)
36    FORMAT(T2,1H*,3X,'THIS IS ONLY PART OF THE TOTAL FUSION'
     &,' X-SECTION FOR ',A6,' (PTCUT =',E10.3,' > MASS(',A1,') ='
     &,E10.3,' GEV)'
     &,T121,1H*/T2,1H*,T121,1H*)
30    FORMAT(T2,1H*,3X,'GENERATION FORCED OVER THE RANGE: ',T121,1H*
     &/T2,1H*,3X,E10.3,' < PT(HARD SCATTERING) < ',E10.3,' (GEV)'
     &,T121,1H*/T2,1H*  ,T121,1H*
     &/T2,1H*,3X,'WITH  X-SECTION = ',E10.3,' (MILLIBARN)',T121,1H*
     &/T2,1H*  ,T121,1H*)
32    FORMAT(T2,1H*,3X,'TOP QUARK MASS = ',E10.3,' GEV',T121,1H*/T2,
     *1H* ,T121,1H*)
31    FORMAT(T2,1H*,3X,'QCD X-SECT. = ',E12.4,1X,'OF INEL. X-SECT.',
     *    T121,1H*/T2,1H*,T121,1H*)
34    FORMAT(T2,1H*,3X,'(NO PT FORCING) TOTAL X-SECTION = '
     *,E10.3,' (MILLIBARN)'
     *,T121,1H*/T2,1H*,T121,1H*)
82    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES THE EFFECTS OF EVENT REPETITION'
     *,' (CHANGING DECAYS OF OPEN ',A8,'PARTICLES), NREPET =',I5
     *,T121,1H*/T2,1H*,T121,1H*)
83    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES K-FACTOR =',E10.3
     *,T121,1H*/T2,1H*,T121,1H*)
85    FORMAT(T2,1H*,3X,
     *'   ***X-SECTION VALUE INCLUDES EFFECTS FROM USER SELECTIONS'
     *,' - REJECTED EVENTS =',I10
     *,T121,1H*/T2,1H*,T121,1H*)
72    FORMAT(T2,1H*,3X,'NA3 STRUCTURE FUNCTIONS USED'
     *,T121,1H*/T2,1H*,T121,1H*)
73    FORMAT(T2,1H*,3X,'EHLQ STRUCTURE FUNCTIONS SET ',I1
     *,' USED'
     *,T121,1H*/T2,1H*,T121,1H*)
74    FORMAT(T2,1H*,3X,'TOTAL NO. OF EVENTS ',I7,5X,
     *'NO. OF HARD EVENTS ',I7,T121,1H*/T2,1H*,T121,1H*)
75    FORMAT(T2,1H*,3X,'TOTAL NO. OF EVENTS ',I7
     *,T121,1H*/T2,1H*,T121,1H*)
17    FORMAT(T2,1H*,3X,'(INCLUDING EVENT REPETITION, NREPET =',I5,')'
     *,T121,1H*/T2,1H*,T121,1H*)
102   FORMAT(T2,1H*,3X,'***NO EVENTS GENERATED***'
     *,T121,1H*/T2,1H*,T121,1H*)
C
      RETURN
      END
CDECK  ID>, CJHEAT.
      SUBROUTINE CJHEAT(TINIT)
C     ************************
C-- PRINTS HEADING
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MXCUEV=50,MXCUEJ=50)
      COMMON/CJCUES/CUEV(MXCUEV,10,2),CUE(MXCUEJ,6)
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJOVEC/SPYOVR,KOVER
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      COMMON/CJTOTA/SIGTOT
      REAL SIGTOT
      PARAMETER (MAXRAD=100)
      COMMON/CJZWRA/P(MAXRAD,5)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      CHARACTER*6 CHFLA(3)
      CHARACTER*8 LABLCJ
      CHARACTER*8 CH8(NDFORC),BLANK
C
      DATA CHFLA/'CHARM','BOTTOM','TOP'/,BLANK/'       '/
C
      WRITE(ITLIS,1)
      WRITE(ITLIS,2)
      WRITE(ITLIS,26)
      WRITE(ITLIS,5)
      WRITE(ITLIS,11) FLOAT(IDVER)/100.,DAVERS
      WRITE(ITLIS,2)
      WRITE(ITLIS,6) IDG
      WRITE(ITLIS,2)
      WRITE(ITLIS,3)
      WRITE(ITLIS,3)
      IF(IEVTYP.NE.5.AND.KPBAR.EQ.1) WRITE(ITLIS,18) ECM
      IF(IEVTYP.NE.5.AND.KPBAR.NE.1) WRITE(ITLIS,19) ECM
      IF(IEVTYP.EQ.5) WRITE(ITLIS,17) ECM
      WRITE(ITLIS,3)
C
C-- CALL PROCESS SPECIFIC HEAD ROUTINES
      IF(IEVTYP.EQ.1) CALL CJHEAH
      IF(IEVTYP.GE.2.AND.IEVTYP.LE.4) CALL CJHEAB
      IF(IEVTYP.EQ.5) CALL CJHEAE
C
1     FORMAT(1H1,5(/))
2     FORMAT(T2,120(1H*)/T2,120(1H*))
3     FORMAT(T2,1H*,T121,1H*)
4     FORMAT(T2,120(1H*),5(/))
5     FORMAT(T2,120(1H*))
26    FORMAT(T2,54(1H*),12X,54(1H*)/T2,54(1H*),'   COJETS   ',54(1H*)
     *   /T2,54(1H*),12X,54(1H*))
11    FORMAT(T2,46(1H*),' VERSION',F6.2,' -- ',A9,' ',46(1H*))
6     FORMAT(T2,53(1H*),'    RUN ID    ',53(1H*)
     *      /T2,53(1H*),'  Y M D H M S ',53(1H*)
     *      /T2,53(1H*),' ', 2I6,' ',53(1H*))
18    FORMAT(T2,1H*,10X,'ANTIPROTON-PROTON COLLISIONS',10X,'ECM =',
     1E10.3,' GEV ',T121,1H*/T2,1H*,T121,1H*)
19    FORMAT(T2,1H*,10X,'PROTON-PROTON COLLISIONS',10X,'ECM =',E10.3
     1     ,' GEV ',T121,1H*/T2,1H*,T121,1H*)
17    FORMAT(T2,1H*,10X,'E+E- ANNIHILATION',10X,'ECM =',
     1E10.3,' GEV ',T121,1H*/T2,1H*,T121,1H*)
C
      IF(KYEVOL.EQ.0) GO TO 66
      WRITE(ITLIS,3)
      WRITE(ITLIS,62) KYEVOL
62    FORMAT(T2,1H*,3X,'****WARNING -- JOB HAS BEEN RUN WITH KYEVOL ='
     1 ,I2,' (PARTIAL OR TOTAL SUPPRESSION OF QCD BREMSSTRAHLUNG)'
     *,T121,1H*/T2,1H*,T121,1H*)
      WRITE(ITLIS,3)
66    CONTINUE
C
      IF(NFLAV.LT.6.OR.KYTQCD.EQ.0) GO TO 63
      WRITE(ITLIS,3)
      WRITE(ITLIS,64) KYTQCD
64    FORMAT(T2,1H*,3X,'****WARNING -- JOB HAS BEEN RUN WITH KYTQCD ='
     1,I2,T121,1H*/T2,1H*,3X
     2,'****(PARTIAL OR TOTAL SUPPRESSION OF QCD BREMSSTRAHLUNG IN TOP'
     2,' DECAYS)'
     *,T121,1H*/T2,1H*,T121,1H*)
      WRITE(ITLIS,3)
63    CONTINUE
C
      IF(NOFRGM.EQ.1) WRITE(ITLIS,40)
40    FORMAT(T2,1H*,3X,'FINAL STATE FROZEN AT THE LEVEL OF PARTONS'
     &,T121,1H*/T2,1H*,T121,1H*)
C
      IF(KREPET.NE.0) WRITE(ITLIS,56) NREPET,CHFLA(KREPET-3)
56    FORMAT(T2,1H*,3X,'EVENTS REPEATED ',I5,' TIMES CHANGING ONLY'
     *,' WEAK DECAYS OF ',A6,' PARTICLES '
     *,T121,1H*/T2,1H*,T121,1H*)
C
      IF(NFLAV.GE.6) THEN
        IF(KYTQED.EQ.0) THEN
          WRITE(ITLIS,67)
        ELSEIF(KYTQED.EQ.1) THEN
          WRITE(ITLIS,68)
        ELSEIF(KYTQED.EQ.2) THEN
          WRITE(ITLIS,69)
        ENDIF
      ENDIF
67    FORMAT(T2,1H*,3X,'QED RAD. EFFECTS IN TOP SEMILEPTONIC DECAYS'
     *,' ARE NEGLECTED'
     *,T121,1H*/T2,1H*,T121,1H*)
68    FORMAT(T2,1H*,3X,'QED RAD. EFFECTS IN TOP SEMILEPTONIC DECAYS'
     *,' ARE CALCULATED AT O(ALPHA) + LPA'
     *,T121,1H*/T2,1H*,T121,1H*)
69    FORMAT(T2,1H*,3X,'QED RAD. EFFECTS IN TOP SEMILEPTONIC DECAYS'
     *,' ARE CALCULATED AT O(ALPHA)'
     *,T121,1H*/T2,1H*,T121,1H*)
C
      IF(NODECY.EQ.1) THEN
        WRITE(ITLIS,72)
72    FORMAT(T2,1H*,3X,'ALL PARTICLE DECAYS HAVE BEEN SUPPRESSED'
     *,T121,1H*/T2,1H*,T121,1H*)
        GO TO 80
      ENDIF
C
        IF(NOBROA.EQ.1) THEN
          WRITE(ITLIS,92)
        ELSE
          WRITE(ITLIS,93)
        ENDIF
92    FORMAT(T2,1H*,3X,'MASS BROADENING IN PARTICLE DECAYS NOT ACTIVE'
     *,T121,1H*/T2,1H*,T121,1H*)
93    FORMAT(T2,1H*,3X,'MASS BROADENING IN PARTICLE DECAYS ACTIVE'
     *,T121,1H*/T2,1H*,T121,1H*)
C
      WRITE(ITLIS,73)
73    FORMAT(T2,1H*,3X,'DECAYS OF THE FOLLOWING PARTICLES HAVE BEEN'
     *,' SUPPRESSED:',T121,1H*)
      IF(NSTOPD.NE.0) THEN
        DO 74 N=1,NSTOPD
        WRITE(ITLIS,75) LABLCJ(KSTOPD(N)),IPDGCJ(KSTOPD(N)),KSTOPD(N)
75    FORMAT(T2,1H*,3X,A8,'  PDG ID = ',I6,'  ISAJET ID = ',I6
     *,T121,1H*)
74      CONTINUE
        WRITE(ITLIS,3)
      ELSE
        WRITE(ITLIS,76)
76    FORMAT(T2,1H*,3X,'  NONE'
     *,T121,1H*/T2,1H*,T121,1H*)
      ENDIF
C
      WRITE(ITLIS,78)
78    FORMAT(T2,1H*,3X,'FORCED DECAY MODES:',T121,1H*)
      NWRITE=0
      IF(NFORCE.EQ.0) GO TO 77
      DO 79 N=1,NFORCE
      IF(IEVTYP.GE.2.AND.IEVTYP.LE.5.AND.(KFORCE(1,N).EQ.IDZ.OR.
     &KFORCE(1,N).EQ.IDWP)) GO TO 79
      NWRITE=NWRITE+1
      DO 36 L=1,NDFORC
      IF(KFORCE(L,N).NE.0) THEN
        CH8(L)=LABLCJ(KFORCE(L,N))
      ELSE
        CH8(L)=BLANK
      ENDIF
36    CONTINUE
      WRITE(ITLIS,35) CH8
35    FORMAT(T2,1H*,3X,A8,'-->',5(3X,A8),T121,1H*)
79    CONTINUE
      IF(NWRITE.GT.0) WRITE(ITLIS,3)
77    CONTINUE
      IF(NWRITE.EQ.0) WRITE(ITLIS,76)
C
80    CONTINUE
C
      IF(NOUNST.EQ.1) THEN
        WRITE(ITLIS,97)
97    FORMAT(T2,1H*,3X,'****STABLE PARTICLES ONLY HAVE BEEN RETAINED'
     *,T121,1H*/T2,1H*,T121,1H*)
      ELSE
        WRITE(ITLIS,98)
98    FORMAT(T2,1H*,3X,'BOTH STABLE AND UNSTABLE PARTICLES HAVE BEEN'
     *,' RETAINED'
     *,T121,1H*/T2,1H*,T121,1H*)
      ENDIF
C
      IF(NOPDG.EQ.1) THEN
        WRITE(ITLIS,41)
      ELSE
        WRITE(ITLIS,42)
      ENDIF
41    FORMAT(T2,1H*,3X,'***ISAJET CODES USED IN FINAL OUTPUT'
     *,T121,1H*/T2,1H*,T121,1H*)
42    FORMAT(T2,1H*,3X,'PDG CODES USED IN FINAL OUTPUT'
     *,T121,1H*/T2,1H*,T121,1H*)
C
      IF(NEVHEP.GT.0) THEN
        CALL CJTLFT(TLEFT)
        DTIME=(TINIT-TLEFT)/FLOAT(NEVHEP)
        WRITE(ITLIS,3)
        WRITE(ITLIS,20) DTIME
      ENDIF
20    FORMAT(T2,1H*,3X,'TIME SPENT PER EVENT:',E12.3,' SEC'
     *,T121,1H*/T2,1H*,T121,1H*)
C
      WRITE(ITLIS,3)
      WRITE(ITLIS,3)
      WRITE(ITLIS,3)
      IF(SPYOVR.GT.0.) WRITE(ITLIS,49)
49    FORMAT(T2,1H*,'****DIMENSION OVERFLOW HAS OCCURRED (NOT COUNTED'
     1,' IN STATISTICS BELOW) -- LOOK FOR DIAGNOSTICS BEFORE THIS PRIN'
     2,'TING****',T121,1H*/T2,1H*,T121,1H*)
C
      WRITE(ITLIS,50)
50    FORMAT(T2,1H*,1X,'**UTILIZATION OF ARRAY DIMENSIONS**',T121,
     11H*/T2,1H*,1X,'MAX UTILIZATION OF VARIABLE LENGTH ARRAYS',
     2' IS REPORTED',T121,1H*,
     3/T2,1H*,1X,'THEIR DIMENSIONS CAN BE CHANGED BY MEANS OF',
     4' LISTED DIMENSION CONTROL PARAMETERS',T121,1H*)
      MNBOOK=MAX(MNBOOK,MMBOOK+1)
      WRITE(ITLIS,52) NMXHEP,MNHEP,MXINQ,MNBOOK,MAXRAD,MNRAD
     1,MXCUEV,MNCUEV,MXCUEJ,MNCUEJ
52    FORMAT(
     * T2,1H*,1X,'CURR. DIM. NMXHEP=',I6,'  USED UP TO',I6,T121,1H*
     */T2,1H*,1X,'CURR. DIM. MXINQ =',I6,'  USED UP TO',I6,T121,1H*
     */T2,1H*,1X,'CURR. DIM. MAXRAD=',I6,'  USED UP TO',I6,T121,1H*
     */T2,1H*,1X,'CURR. DIM. MXCUEV=',I6,'  USED UP TO',I6,T121,1H*
     */T2,1H*,1X,'CURR. DIM. MXCUEJ=',I6,'  USED UP TO',I6,T121,1H*
     *)
C
      WRITE(ITLIS,3)
      WRITE(ITLIS,4)
C
C-- LAST HEPEVT RECORD
      ISTHEP(1)=NEVHEP
      PHEP(1,1)=SIGTOT
c      print *,'setting',sigtot,phep(1,1)
      NEVHEP=-2
      NHEP=1
      DO 21 L=1,2
      JMOHEP(L,1)=0
21    JDAHEP(L,1)=0
      DO 22 L=1,4
      PHEP(L+1,1)=0.
22    VHEP(L,1)=0.
C
      RETURN
      END
CDECK  ID>, CJHGEV.
      SUBROUTINE CJHGEV
C     *****************
C-- HANDLES EVENT GENERATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPTHD/PTHARD,WEIGHT
      REAL PTHARD,WEIGHT
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      LOGICAL ACCEPT
      DIMENSION TV(2),UV(2),WGV(2,6),WFDSDT(6),WTDS(2)
C
      DATA NACCPL/0/
      DATA ICALL/0/
C
      IF(ICALL.EQ.0) CALL CJHPRE
      ICALL=1
700   IFIREF=0
C
C-- DECIDE WHETHER IT IS A MINBIAS (SMALL PT) EVENT OR NOT
      IF(PTMIN.LE.PTCUT.AND.KPRHEV.EQ.0) THEN
        IF(RNCJ(0).GT.FRAGEH) GO TO 300
      ENDIF
C-- GENERATE HARD QSQ (=2STU/(S**2+T**2+U**2), ABOUT =PT**2)
      CALL CJGEQ(ALQ,IALQ)
      QSQ=EXP(ALQ*ALQZM+ALLAM2)
      PTHARD=SQRT(QSQ)
      YQSQ=LOG(ALQ)
      FACTW=PI/(BALPHS*LOG(QSQ/ALAMBD**2))**2
      IF(KPTWGT.EQ.1) WEIGHT=PTWGTM/PTWGCJ(QSQ)
C-- GENERATE COLLISION CHANNEL
      IFIRE=0
      RR=RNCJ(0)
      DO 10 IW=1,5
      IPACH=IW
      IF(RR.LT.WGALQ(IALQ,IW,1)) GO TO 11
10    CONTINUE
11    CONTINUE
1     CONTINUE
C-- GENERATE PAIR OF INITIAL PARTONS
      CALL CJGPAR
C-- GENERATE PARTON CASCADE (LLA QCD)
      JBOOK=2
      DO 12 IB=1,2
      NBOOK(IB)=1
      MBOOK(IB)=0
      ISTOP(IB)=0
12    IBACK(IB)=0
      IBEAM=1
      ZERO=0.
      CALL CJQSGE(IFLING(1),ZERO,YIN1,QSQIN1)
      CALL CJBOOK(IFLING(1),0,XMING(1),YIN1,XING(1),PXING(1),PYING(1)
     +,ZERO,YF)
      IBACK(IBEAM)=0
100   CONTINUE
      IBEAM=1
      CALL CJEVOL(1,YQSQ)
      MMBOOK=MAX(MMBOOK,MBOOK(1))
      IF(ISTOP(1).EQ.1) GO TO 200
      MBOOK(2)=0
      IBEAM=2
      CALL CJQSGE(IFLING(2),ZERO,YIN2,QSQIN2)
      CALL CJBOOK(IFLING(2),0,XMING(2),YIN2,XING(2),PXING(2),PYING(2)
     +,ZERO,YF)
      IBACK(IBEAM)=0
      ISTOP(IBEAM)=0
150   CONTINUE
      CALL CJEVOL(1,YQSQ)
      MMBOOK=MAX(MMBOOK,MBOOK(2))
      IF(ISTOP(2).EQ.1) GO TO 100
C-- PREPARE TO ENTER HARD PROCESS
      IFLA1=PARACT(1,1,1)
      XM1=PARACT(1,3,1)
      XP1=PARACT(1,5,1)
      PX1=PARACT(1,6,1)
      PY1=PARACT(1,7,1)
      MFLA1=ABS(IFLA1)
      IFLA2=PARACT(1,1,2)
      XM2=PARACT(1,3,2)
      XP2=PARACT(1,5,2)
      PX2=PARACT(1,6,2)
      PY2=PARACT(1,7,2)
      SHAT=(XP1*XP2+XM1*XM2)*S-2.*(PX1*PX2+PY1*PY2)
      IF(SHAT.LT.3.*QSQ) GO TO 150
      IF(KPRHEV.EQ.1) THEN
        IF(SHAT.LE.THRFLA(KFRFLA)) GO TO 150
      ELSEIF(KPRHEV.EQ.2) THEN
        IF(SHAT.LE.AM2HEV(KFRFLA)) GO TO 150
      ENDIF
C
      MFLA2=ABS(IFLA2)
      IM=IMATCH(MFLA1,MFLA2)
      IF(IM.NE.2) GO TO 212
      IF(IFLA1*IFLA2.LT.0) IM=3
212   CONTINUE
      IF(IM.NE.9) GO TO 272
      IF(IFLA1*IFLA2.LT.0) IM=10
272   CONTINUE
      IF(KPRHEV.EQ.1) THEN
        IF(IM.NE.3.AND.IM.NE.5.AND.IM.NE.10) GO TO 150
      ELSEIF(KPRHEV.EQ.2) THEN
        IF(IM.LE.5) GO TO 150
        IF(MFLA1.NE.KFRFLA.AND.MFLA2.NE.KFRFLA) GO TO 150
      ENDIF
C
C-- THRESHOLD CONDITION PASSED - CALCULATE MATRIX ELEMENTS
      IFIRE=1
      FACTWS=FACTW/SHAT**2
      DSQ=SQRT(ABS(1.-4./(1.+SHAT/QSQ)))
      TV(1)=-SHAT*.5*(1.+DSQ)
      TV(2)=-SHAT*.5*(1.-DSQ)
      UV(1)=-SHAT-TV(1)
      UV(2)=-SHAT-TV(2)
      CALL CJDSDT(IM,MFLA1,MFLA2,SHAT,TV(1),UV(1),WTDS(1),WFDSDT)
      DO 216 L=1,6
216   WGV(1,L)=WFDSDT(L)
      CALL CJDSDT(IM,MFLA1,MFLA2,SHAT,TV(2),UV(2),WTDS(2),WFDSDT)
      DO 217 L=1,6
217   WGV(2,L)=WFDSDT(L)
      WGT=1.E10
      IF(DSQ.GT.0.)
     *WGT=(WTDS(1)+WTDS(2))*FACTWS/(DSQ*(QSQ/SHAT+1.)**2)
      IF(WGT.LT.1.E-30) GO TO 150
      RTU=WTDS(1)/(WTDS(1)+WTDS(2))
      NIT=0
C-- HANDLE FLUCTUATIONS FROM MEAN WEIGHT (TO HAVE WEIGHT=1 EVENTS)
      WGTX=(SQRT(FLOAT(NEVGEN)*WGALQ(IALQ,IPACH,3))/4.+1.)
     *    *WGALQ(IALQ,IPACH,2)
      WGT=MIN(WGT,WGTX)
      NLOOP=WGT/WGALQ(IALQ,IPACH,2)+1
210   CONTINUE
      IFAIL=0
      IFLGHV=0
      IF(WGT.GT.WGALQ(IALQ,IPACH,2)) GO TO 211
      IF(WGT.LT.RNCJ(0)*WGALQ(IALQ,IPACH,2)) GO TO 150
211   CONTINUE
      NIT=NIT+1
      IF(NIT.GT.2*NLOOP) GO TO 150
      WGT=WGT-WGALQ(IALQ,IPACH,2)
C
C-- Q.N. FINAL PARTONS
      ITU=1
      IF(RNCJ(0).GT.RTU) ITU=2
      IFLAF1=IFLA1
      IFLAF2=IFLA2
      LF=1
      IF(IM.NE.3.AND.IM.NE.5.AND.IM.NE.10) GO TO 260
      IF(KPRHEV.EQ.1) THEN
        LF=KFRFLA
        GO TO 230
      ENDIF
      RW=RNCJ(ITU)*WTDS(ITU)
      WCHT=0.
      DO 221 L=1,6
      LF=L
      WCHT=WCHT+WGV(ITU,L)
      IF(RW.LT.WCHT) GO TO 230
221   CONTINUE
230   IF(IM.EQ.5) GO TO 250
      IF(IM.EQ.10) GO TO 255
C-- QB-Q ANNIHILATION CHANNEL
      IF(LF.EQ.1) GO TO 260
      IF(LF.GT.2) GO TO 233
      IR=INT(2.*RNCJ(LF))+1
      I3=SIGN(MOD(ABS(IFLA1)-1+IR,3)+1,IFLA1)
      IFLAF1=I3
      IFLAF2=-IFLAF1
      GO TO 260
233   IF(LF.GT.3) GO TO 234
      IFLAF1=LGLU
      IFLAF2=LGLU
      GO TO 260
234   IFLAF1=LF
      IFLAF2=-IFLAF1
      GO TO 260
C-- G-G ANNIHILATION CHANNEL
250   IF(LF.GT.1) GO TO 251
      IFLAF1=LGLU
      IFLAF2=LGLU
      GO TO 260
251   IF(LF.GT.3) GO TO 252
      IR=INT(3*RNCJ(LF))+1
      IFLAF1=IR
      IFLAF2=-IFLAF1
      GO TO 260
252   IFLAF1=LF
      IFLAF2=-IFLAF1
      GO TO 260
C-- QHB-QH ANNIHILATION CHANNEL
255   IF(LF.EQ.1) GO TO 260
      IF(LF.GT.2) GO TO 256
      IR=INT(3.*RNCJ(LF))+1
      IFLAF1=IR
      IFLAF2=-IFLAF1
      GO TO 260
256   IF(LF.GT.3) GO TO 257
      IFLAF1=LGLU
      IFLAF2=LGLU
      GO TO 260
257   IFLAF1=LF
      IFLAF2=-IFLAF1
C
260   CONTINUE
C
      IF(IFAIL.EQ.1) GO TO 215
C-- PARTONS HAVE INTERACTED
      NHEP=0
C
      CALL CJTEVO(IACT1,IACT2)
      CALL CJHARD(IACT1,IACT2,IFLAF1,IFLAF2,IM,LF,SHAT,TV(ITU))
      IF(IFAIL.EQ.1) GO TO 215
      IF(IFLGHV.EQ.1) GO TO 210
C
      NHEPF=NHEP
      IF(NOFRGM.EQ.0) CALL CJHADR(1,NHEPF,1)
      IF(IFAIL.EQ.1) GO TO 215
C
      DO 31 I=1,NHEP
      DO 31 J=1,4
31    VHEP(J,I)=0.
C
C-- DECAY UNSTABLE PARTICLES
      IF(NODECY.EQ.0) CALL CJDECY(1,0)
      IF(IFAIL.EQ.1) GO TO 215
      IF(IFLGHV.EQ.1) GO TO 210
      NEVGEN=NEVGEN+1
      MNHEP=MAX(MNHEP,NHEP)
C
      IF(KREPET.EQ.0) THEN
        IF(NOUNST.EQ.1) CALL CJSTAB
        IF(NOPDG.EQ.0) CALL CJPDG(1)
        IF(NHEP+1.GT.NMXHEP) GO TO 500
        PHEP(1,NHEP+1)=PTHARD
        MNHEP=MAX(MNHEP,NHEP+1)
        NEVHEP=NEVHEP+1
        ACCEPT=.TRUE.
        CALL CJUSER(ACCEPT)
        IF(ACCEPT) NHARD=NHARD+1
        IF(.NOT.ACCEPT) NEVHEP=NEVHEP-1
        IF(NEVHEP.NE.NACCPL) THEN
          IF(NEVHEP.LE.NDUMP.AND.
     &    (MOD(NEVHEP,NJUMP).EQ.1.OR.NJUMP.EQ.1))
     *    CALL CJDUMP
          NACCPL=NEVHEP
        ENDIF
      ELSE
        CALL CJREPT
      ENDIF
      IF(NEVHEP.GE.NLEAVE) RETURN
      IFIREF=1
      GO TO 210
C
C-- BAD EVENT
215   CONTINUE
      WGT=WGT+WGALQ(IALQ,IPACH,2)
      IF(IFLGHV.EQ.1) NHVREJ=NHVREJ-1
      GO TO 210
C
200   CONTINUE
      IF(IFIRE.EQ.0) GO TO 1
      IF(IFIREF.EQ.0) GO TO 700
      RETURN
C
C-- MINBIAS EVENTS
300   CONTINUE
      IFAIL=0
      IFLGHV=0
      QSQ=0.
      PTHARD=0.
      IF(KPTWGT.EQ.1) WEIGHT=(1.-PROPTW)/(1.-FRAGEH)
      NHEP=0
      IF(NOFRGM.EQ.0) CALL CJHADR(0,0,1)
      IF(IFAIL.EQ.1) GO TO 300
C
      DO 32 I=1,NHEP
      DO 32 J=1,4
32    VHEP(J,I)=0.
C
C-- DECAY UNSTABLE PARTICLES
      IF(NODECY.EQ.0) CALL CJDECY(1,0)
      IF(IFAIL.EQ.1) GO TO 300
      IF(IFLGHV.EQ.1) GO TO 300
      NEVGEN=NEVGEN+1
C
      MNHEP=MAX(MNHEP,NHEP)
      IF(NOUNST.EQ.1) CALL CJSTAB
      IF(NOPDG.EQ.0) CALL CJPDG(1)
      IF(NHEP+1.GT.NMXHEP) GO TO 500
      PHEP(1,NHEP+1)=0.
      MNHEP=MAX(MNHEP,NHEP+1)
      NEVHEP=NEVHEP+1
      ACCEPT=.TRUE.
      CALL CJUSER(ACCEPT)
      IF(.NOT.ACCEPT) NEVHEP=NEVHEP-1
      IF(NEVHEP.NE.NACCPL) THEN
        IF(NEVHEP.LE.NDUMP.AND.
     &  (MOD(NEVHEP,NJUMP).EQ.1.OR.NJUMP.EQ.1))
     *  CALL CJDUMP
        NACCPL=NEVHEP
      ENDIF
      IF(NEVHEP.GE.NLEAVE) RETURN
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS ',I10
     1//1X,'***IN SUBROUTINE CJHGEV'
     1//1X,'***EVENT NO. = ',I10
     3//1X,'***INCREASE NMXHEP'
     4//1X,'***JOB IS ABORTED'
     5)
      STOP
C
      END
CDECK  ID>, CJHPRE.
      SUBROUTINE CJHPRE
C     *****************
C-- HANDLES PREPARATION OF TABLES FOR HARD PT GENERATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION WGIN(2),ICHA(2,3),IWGV(3)
      DATA ICALL/0/
C
      IF(ICALL.GT.0) RETURN
      ICALL=1
C-- INITIALIZATION
      NEVHEP=0
C-- SET DEFAULT SIGINL - FROM LOG(S)**2 FIT TO PBAR-P DATA AT ISR
C-- (NUCL.PHYS. B262 (1985) 689) AND 900 GEV (UA5, Z.PHYSIK C 32
C-- (1986) 153) - IN MILLIBARN
      IF(SIGINL.EQ.0) SIGINL=36.66
     *+(50.3-36.66)*(LOG(ECM)**2-LOG(62.3)**2)
     */(LOG(900.)**2-LOG(62.3)**2)
C
      S=ECM**2
      ICHA(1,1)=IVAL
      ICHA(2,1)=IVAL
      ICHA(1,2)=LGLU
      ICHA(2,2)=IVAL
      ICHA(1,3)=LGLU
      ICHA(2,3)=LGLU
      IWGV(1)=1
      IWGV(2)=4
      IWGV(3)=5
      JBOOK=1
      IF(KPRHEV.EQ.1) PTCUT=MAX(REAL(QZEVOL*1.01),REAL(QMAS(KFRFLA)))
      PTI=MAX(PTCUT,PTMIN)
      ALQZM=LOG((QZEVOL/ALAMBD)**2)
      ALQI=(LOG(PTI**2)-ALLAM2)/ALQZM
      IF(ALQI.LT.1.) GO TO 500
      ALQF=(LOG(PTMAX**2)-ALLAM2)/ALQZM
      YF=LOG(ALQF)
      DALQ=(ALQF-ALQI)/FLOAT(NALQ)
      Q2VECT(1)=PTI**2
      DO 5 I=1,NALQ
      I1=I+1
5     Q2VECT(I1)=EXP((ALQI+DALQ*FLOAT(I))*ALQZM+ALLAM2)
C-- FORCED PT GENERATION -- INITIALIZATION
      IF(PTMIN.GT.PTMAX) GO TO 700
      ZSLW=EMCUT/ECM
      ZSUP=1.-ZSLW
      XMIN=(3.*PTCUT**2-5.*PT2INT)/S
      IF(KPRHEV.EQ.1) XMIN=MAX(XMIN,(THRFLA(KFRFLA)-5.*PT2INT)/S)
      IF(KPRHEV.EQ.2) XMIN=MAX(XMIN,(AM2HEV(KFRFLA)-5.*PT2INT)/S)
      IF(PTMIN.GT.PTCUT) XMIN=MAX(XMIN,(3.*PTMIN**2-5.*PT2INT)/S)
C
      CALL CJQCDS
      CALL CJQCDT
C
C-- MAIN LOOP
C   ---------
      DO 6 J1=1,3
      DO 6 J2=1,5
      DO 6 J3=1,NALQ
6     WGALQ(J3,J2,J1)=0.
      DO 7 N=1,NALQ
7     WGALQT(N)=0.
C
      CALL CJTLFT(TEXEC)
      IF(NSIGMA.EQ.0) NSIGMA=NLEAVE*100
      IF(NPRESH.EQ.0) NPRESH=NLEAVE
      NCASCX=100000
      NCASC=0
      NSHOWS=0
      DO 105 NC=1,NCASCX
      NCASC=NCASC+1
      DO 100 ICH=1,3
C-- ICH=1 Q-Q OR Q-QB, 2 Q-G, 3 G-G
C-- IWG=1 Q-Q OR Q-QB DIFFERENT FLAVORS, 2 Q-Q SAME FLAVORS, 3 Q-QB
C--     SAME FLAVORS, 4 Q-G, 5 G-G
      CALL CJGEXM(ICHA(1,ICH),IFLAIN(1),XIN(1),PXIN(1),PYIN(1),WGIN(1))
      IF(KPBAR.EQ.1.AND.ICHA(1,ICH).NE.LGLU) IFLAIN(1)=-IFLAIN(1)
      CALL CJGEXM(ICHA(2,ICH),IFLAIN(2),XIN(2),PXIN(2),PYIN(2),WGIN(2))
      IF(XIN(1)*XIN(2).LE.XMIN) GO TO 100
      NSHOWS=NSHOWS+1
      IWG=IWGV(ICH)
      IF(ICH.EQ.1) THEN
        IF(IFLAIN(1).EQ.IFLAIN(2)) IWG=IWG+1
        IF(IFLAIN(1).EQ.(-IFLAIN(2))) IWG=IWG+2
      ENDIF
      WGTCAS=WGIN(1)*WGIN(2)
      IF(ICH.EQ.2) WGTCAS=WGTCAS*2.
      CALL CJMATC(IWG,WGTCAS)
100   CONTINUE
      CALL CJTLFT(TLEFT)
      IF(TLEFT.LT.TLEAVE) GO TO 101
      IF(NKINPT.GE.NSIGMA.AND.NSHOWS.GE.NPRESH) GO TO 101
105   CONTINUE
101   NSIGMA=NKINPT
      NPRESH=NSHOWS
      IF(NCASC.EQ.0) GO TO 800
      CALL CJTLFT(TPRETB)
      TPRETB=TEXEC-TPRETB
C
C-- DETERMINE PROBABILITY OF MINBIAS EVENTS
      WGTOR=0.
      WGTHD1=0.
      DO 102 IW=1,5
      DO 102 N=1,NALQ
      WGTHD1=WGTHD1+WGALQ(N,IW,1)
      IF(WGALQ(N,IW,3).LT.1.E-30) GO TO 102
      WGTOR=WGTOR+WGALQ(N,IW,1)/WGALQ(N,IW,2)*WGALQ(N,IW,3)
102   CONTINUE
      FRHARD=WGTHD1/FLOAT(NCASC)*UNITS/SIGINL*FACTK
      IF(FRHARD.GT..3) GO TO 900
      PROPT=WGTOR/FLOAT(NCASC)*UNITS/SIGINL*FACTK
      PROPTW=PROPT/(1.-(FRHARD-PROPT))
      IF(PROPTW.GE.1.) GO TO 600
      IF(KPTWGT.EQ.0) FRAGEH=PROPTW
C-- FORCED GENERATION -- HARD X-SECTION OVER FORCED PT RANGE
      IF(PTMIN.GT.PTCUT) THEN
        SIGHRD=0.
        DO 104 IW=1,5
        DO 104 N=1,NALQ
104     SIGHRD=SIGHRD+WGALQ(N,IW,1)
        SIGHRD=SIGHRD/FLOAT(NCASC)*UNITS*FACTK
      ENDIF
C-- MODIFY PT TABLE WITH (OPTIONAL) PTWGCJ(PT)
      IF(KPTWGT.EQ.0) GO TO 110
      WGTPT=0.
      DO 103 N=1,NALQ
      WPT=PTWGCJ(Q2VECT(N))
      DO 103 IW=1,5
      WGALQ(N,IW,1)=WGALQ(N,IW,1)*WPT
      WGALQ(N,IW,2)=WGALQ(N,IW,2)*WPT
      WGALQ(N,IW,3)=WGALQ(N,IW,3)*WPT
103   WGTPT=WGTPT+WGALQ(N,IW,1)
      PTWGTM=WGTPT/WGTHD1
110   CONTINUE
C-- COMPLETE TABLES
      DO 120 N=1,NALQ
      WGALQT(N)=0.
      DO 120 IW=1,5
      IF(WGALQ(N,IW,3).LT.1.E-30) GO TO 120
      WGALQ3=WGALQ(N,IW,1)
      WGALQ(N,IW,2)=WGALQ(N,IW,1)/WGALQ(N,IW,2)
      WGALQ(N,IW,1)=WGALQ(N,IW,2)*WGALQ(N,IW,3)
      WGALQ(N,IW,3)=WGALQ3
      WGALQT(N)=WGALQT(N)+WGALQ(N,IW,1)
120   CONTINUE
      DO 130 N=1,NALQ
      IF(WGALQT(N).LT.1.E-30) GO TO 130
      WGALQ(N,1,1)=WGALQ(N,1,1)/WGALQT(N)
      DO 131 IW=2,5
      WGALQ(N,IW,1)=WGALQ(N,IW,1)/WGALQT(N)+WGALQ(N,IW-1,1)
131   CONTINUE
130   CONTINUE
      DO 180 N=2,NALQ
180   WGALQT(N)=WGALQT(N)+WGALQT(N-1)
      ZERO=0.
      IF(WGALQT(NALQ).EQ.ZERO) GO TO 920
      DO 190 N=1,NALQ
190   WGALQT(N)=WGALQT(N)/WGALQT(NALQ)
      WGALQ3=0.
      DO 200 IW=1,5
      DO 200 N=1,NALQ
      WGALQ3=WGALQ3+WGALQ(N,IW,3)
200   CONTINUE
      DO 201 IW=1,5
      DO 201 N=1,NALQ
201   WGALQ(N,IW,3)=WGALQ(N,IW,3)/WGALQ3
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,511) PTCUT,QZEVOL
511   FORMAT(//' *** PTCUT =',E11.4,' GEV < QZEVOL ='
     1,E11.4,' GEV (INITIAL SCALE FOR PARTON DENSITY EVOLUTION)'
     2//' *** SET PTCUTOFF GREATER THAN QZEVOL'
     3//' *** OR DECREASE QZEVOL ')
      STOP
600   WRITE(ITLIS,601) FRAGEH
601   FORMAT(//' ***QCD X-SECTION TOO HIGH'
     *//' ***PROBABILITY FOR HARD EVENTS EXCEEDS 1 (= ',E10.3,')'
     *//' ***INCREASE PTCUT (AND ALSO CHECK VALUE OF SIGINL)')
      STOP
700   WRITE(ITLIS,711) PTMIN,PTMAX
711   FORMAT(//' ***INPUT PTMIN (= ',E10.3,') > PTMAX (',E10.3,')'
     *//1X,' ***DECREASE PTMIN')
      STOP
800   WRITE(ITLIS,801)
801   FORMAT(//' ***TOO LITTLE TIME FOR EXECUTION'
     * //' ***INCREASE TIME PARAMETER ON JOB CARD')
      STOP
900   WRITE(ITLIS,911) FRHARD,PTCUT
911   FORMAT(//' ***QCD X-SECTION = ',E12.4,'*SIGTINEL'
     *//' ***TOO HIGH (MAX LIMIT SET AT 0.3*SIGTINEL)'
     *//' ***INCREASE PTCUT (AT PRESENT PTCUT = ',E12.3,')' )
      STOP
920   WRITE(ITLIS,931)
931   FORMAT(//' ***NO ENTRIES IN PRETABULATION'
     */' ***INCREASE NUMBER OF REQUESTED EVENTS OR NSIGMA'
     &,' OR NPRESH')
      STOP
      END
CDECK  ID>, CJIALL.
      SUBROUTINE CJIALL
C     *****************
C-- GLOBAL INITIALIZATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      EXTERNAL F2XXCJ
      DATA ICALL/0/
C
      IF(ICALL.GT.0) RETURN
      ICALL=1
C
C-- CONSTANTS (/CJQCDC/)
      PI=4.*ATAN(1.)
      PI2=2.*PI
      COLORS=3.
      CA=COLORS
      CF=(COLORS**2-1.)/(2.*COLORS)
C
C-- /CJIDRU/
      CALL CJIDGE
C-- FIRST HEPEVT RECORD
      NEVHEP=-1
      ISTHEP(1)=0
      IDHEP(1)=0
      JMOHEP(1,1)=IDG(1)
      JMOHEP(2,1)=IDG(2)
      JDAHEP(1,1)=IDVER
      JDAHEP(2,1)=IDATVR
      NHEP=1
      DO 32 L=1,4
      VHEP(L,1)=0.
32    PHEP(L,1)=0.
      PHEP(5,1)=0.
C
C-- READ PARTICLE TABLE
      CALL CJRTAB
C-- SET Z, W ID AND DECAY CHANNEL PARAMETERS
      IDZ=90
      IDWP=80
      IDWM=-80
      KINTZ=INIDCJ(IDZ)
      KINTWP=INIDCJ(IDWP)
      KINTWM=INIDCJ(IDWM)
      ND=IDB(KINTZ)-1
45    ND=ND+1
      IF(ND.GT.NDECT) GO TO 46
      IF(MOTHER(ND).NE.IDZ) GO TO 47
      GO TO 45
47    ND=ND-1
46    NDECZ=ND-(IDB(KINTZ)-1)
      NDECZ1=NDECZ+1
      ND=IDB(KINTWP)-1
48    ND=ND+1
      IF(ND.GT.NDECT) GO TO 49
      IF(MOTHER(ND).NE.IDWP) GO TO 50
      GO TO 48
50    ND=ND-1
49    NDECW=ND-(IDB(KINTWP)-1)
      IFL=0
      IF(NDECZ.GT.MXDCZ) THEN
        WRITE(ITLIS,54) NDECZ,MXDCZ
54      FORMAT(/' ***TOTAL NUMBER OF Z DECAY CHANNELS IS '
     &  ,I3,' > MXDCZ =',I3
     &  /' ***INCREASE MXDCZ, SET MXDCZ1=MXDCZ+1'
     &  /' ***JOB WILL BE ABORTED'
     &  )
        IFL=1
      ENDIF
      IF(NDECW.GT.MXDCW) THEN
        WRITE(ITLIS,53) NDECW,MXDCW
53      FORMAT(/' ***TOTAL NUMBER OF W DECAY CHANNELS IS '
     &  ,I3,' > MXDCW =',I3
     &  /' ***INCREASE MXDCW'
     &  /' ***JOB WILL BE ABORTED'
     &  )
        IFL=1
      ENDIF
      IF(IFL.NE.0) STOP
C
C-- CROSS SECTION UNITS IN MILLIBARN
      UNITS=(.19733)**2*10.
C
C-- QED ALPHA
      ALFQED=1./137.03604
C
C-- READ INPUT COMMANDS
      IFL=0
      CALL CJRINP(IFL)
C
      IF(TOPMAS.LT.0.) TOPMAS=QMAS(6)
C
      IF(ZMASS.GT.0.) THEN
        PMAS(KINTZ)=ZMASS
      ELSE
        ZMASS=PMAS(KINTZ)
      ENDIF
      IF(WMASS.GT.0.) THEN
        PMAS(KINTWP)=WMASS
        PMAS(KINTWM)=PMAS(KINTWP)
      ELSE
        WMASS=PMAS(KINTWP)
      ENDIF
C
      IF(ZGAMMA.GT.0.) THEN
        WIDTHP(KINTZ)=ZGAMMA
      ELSE
        ZGAMMA=WIDTHP(KINTZ)
      ENDIF
      IF(WGAMMA.GT.0.) THEN
        WIDTHP(KINTWP)=WGAMMA
        WIDTHP(KINTWM)=WIDTHP(KINTWP)
      ELSE
        WGAMMA=WIDTHP(KINTWP)
      ENDIF
C
C-- Minimum values of QCD cutoff parameters for timelike evolution
C-- compatile with hadronization
      QZFLHM(1)=MAX(AMASCJ(110),AMASCJ(120))
      QZFLHM(2)=QZFLHM(1)
      QZFLHM(3)=MAX(AMASCJ(130),AMASCJ(230))
      QZFLHM(4)=MAX(AMASCJ(140),AMASCJ(240))
      QZFLHM(5)=MAX(AMASCJ(150),AMASCJ(250))
      QZFLHM(6)=QMAS(6)
      QZFLHM(LGLU)=QZFLHM(1)
      DO 2 L=1,6
2     QZFLHM(L)=QZFLHM(L)*1.001
      QZFLHM(LGLU)=QZFLHM(LGLU)*1.001
C
      QZM=0.
      DO 3 L=1,3
      IF(QZFLHM(L).GT.QZM) QZM=QZFLHM(L)
3     CONTINUE
      IF(QZ.LT.QZM) THEN
        WRITE(ITLIS,4) QZ,QZM
4     FORMAT(/' ***WARNING: INPUT CUTJET = ',E13.5,' TOO LOW'
     &,' FOR FRAGMENTATION OF LIGHT PARTONS'
     &/' ***IT HAS BEEN RESET TO MINIMUM ALLOWED VALUE = ',E13.5/)
        QZ=QZM
      ENDIF
C
C-- MAX FLAVOR POSSIBLE
      DO 11 L=1,6
11    IF(2.*QZFLHM(L).LT.ECM) NFLAVX=L
C
C-- ELIMINATE TOO MASSIVE Z/W DECAY MODES
C-- INCREASE NFLAV TO ACCOMODATE FORCING
      IF(IEVTYP.GE.2.AND.IEVTYP.LE.5) THEN
        ETOTX=ECM*.9
        IF(IEVTYP.EQ.3) THEN
          IDF=IDWP
        ELSEIF(IEVTYP.EQ.2.OR.IEVTYP.EQ.4) THEN
          IDF=IDZ
        ELSEIF(IEVTYP.EQ.5) THEN
          IDF=IDZ
        ENDIF
        NFB=0
        NF=0
40      NF=NF+1
        IF(NF.GT.NFORCE) GO TO 42
        IF(KFORCE(1,NF).NE.IDF) GO TO 40
        TOTMAS=0.
        NFLADX=0
        DO 41 LD=2,NDFORC
        IDA=ABS(KFORCE(LD,NF))
        IF(IDA.NE.0.AND.IDA.LT.10) NFLADX=MAX(NFLADX,IDA)
41      TOTMAS=TOTMAS+AMASCJ(KFORCE(LD,NF))
        IF(TOTMAS.GT.ETOTX.OR.NFLADX.GT.NFLAVX) THEN
          IF(NF.EQ.NFORCE) THEN
            NFORCE=NFORCE-1
          ELSE
            DO 43 NF2=NF+1,NFORCE
            DO 43 LD=1,NDFORC
            KFORCE(LD,NF2-1)=KFORCE(LD,NF2)
43          CONTINUE
            NFORCE=NFORCE-1
          ENDIF
        ELSE
          NFB=NFB+1
          NFLAV=MAX(NFLAV,NFLADX)
        ENDIF
        GO TO 40
42      CONTINUE
        IF(NFB.EQ.0) THEN
          WRITE(ITLIS,44)
44        FORMAT(
     *    /' ***ZWFORCE OR EEFORCE INPUT INCOMPATIBLE WITH '
     *    ,'MASS CONSTRAINTS'
     *    /' ***JOB WILL BE ABORTED')
          STOP
        ENDIF
      ENDIF
C
C-- Z0 BRANCHING FRACTIONS
      XW=SIN2W
      RHO4=4.*(QMAS(6)/ZMASS)**2
      AQ(1)=-2./3.*XW+.25
      BQ(1)=.25
      AQ(2)=1./3.*XW-.25
      BQ(2)=-.25
      AL(1)=XW-.25
      BL(1)=-.25
      AL(2)=.25
      BL(2)=.25
C
C-- BR FACTORS FOR W DECAY (MASS DEPENDENT FACTORS NOT INCLUDED)
      CB2=COSCAB**2
      SB2=1.-CB2
      DO 25 ICH=IDB(KINTWP),IDB(KINTWP)+NDECW-1
      ICHW=ICH-IDB(KINTWP)+1
      ID1=KDP(1,ICH)
      IF(ABS(ID1).GT.6) THEN
        BRW(ICHW)=1.
      ELSE
        ID2=KDP(2,ICH)
        IF(IPDGCJ(ID1)+IPDGCJ(ID2).EQ.1) THEN
          BRW(ICHW)=3.*CB2
        ELSE
          BRW(ICHW)=3.*SB2
        ENDIF
      ENDIF
25    CONTINUE
C
C-- IDENTIFY CHANNEL Z --> T + TB
      DO 26 ICH=IDB(KINTZ),IDB(KINTZ)+NDECZ-1
26    IF(ABS(KDP(1,ICH)).EQ.6.AND.ABS(KDP(2,ICH)).EQ.6
     & .AND.KDP(3,ICH).EQ.0) IZTOP=ICH
C
C-- SET NFLAVS, NFLAVT
      NFLAVT=NFLAV
      NFLAVS=NFLAV
      IF(KPRHEV.EQ.1) NFLAVS=KFRFLA-1
C
C-- ALLAM2 (/CJQCDC/)
      ALLAM2=LOG(ALAMBD**2)
C
C-- PTMAX (TWOJET)
      IF(PTMAX.EQ.0.) PTMAX=ECM*.45
C
C-- SET MXSPE
      MXSPE=MXINQ-1
C
C-- MASS BOUNDS IN INITIAL EVOLUTION AND FINAL CHANNEL THRESHOLDS
      DO 31 L=1,6
      AMHEV(L)=QMAS(L)
      AM2HEV(L)=(QMAS(L))**2
31    THRFLA(L)=4.*AM2HEV(L)
C
C-- CALCULATE AGLU FOR NA3 STRUCTURE FUNCTIONS
      IF(IEVTYP.NE.5.AND.IFUNCX.EQ.0) THEN
        ZERO=0.
        ONE=1.
        EPSI=.001
        AGLU=1.-ASIMCJ(ZERO,ONE,EPSI,M,2,F2XXCJ)
      ENDIF
C
C-- SET UNDEFINED MASSES FOR HADRONS
      DO 30 NP=1,352
      IDA=ABS(IDEXCJ(NP))
      IF(IDA.GT.100.AND.PMAS(NP).EQ.0.) THEN
        IP=IDA/1000
        JP=MOD(IDA/100,10)
        KP=MOD(IDA/10,10)
        JSPIN=MOD(IDA,10)
        PMAS(NP)=QMAS(JP)+QMAS(KP)-.03+.04*JSPIN
        IF(IP.NE.0) PMAS(NP)=PMAS(NP)+QMAS(IP)
      ENDIF
30    CONTINUE
C
C-- HANDLE FORCING COMMANDS
      CALL CJFRCE(IFL)
C
C-- ABNORMAL EXIT
300   IF(IFL.EQ.1) THEN
        WRITE(ITLIS,301)
301     FORMAT(/' ***JOB ABORT')
        STOP
      ENDIF
      RETURN
      END
CDECK  ID>, CJIDGE.
      SUBROUTINE CJIDGE
C     *****************
C          CALL SYSTEM DATE AND TIME ROUTINES (NON-STANDARD) TO SET UP
C          RUN IDENTIFICATION:
C          IDVER=100*VERSN     (INTEGER COJETS VERSION NUMBER)
C          IDG(1)=YYMMDD       (INTEGER YEAR-MONTH-DAY)
C          IDG(2)=HHMMSS       (INTEGER HOUR-MINUTE-SECOND)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      CHARACTER*8 BF
      DIMENSION ND(2),NT(2)
      DIMENSION NDV(6),NTV(6)
C          DEFAULT RUN ID IS ZERO.
      IDG(1)=0
      IDG(2)=0
      RETURN
1     FORMAT(2A4)
      END
CDECK  ID>, CJJETC.
      SUBROUTINE CJJETC(IPD,NPI,NPF)
C     ******************************
C-- ROTATE AND BOOST JET SO AS TO CORRECT FOR PT UNBALANCE AND ENERGY
C-- NON-CONSERVATION -- JET IS LEFT ALONG Z AXIS
C-- IPD = FRAGMENTING PARTON
C-- NPI, NPF = INITIAL AND FINAL FRAGMENTATION PARTICLES
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION PJTOT(5)
C
      EBEG=PHEP(4,IPD)
      DO 1 J=1,4
1     PJTOT(J)=0.
      DO 2 I=NPI,NPF
      IF(ISTHEP(I).NE.1) GO TO 2
      DO 3 J=1,4
3     PJTOT(J)=PJTOT(J)+PHEP(J,I)
2     CONTINUE
      PMTSQ=PJTOT(1)**2+PJTOT(2)**2
      PMT=SQRT(PMTSQ)
      PMSQ=PMTSQ+PJTOT(3)**2
      PM=SQRT(PMSQ)
      PJTOT(5)=SQRT(ABS(PJTOT(4)**2-PMSQ))
C
      IF(PJTOT(5).GE.EBEG) THEN
        WRITE(ITLIS,10) IDHEP(IPD),EBEG,PJTOT(5)
10      FORMAT(//1X,'***ERROR IN CJJETC'
     &  /1X,'***INVARIANT MASS OF JET LARGER THAN INPUT JET ENERGY'
     &  /1X,'***ABNORMAL ERROR: THIS IS A WARNING'
     &  /1X,'***JET IS LEFT UNCORRECTED, EXECUTION CONTINUES'
     &  /1X,'***FRAGMENTING PARTON: ',I8
     &  /1X,'***INPUT PARTON ENERGY: ',E12.5
     &  /1X,'***INVARIANT MASS OF JET: ',E12.5
     &  /1X,'***PARTICLES IN JET:'
     &  )
        DO 11 I=NPI,NPF
11      WRITE(ITLIS,12) I,IDHEP(I),(PHEP(L,I),L=1,5)
12    FORMAT(1X,2I10,5E10.3)
        RETURN
      ENDIF
C
      ZERO=0.
      IF(PM.NE.ZERO) THEN
        CT=PJTOT(3)/PM
        ST=PMT/PM
      ELSE
        CT=1.
        ST=0.
      ENDIF
      IF(PMT.NE.ZERO) THEN
        CP=PJTOT(1)/PMT
        SP=PJTOT(2)/PMT
      ELSE
        CP=1.
        SP=0.
      ENDIF
      EXPB=(EBEG+SQRT(ABS(EBEG**2-PJTOT(5)**2)))/(PJTOT(4)+PM)
      COSHB=.5*(EXPB+1./EXPB)
      SINHB=.5*(EXPB-1./EXPB)
C
      DO 5 I=NPI,NPF
C-- INVERSE ROTATION 1-2 AXES -- JET IN 1-3 PLANE
      P1=        PHEP(1,I)*CP+PHEP(2,I)*SP
      PHEP(2,I)=-PHEP(1,I)*SP+PHEP(2,I)*CP
      PHEP(1,I)=P1
C-- INVERSE ROTATION 1-3 AXES -- JET ALONG 3RD AXIS
      P3=        PHEP(3,I)*CT+PHEP(1,I)*ST
      PHEP(1,I)=-PHEP(3,I)*ST+PHEP(1,I)*CT
      PHEP(3,I)=P3
C-- BACK TO ORIGINAL AZIMUTHAL REFERENCE FRAME
      P1=        PHEP(1,I)*CP-PHEP(2,I)*SP
      PHEP(2,I)= PHEP(1,I)*SP+PHEP(2,I)*CP
      PHEP(1,I)=P1
C-- BOOST ALONG 3RD AXIS -- TOTAL ENERGY = INPUT ENERGY
      E=        PHEP(4,I)*COSHB+PHEP(3,I)*SINHB
      PHEP(3,I)=PHEP(4,I)*SINHB+PHEP(3,I)*COSHB
      PHEP(4,I)=E
5     CONTINUE
C
      RETURN
      END
CDECK  ID>, CJJETG.
      SUBROUTINE CJJETG(IPD)
C     **********************
C-- JET GENERATION ROUTINE OF FIELD-FEYNMAN TYPE.
C-- ENSURES FORWARD MOTION, ENERGY CONSERVATION, PT BALANCE.
C-- INCLUDES INPUT AND GENERATED DIQUARKS
C-- ENFORCE JET MASS BOUNDS (FOR E+E-)
C-- IPD = FRAGMENTING PARTON
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJEEMS/FLOG(NMXHEP),TOTLOG
     &,NHEPC1,NHEPC2
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      PARAMETER (NG=100)
      DIMENSION TG(NG),TGV(NG,3)
      DIMENSION PC(3)
      INTEGER LG(NG),LGV(NG,3),LWORKG(NG)
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 50
C-- PREPARE TABLES FOR HEAVY QUARK FRAGMENTATION
      ICALL=1
      PIG=4.*ATAN(1.)
      PIG2=2.*PIG
      ONE=1.
      F2D3=2./3.
      F1D3=1./3.
      DG=1./FLOAT(NG)
      HDG=DG/2.
      DO 10 JG=1,3
      TTG=0.
      DO 11 IG=1,NG
      XG=DG*FLOAT(IG-1)+HDG
      TG(IG)=1./(XG*(1.-1./XG-EPSPET(JG)/(1.-XG))**2)
11    TTG=TTG+TG(IG)
      DO 12 IG=1,NG
12    TG(IG)=TG(IG)/TTG
      CALL CJALIA(LG,TG,LWORKG,NG)
      DO 13 IG=1,NG
      TGV(IG,JG)=TG(IG)
13    LGV(IG,JG)=LG(IG)
10    CONTINUE
50    CONTINUE
C
      IF(ISTHEP(IPD).NE.1) RETURN
C
C-- CREATE FRAGMENTATION JET ENTRY (IDISA=IDPDG=93) IN PARTICLE STREAM
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 500
      IPFRAG=NHEP
      ISTHEP(IPD)=2
      JDAHEP(1,IPD)=IPFRAG
      JDAHEP(2,IPD)=IPFRAG
      ISTHEP(IPFRAG)=2
      IDHEP(IPFRAG)=93
      JMOHEP(1,IPFRAG)=IPD
      JMOHEP(2,IPFRAG)=0
      DO 51 L=1,4
      VHEP(L,IPFRAG)=0.
51    PHEP(L,IPFRAG)=0.
      PHEP(5,IPFRAG)=0.
C
C-- INITIAL SETTINGS
C-- (JET IS ROTATED ALONG THE INITIAL PARTON DIRECTION AT THE END)
      NHEPL=NHEP+1
      EBEG=PHEP(4,IPD)
      IFLBEG=IDHEP(IPD)
      IREPET=0
C
C-- QUARK/GLUON SET-UP
      IF(IFLBEG.EQ.IDGL) THEN
        SIGMA=SIGMAG
        AX=FRALOG(1)
        BX=FRALOG(2)
        CX=FRALOG(3)
        DX=FRALOG(4)
        EX=FRALOG(5)
        IFL1=(INT(3*RNCJ(0))+1)*(-1)**(INT(2*RNCJ(1))+1)
        IFLG=IFL1
        EBEG1=EBEG/2.
        EBEG2=EBEG-EBEG1
        EBEG=EBEG1
      ELSE
        SIGMA=SIGMAQ
        AX=FRALOQ(1)
        BX=FRALOQ(2)
        CX=FRALOQ(3)
        DX=FRALOQ(4)
        EX=FRALOQ(5)
        IFL1=IFLBEG
      ENDIF
      SIGMA2=SIGMA**2
C
C-- INITIAL VALUES, PT FOR FIRST CONSTITUENT IN CASCADE
      I=NHEP
70    CONTINUE
      KEYBAR=1
      KEYSTR=1
      KEYSPN=1
      KEYETA=1
      EMAX=EBEG
      IQHI1=ABS(MOD(IFL1,10))
      QMSBEG=QMAS(IQHI1)
      W=EBEG+SQRT(ABS(EBEG**2-QMSBEG**2))
      IF(IEVTYP.EQ.5) THEN
        QMX=(FRAMAS(1)+FRAMAS(2)*ECM)*FLOG(IPD)/TOTLOG
      ELSE
        QMX=ECM
      ENDIF
      QMX=MIN(QMX,EBEG)
      QMX2=QMX**2
      WPLUS=0.
      WMINUS=0.
C
C-- FLAVOR FOR NEXT CONSTITUENT
100   I=I+1
      IF(I.GT.NMXHEP) GO TO 500
      IQHI1=ABS(MOD(IFL1,10))
C
C-- ITERATE IF KINEMATIC BOUNDS ARE NOT SATISFIED AND TAKE ACTION
      ITER=0
200   ITER=ITER+1
      IF(ITER.GT.10) THEN
        IF(I.GT.NHEPL) THEN
C-- TERMINATE
          I=I-1
          IFL2=-IFL1
        ELSE
C-- REDUCE TO ONE PARTICLE JET
C-- (PHEP(5,I) etc. defined by last iteration)
          PHEP(1,I)=0.
          PHEP(2,I)=0.
          PHEP(3,I)=SQRT(MAX(0.,REAL(EBEG**2-PHEP(5,I)**2)))
          PHEP(4,I)=SQRT(PHEP(5,I)**2+PHEP(3,I)**2)
          X=1.
        ENDIF
        GO TO 400
      ELSEIF(ITER.GT.1) THEN
C-- IF CURRENT PARTICLE TURNS IS TOO ENERGETIC OR BACKWARD MOVING,
C-- THEN PROGRESSIVELY SUPPRESS GENERATION OF MASSIVE PARTICLES
        IF(ABS(IFL2).GT.10) THEN
          KEYBAR=0
        ELSEIF(KEYSPN.GT.0) THEN
          KEYSPN=0
          KEYBAR=0
        ELSE
          KEYSTR=0
          KEYETA=0
        ENDIF
      ENDIF
C
C-- 2ND CONSTITUENT CAN BE DIQUARK IF 1ST IS NOT
      IF(ABS(IFL1).LT.10) THEN
        IF(KEYBAR.GT.0.AND.RNCJ(0).LT.PBARYO) THEN
C-- QUARK + DIQUARK
          CALL CJBARY(IFL1,0,KEYSTR,KEYSPN,IDOUT,IFL2)
        ELSE
C-- QUARK + ANTIQUARK
201       CONTINUE
          IFL2=SIGN(1+INT(RNCJ(0)*(2.+PSQRK*KEYSTR)),-IFL1)
          CALL CJMESO(IFL1,IFL2,KEYSPN,KEYETA,IDOUT)
          IF(RNCJ(1.).GT.(1.-AMASCJ(IDOUT)/EMAX)**2) GO TO 201
        ENDIF
      ELSE
C-- DIQUARK + QUARK
        CALL CJBARY(0,IFL1,KEYSTR,KEYSPN,IDOUT,IFL2)
      ENDIF
C
C-- PARTICLE NON-KINEMATIC PARAMETERS
      IDHEP(I)=IDOUT
      JMOHEP(1,I)=IPFRAG
      JMOHEP(2,I)=0
      JDAHEP(1,I)=0
      JDAHEP(2,I)=0
      ISTHEP(I)=1
C
C-- PARTICLE MASS: CHECK BOUNDS
      PHEP(5,I)=AMAWCJ(IDHEP(I))
      IF(PHEP(5,I).GE.QMX-SQRT(WPLUS*WMINUS)) GO TO 200
      IF(PHEP(5,I).GE.EMAX) GO TO 200
      IF(WMINUS.NE.0.) THEN
        SQWW=SQRT(WPLUS*WMINUS)
        T1=(QMX2-WPLUS*WMINUS-PHEP(5,I)**2)/(2.*WMINUS)
        T2=SQRT((QMX2-(SQWW+PHEP(5,I))**2)
     &     *(QMX2-(SQWW-PHEP(5,I))**2))/(2.*WMINUS)
        EPPM=T1-T2
        EPPX=T1+T2
        IF(EPPM.LT.PHEP(5,I)) EPPM=PHEP(5,I)
      ELSE
        EPPM=PHEP(5,I)
        EPPX=W
      ENDIF
      IF(EPPM.GE.EPPX) GO TO 200
C
C-- X GENERATION
      XMIN=EPPM/W
      XMAX=EPPX/W
      IF(XMIN.LE.0.) XMIN=0.
      IF(XMAX.GT.1.) XMAX=1.
      IF(XMIN.GE.XMAX) GO TO 200
C
      IF(IQHI1.LE.3) THEN
C-- "SCALING" FUNCTION FOR LIGHT CONSTITUENTS
        DEX=DX
        IF(ABS(IFL1).GE.10.OR.ABS(IFL2).GE.10) DEX=DX+EX
301     X=1.-RNCJ(0.)**(1./(AX+1.))
        FEXP=CX + EXP(-BX*PHEP(5,I)*(1./(X*W+DEX)-1./(W+DEX)))
        IF(RNCJ(1.).GT.FEXP) GO TO 301
      ELSE
C-- FRAGMENTATION A LA PETERSON ET AL. FOR HEAVY QUARKS
        X=RNCJ(0)
        JG=IQHI1-3
        IXG=X*FLOAT(NG)+1.
        IF(RNCJ(0.).GT.TGV(IXG,JG)) IXG=LGV(IXG,JG)
        X=DG*FLOAT(IXG-1)+HDG
      ENDIF
      X=XMIN+(XMAX-XMIN)*X
      EPP=X*W
C
C-- PT OF GENERATED HADRON
      PTPSQX=(QMX2-WPLUS*WMINUS-WMINUS*EPP)/(1.+WPLUS/EPP)
     &       -PHEP(5,I)**2
      IF(PTPSQX.LE.0.) GO TO 200
      RM=EXP(-PTPSQX/SIGMA2)
      ITPT=0
300   ITPT=ITPT+1
      IF(ITPT.GT.20) GO TO 200
      PTPSQ=SIGMA2*ABS(LOG(RM+(1.-RM)*RNCJ(0)))
      IF(PTPSQ.GT.PTPSQX) GO TO 300
      PTP=SQRT(PTPSQ)
      PHIP=PIG2*RNCJ(0)
      PHEP(1,I)=PTP*COS(PHIP)
      PHEP(2,I)=PTP*SIN(PHIP)
C
C-- COMPLETE KINEMATICS - CHECK FORWARD MOTION
      PMTSQ=PHEP(1,I)**2+PHEP(2,I)**2+PHEP(5,I)**2
      PHEP(3,I)=(EPP-PMTSQ/EPP)/2.
      IF(PHEP(3,I).LT.0.) GO TO 300
      PHEP(4,I)=(EPP+PMTSQ/EPP)/2.
      IF(PHEP(4,I).GE.EMAX) GO TO 300
C
C-- PREPARE FOR NEXT STEP
      IFL1=-IFL2
      WPLUS=WPLUS+(PHEP(4,I)+PHEP(3,I))
      WMINUS=WMINUS+(PHEP(4,I)-PHEP(3,I))
      W=(1.-X)*W
      EMAX=EMAX-PHEP(4,I)
C-- IF ENOUGH ENERGY LEFT AND JET MASS BOUND NOT REACHED,
C-- KEEP ON CASCADING
      IF(EMAX.GT.EFGMIN.AND.WPLUS*WMINUS.LT.QMX2.AND.W.GT.0.)
     &GO TO 100
C
C-- EXIT
400   CONTINUE
      IF(IEVTYP.EQ.5) CALL CJBASK(1,-IFL2)
      IF(IFLBEG.EQ.IDGL.AND.IREPET.EQ.0) THEN
        IREPET=1
        IFL1=-IFLG
        EBEG=EBEG2
        GO TO 70
      ENDIF
      NHEP=I
      JDAHEP(1,IPFRAG)=NHEPL
      JDAHEP(2,IPFRAG)=NHEP
C-- CORRECT FOR ENERGY, PT BALANCE
      NHEPF=NHEP
      CALL CJJETC(IPD,NHEPL,NHEPF)
C-- ROTATE JET ALONG INITIAL PARTON DIRECTION
      PJTSQ=PHEP(1,IPD)**2+PHEP(2,IPD)**2
      PJT=SQRT(PJTSQ)
      PJSQ=PJTSQ+PHEP(3,IPD)**2
      PJ=SQRT(PJSQ)
      ZERO=0.
      IF(PJ.NE.ZERO) THEN
        CT=PHEP(3,IPD)/PJ
        ST=PJT/PJ
      ELSE
        CT=1.
        ST=0.
      ENDIF
      IF(PJT.NE.ZERO) THEN
        CP=PHEP(1,IPD)/PJT
        SP=PHEP(2,IPD)/PJT
      ELSE
        CP=1.
        SP=0.
      ENDIF
      NHEPF=NHEP
      CALL CJROTP(NHEPL,NHEPF,CT,ST,CP,SP)
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS ',I10
     1//1X,'***IN SUBROUTINE CJJETG'
     1//1X,'***EVENT NO. = ',I10
     3//1X,'***INCREASE NMXHEP'
     5)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJJETQ.
      SUBROUTINE CJJETQ(IPD)
C     **********************
C-- DEVELOPS TIMELIKE CASCADE OF PARTONS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MXCUEV=50,MXCUEJ=50)
      COMMON/CJCUES/CUEV(MXCUEV,10,2),CUE(MXCUEJ,6)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      DIMENSION PROB(7),VZLW(7),VZUP(7)
C- IZFAST = 1, FASTEST SECONDARY LEG IN A BRANCHING DEVELOPS FIRST (THE
C-    OTHER ONE DEVELOPS IN LEFTOVER PHASE-SPACE) -- OTHERWISE FIRST
C-    LEG TO DEVELOP IS CHOSEN AT RANDOM (DIFFERENCES IN THE RESULTS
C-    ARE MINIMAL)
      DATA IZFAST/0/
      DATA NJTQCD/0/
C
      IF(NJTQCD.EQ.0) CALL CJQCDT
      NJTQCD=NJTQCD+1
C
      IF(KYEVOL.GT.1) RETURN
      IF(ISTHEP(IPD).NE.1) RETURN
      IFLA=IDHEP(IPD)
      IF(IFLA.EQ.IDGL) IFLA=LGLU
      MFLA=ABS(IFLA)
      PSQ=PHEP(5,IPD)**2
      IF(PSQ.LE.QTHRSQ(MFLA)) RETURN
C
C-- RESET
      NHEPI=NHEP+1
      NCUE=0
C
C-- SETTING PARAMETERS OF INITIAL LEG
C-- (SHOWER ROTATED ALONG INITIAL PARTON DIRECTION BEFORE EXITING)
      PX=0.
      PY=0.
      EPP=PHEP(4,IPD)
     &    +SQRT(PHEP(1,IPD)**2+PHEP(2,IPD)**2+PHEP(3,IPD)**2)
      JETP=IPD
C
C-- BRANCHING LOOP
C   ==============
C
C-- GENERATE Z
C   ----------
200   CONTINUE
      MFLA=ABS(IFLA)
      IF(IFLA.EQ.LGLU) GO TO 210
C-- QUARK BRANCHING
      CALL CJZLIM(PSQ,QZFLSQ(MFLA),QZFLSQ(LGLU),ZLW,ZUP,FLAG)
      CALL CJZGEN(1,ZLW,ZUP,FLAG,Z)
C-- CORRECT 1ST BRANCHING TO REPRODUCE O(ALPHAS) MATRIX ELEMENT
C-- RMATRX=X1**2+X2**2
      IF(IEVTYP.EQ.5.AND.NHEP.LT.NHEPI) THEN
        PCM=PHEP(3,IPD)
        E1=PHEP(4,IPD)
        E2=SQRT(PCM**2+QZFLSQ(ABS(IDHEP(IPD))))
        RMATRX=(E1**2+E2**2)/(.5*(E1+E2))**2
        IF(2.*RNCJ(0.).GT.RMATRX)  RETURN
      ENDIF
      IFLA1=IFLA
      IFLA2=LGLU
      IF(IFLA.GT.0) GO TO 201
      Z=1.-Z
      IFLA1=LGLU
      IFLA2=IFLA
201   CONTINUE
      GO TO 250
C
C-- GLUON BRANCHING - GENERATE DECAY CHANNEL
210   CONTINUE
      CALL CJZLMS(PSQ,QZFLSQ(LGLU),ZLW,ZUP,FLAG)
      PROGLT=PAPICJ(2,ZUP)-PAPICJ(2,ZLW)
      PROB(1)=PROGLT
      VZLW(1)=ZLW
      VZUP(1)=ZUP
      DO 211 L=1,NFLAVT
      CALL CJZLMS(PSQ,QZFLSQ(L),ZLW,ZUP,FLAG)
      IF(FLAG.GT.0.) GO TO 212
      PROQQB=PAPICJ(3,ZUP)-PAPICJ(3,ZLW)
      PROB(L+1)=PROB(L)+PROQQB
      VZLW(L+1)=ZLW
      VZUP(L+1)=ZUP
      GO TO 211
212   PROB(L+1)=PROB(L)
211   CONTINUE
      RR=RNCJ(0.)
      DO 213 L=1,NFLAVT+1
      LOUT=L
      IF(RR.LT.PROB(L)/PROB(NFLAVT+1)) GO TO 214
213   CONTINUE
214   LFLA=LOUT-1
      FLAG=-1.
      IF(LFLA.GT.0) GO TO 230
C
C-- GLUON BRANCHES INTO TWO GLUONS
      ZLW=VZLW(1)
      ZUP=VZUP(1)
      CALL CJZGEN(2,ZLW,ZUP,FLAG,Z)
      IFLA1=LGLU
      IFLA2=LGLU
      GO TO 250
C
C-- GLUON BRANCHES INTO Q-QB
230   ZLW=VZLW(LFLA+1)
      ZUP=VZUP(LFLA+1)
      CALL CJZGEN(3,ZLW,ZUP,FLAG,Z)
      IFLA1=-LFLA
      IFLA2=LFLA
      GO TO 250
C
C-- GENERATE MASSES OF SECONDARIES
C   ------------------------------
250   CONTINUE
      MFLA1=ABS(IFLA1)
      MFLA2=ABS(IFLA2)
      IF(IZFAST.EQ.1) GO TO 251
      IF(RNCJ(0.).GT..5) GO TO 270
      GO TO 280
251   IF(Z.GT..5) GO TO 270
      GO TO 280
270   CONTINUE
      XP1SQ=Z*(PSQ-QZFLSQ(MFLA2)/(1.-Z))
      CALL CJQTGE(MFLA1,XP1SQ,P1SQ,IGO1)
      XP2SQ=(1.-Z)*(PSQ-P1SQ/Z)
      CALL CJQTGE(MFLA2,XP2SQ,P2SQ,IGO2)
      GO TO 290
280   CONTINUE
      XP2SQ=(1.-Z)*(PSQ-QZFLSQ(MFLA1)/Z)
      CALL CJQTGE(MFLA2,XP2SQ,P2SQ,IGO2)
      XP1SQ=Z*(PSQ-P2SQ/(1.-Z))
      CALL CJQTGE(MFLA1,XP1SQ,P1SQ,IGO1)
      GO TO 290
C
C-- SET TRANSVERSE VARIABLES
C   ------------------------
290   CONTINUE
      PTRSQ=Z*(1.-Z)*(PSQ-P1SQ/Z-P2SQ/(1.-Z))
      PTR=SQRT(PTRSQ)
      IF(KYEVOL.GE.1) PTR=0.
      PHI=2.*PI*RNCJ(0.)
      PTRX=PTR*COS(PHI)
      PTRY=PTR*SIN(PHI)
      P1X=Z*PX+PTRX
      P1Y=Z*PY+PTRY
      P2X=(1.-Z)*PX-PTRX
      P2Y=(1.-Z)*PY-PTRY
C
C-- SET LONGITUDINAL VARIABLES
C   --------------------------
      EPP1=EPP*Z
      EPP2=EPP*(1.-Z)
C
C-- BOOK SECONDARIES, DECIDE WHICH IS NEXT TO CASCADE
C   -------------------------------------------------
C--  EXTRA PHEP INFO
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 560
      PHEP(1,NHEP)=P1X
      PHEP(2,NHEP)=P1Y
      APSQ=P1SQ
      AMT2=P1X**2+P1Y**2+APSQ
      EPM1=AMT2/EPP1
      PHEP(3,NHEP)=.5*(EPP1-EPM1)
      PHEP(4,NHEP)=.5*(EPP1+EPM1)
      PHEP(5,NHEP)=SQRT(APSQ)
      IDHEP(NHEP)=JDENCJ(IFLA1)
      JMOHEP(1,NHEP)=JETP
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      ISTHEP(NHEP)=1
C
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 560
      PHEP(1,NHEP)=P2X
      PHEP(2,NHEP)=P2Y
      APSQ=P2SQ
      AMT2=P2X**2+P2Y**2+APSQ
      EPM2=AMT2/EPP2
      PHEP(3,NHEP)=.5*(EPP2-EPM2)
      PHEP(4,NHEP)=.5*(EPP2+EPM2)
      PHEP(5,NHEP)=SQRT(APSQ)
      IDHEP(NHEP)=JDENCJ(IFLA2)
      JMOHEP(1,NHEP)=JETP
      JMOHEP(2,NHEP)=0
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      ISTHEP(NHEP)=1
C
      JDAHEP(1,JETP)=NHEP-1
      JDAHEP(2,JETP)=NHEP
      ISTHEP(JETP)=2
      IF(IGO1.EQ.0) GO TO 291
C-- 1ST KEEPS CASCADING
      IFLA=IFLA1
      PSQ=P1SQ
      EPP=EPP1
      PX=P1X
      PY=P1Y
      JETP=NHEP-1
C-- 2ND IN CUE FOR FUTURE CASCADING
      IF(IGO2.NE.0) THEN
        NCUE=NCUE+1
        MNCUEJ=MAX(MNCUEJ,NCUE)
        IF(NCUE.GT.MXCUEJ) GO TO 550
        CUE(NCUE,1)=IFLA2
        CUE(NCUE,2)=P2SQ
        CUE(NCUE,3)=EPP2
        CUE(NCUE,4)=P2X
        CUE(NCUE,5)=P2Y
        CUE(NCUE,6)=NHEP
      ENDIF
      GO TO 200
C
C-- 1ST STOPS
291   CONTINUE
      IF(IGO2.EQ.0) GO TO 293
C-- 2ND KEEPS CASCADING
      IFLA=IFLA2
      PSQ=P2SQ
      EPP=EPP2
      PX=P2X
      PY=P2Y
      JETP=NHEP
      GO TO 200
C
C-- 2ND STOPS. LAST IN CUE PICKED UP FOR CASCADING
C-- IF NO CUE LEFT, ROTATION ALONG INITIAL PARTON DIRECTION AND EXIT
293   CONTINUE
      IF(NCUE.GT.0) THEN
        IFLA=CUE(NCUE,1)
        PSQ =CUE(NCUE,2)
        EPP =CUE(NCUE,3)
        PX  =CUE(NCUE,4)
        PY  =CUE(NCUE,5)
        JETP=CUE(NCUE,6)
        NCUE=NCUE-1
        GO TO 200
      ELSE
        PJT2=PHEP(1,IPD)**2+PHEP(2,IPD)**2
        IF(PJT2.GT.0.) THEN
          PJT=SQRT(PJT2)
          CP=PHEP(1,IPD)/PJT
          SP=PHEP(2,IPD)/PJT
        ELSE
          CP=1.
          SP=0.
        ENDIF
        PJM2=PJT2+PHEP(3,IPD)**2
        IF(PJM2.GT.0) THEN
          PJM=SQRT(PJM2)
          CT=PHEP(3,IPD)/PJM
          ST=SQRT(ABS(1.-CT**2))
        ELSE
          CT=1.
          ST=0.
        ENDIF
        NHEPF=NHEP
        CALL CJROTP(NHEPI,NHEPF,CT,ST,CP,SP)
        RETURN
      ENDIF
C
C-- ABNORMAL EXIT
550   WRITE(ITLIS,551) MXCUEJ,NEVGEN+1,NJTQCD
551   FORMAT(1H1,'***NUMBER OF PARTONS IN CUE (/CJCUES/) EXCEEDS',I10
     &//1X,'***IN SUBROUTINE CJJETQ'
     1//1X,'***EVENT NO. =',I10
     1//1X,'***NO. OF CJJETQ CALLS',I10
     3//1X,'***INCREASE MXCUEJ'
     4//1X,'***JOB ABORT')
      STOP
560   WRITE(ITLIS,561) NMXHEP
561   FORMAT(5(/),1X,'***NHEP EXCEEDS',I10,' (CJJETQ)'
     1//1X,'***INCREASE NMXHEP'
     &//1X,'***JOB ABORT')
      STOP
      END
CDECK  ID>, CJKNO.
      SUBROUTINE CJKNO(W,PMB)
C     ***********************
C--  HELPS GENERATING SPECTATOR JETS
C--  TOTAL MULTIPLICITY DISTRIBUTION IN SPECTATOR JETS SAMPLED ACCORDING
C--  TO KNO (DE GROOT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPMB/CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR(9)
      REAL CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION TMV(NMXHEP),YV(NMXHEP)
      DIMENSION TBPAIR(9)
      INTEGER IFTB(2,9)
      DIMENSION VPM(7)
      DIMENSION PMB(4),SUM(2),A(4),V(4),V1(4)
      DATA VPM/.120,.150,.175,.196,.207,.211,.217/
      DATA IFTB/110,110,120,-120,130,-130,230,-230,1120,-1120
     &,1220,-1220,2130,-2130,1130,-1130,2230,-2230/
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 10
      ICALL=1
      IDPIP=120
      IDPI0=110
      IDETA=220
      PIPMAS=AMASCJ(IDPIP)
      PI0MAS=AMASCJ(IDPI0)
      TBPAIR(1)=RPAIR(1)
      DO 11 M=2,9
11    TBPAIR(M)=RPAIR(M)+TBPAIR(M-1)
      DO 12 M=1,9
12    TBPAIR(M)=TBPAIR(M)/TBPAIR(9)
10    CONTINUE
C
      NH=NHEP
      IF(W.LT.1.) GO TO 100
C--  MEAN MULTIPLICITY
      WN=W*1.6
      ALB=2.50+.28*LOG(WN)+.53*(LOG(WN))**2
      AVN=2.2*ALB
      AVN=AVN*FMULMB
30    CONTINUE
      NMUL=AVN*FRAMCJ(0)
      IF(RNCJ(0).GT..5) NMUL=NMUL+1
      IF(NH+NMUL.GT.NMXHEP) GO TO 500
      IF(NMUL.LE.1) GO TO 100
C
C
C--  GENERATE MULTIPLICITY AND PARTICLE Q.N.
      NCHMB=0
      IT=0
29    CONTINUE
      IT=IT+1
      IF(IT.GT.10) GO TO 30
      I=NH
      IODD=1
      IF((-1)**NMUL.GT.0) IODD=0
      IF(IODD.EQ.0) GO TO 21
      I=I+1
      IDHEP(I)=IDPI0
21    NPAIR=NMUL/2
      DO 20 N2=1,NPAIR
      RR=RNCJ(N2)
      IF(RR.GE.TBPAIR(1)) GO TO 26
      IF(IODD.EQ.0) GO TO 27
      IF(RNCJ(N2+3).LT.1./(2.*FLOAT(NMUL))) GO TO 26
27    IPAIR=1
      GO TO 23
26    CONTINUE
      DO 22 M=2,9
      IPAIR=M
      IF(RR.LT.TBPAIR(M)) GO TO 23
22    CONTINUE
23    IDHEP(I+1)=IFTB(1,IPAIR)
      IDHEP(I+2)=IFTB(2,IPAIR)
      IF(IPAIR.NE.1) GO TO 24
      IF(RNCJ(N2+1).LT.RETPIZ) IDHEP(I+1)=IDETA
      IF(RNCJ(N2+2).LT.RETPIZ) IDHEP(I+2)=IDETA
24    I=I+2
20    CONTINUE
      NHEP=NH+NMUL
      NH1=NH+1
      TMASS=0.
      DO 25 I=NH1,NHEP
      IF(INT(CHRGCJ(IDHEP(I))).NE.0) NCHMB=NCHMB+1
      PHEP(5,I)=AMAWCJ(IDHEP(I))
25    TMASS=TMASS+PHEP(5,I)
      IF(TMASS.GT.W) GO TO 29
C
C--  MEAN  PT  RISING WITH MULTIPLICITY
      RISIG=FLOAT(NCHMB)/15.+1.
      ISIG=RISIG
      IF(ISIG.LE.6) THEN
        DELSG=RISIG-FLOAT(ISIG)
        SIGMAB=(VPM(ISIG)*(1.-DELSG)+VPM(ISIG+1)*DELSG)*FPTMB
      ELSE
        SIGMAB=VPM(7)*FPTMB
      ENDIF
C
C-- GENERATE PT'S
      DO 17 I=NH1,NHEP
      PERPM=XEXPCJ(PHEP(5,I)/SIGMAB)*SIGMAB
      TM2=PERPM**2
      PT2=TM2-PHEP(5,I)**2
      PT2=MAX(REAL(PT2),0.)
      PT=SQRT(PT2)
      PHI=PI2*RNCJ(0)
      PHEP(1,I)=PT*COS(PHI)
      PHEP(2,I)=PT*SIN(PHI)
17    CONTINUE
C
C--  PT BALANCE WITH PREVIOUS HADRONS
      DO 81 J=1,2
      SUM(J)=-PMB(J)
      DO 82 I=NH1,NHEP
82    SUM(J)=SUM(J)+PHEP(J,I)
      SUM(J)=SUM(J)/FLOAT(NHEP-NH1+1)
      DO 83 I=NH1,NHEP
83    PHEP(J,I)=PHEP(J,I)-SUM(J)
81    CONTINUE
C
C--  TRANSVERSE MASSES
      TMTOT=0.
      DO 85 I=NH1,NHEP
      TMV(I)=SQRT(PHEP(5,I)**2+PHEP(1,I)**2+PHEP(2,I)**2)
85    TMTOT=TMTOT+TMV(I)
      EW=SQRT(W**2+PMB(1)**2+PMB(2)**2)
      IF(TMTOT.GT.EW) GO TO 30
C
C--  GENERATE Y'S
      YMAX=LOG(W/PIPMAS)
      ETOT=0.
      DO 86 I=NH1,NHEP
      YV(I)=YMAX*RNCJ(0)
      EY=EXP(YV(I))
      PHEP(4,I)=.5*TMV(I)*(EY+1./EY)
      ETOT=ETOT+PHEP(4,I)
86    CONTINUE
C
C--  CORRECT  Y'S  ITERATIVELY SO AS TO GET RIGHT TOTAL ENERGY  W
      IF(ETOT.LT.EW) GO TO 18
C
      IMOVE=-1
      YFACT=.5
      YFACTX=1.
      INIT=1
      GO TO 19
C
18    IMOVE=1
      YFACT=2.
      YFACTM=1.
      INIT=2
19    CONTINUE
C
50    CONTINUE
      ETOT=0.
      DO 51 I=NH1,NHEP
      Y=YV(I)*YFACT
      EY=EXP(Y)
      PHEP(4,I)=.5*TMV(I)*(EY+1./EY)
      ETOT=ETOT+PHEP(4,I)
51    CONTINUE
      IF(ABS(ETOT-EW)/EW.LT..01) GO TO 70
      IMOVE=-1
      IF(ETOT.LT.EW) IMOVE=1
C
      IF(INIT.EQ.3) GO TO 60
      IF(INIT.EQ.2) GO TO 55
C
      IF(IMOVE.LT.0) GO TO 52
      YFACTM=YFACT
      YFACT=.5*(YFACTM+YFACTX)
      INIT=3
      GO TO 50
52    YFACT=YFACT*.5
      GO TO 50
C
55    IF(IMOVE.GT.0) GO TO 56
      YFACTX=YFACT
      YFACT=.5*(YFACTM+YFACTX)
      INIT=3
      GO TO 50
56    YFACT=YFACT*2.
      GO TO 50
C
60    IF(IMOVE.GT.0) YFACTM=YFACT
      IF(IMOVE.LT.0) YFACTX=YFACT
      YFACT=.5*(YFACTM+YFACTX)
      GO TO 50
C
70    CONTINUE
C
C--  LONGITUDINAL MOMENTUM BALANCE
      PLONG=0.
      DO 72 I=NH1,NHEP
      PHEP(3,I)=0.
      PAR3=PHEP(4,I)**2-TMV(I)**2
      IF(PAR3.GT.0.) PHEP(3,I)=SQRT(PAR3)
72    TMV(I)=1.
      DO 73 IT=NH1,NHEP
      PLX=0.
      DO 74 I=NH1,NHEP
      IF(TMV(I).LT.0.) GO TO 74
      IF(PHEP(3,I).LT.PLX) GO TO 74
      IX=I
      PLX=PHEP(3,I)
74    CONTINUE
      TMV(IX)=-1.
      IF(IT.GT.NH1) GO TO 75
      IF(RNCJ(IT).GT..5) PHEP(3,IX)=-PHEP(3,IX)
75    CONTINUE
      IF(PLONG.GT.0.) PHEP(3,IX)=-PHEP(3,IX)
      PLONG=PLONG+PHEP(3,IX)
73    CONTINUE
C--  CALL CORRECTIVE ROUTINE
      NHEPF=NHEP
      CALL CJP4CR(EW,PMB,NH1,NHEPF,IFLAG)
      IF(IFLAG.NE.0) GO TO 30
      GO TO 200
C
C--  VERY SMALL  W ,  EMIT TWO  PI0
100   CONTINUE
      SIGMAB=VPM(1)*FPTMB
      EW=SQRT(W**2+PMB(1)**2+PMB(2)**2)
      A(1)=PMB(1)
      A(2)=PMB(2)
      A(3)=0.
      A(4)=EW
      NH1=NH+1
      NHEP=NH+2
      IF(NHEP.GT.NMXHEP) GO TO 500
101   PERPM=XEXPCJ(PI0MAS/SIGMAB)*SIGMAB
      PL2=W**2*.25-PERPM**2
      IF(PL2.LT.0.) GO TO 101
      PL=SQRT(PL2)
      PT2=PERPM**2-PI0MAS**2
      PT=SQRT(PT2)
      PHI=PI2*RNCJ(0)
      NEW=1
      DO 78 I=1,2
      FSIGN=1.
      IF(I.EQ.1) FSIGN=-1.
      V(1)=PT*COS(PHI)*FSIGN
      V(2)=PT*SIN(PHI)*FSIGN
      V(3)=PL*FSIGN
      V(4)=SQRT(PI0MAS**2+PT2+PL2)
      CALL CJLOR4(A,V,V1,NEW)
      NEW=0
      DO 79 J=1,4
79    PHEP(J,NH+I)=V1(J)
      PHEP(5,NH+I)=PI0MAS
      IDHEP(NH+I)=IDPI0
78    CONTINUE
C
C--  FINAL SETTINGS
200   CONTINUE
      DO 201 I=NH1,NHEP
      JMOHEP(1,I)=0
      JMOHEP(2,I)=0
      JDAHEP(1,I)=0
      JDAHEP(2,I)=0
      ISTHEP(I)=1
201   CONTINUE
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'NO. OF PARTICLES DURING CJKNO CALL EXCEEDS ',I10
     1//1X,'EVENT NO. =  ',I10
     3//1X,'INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJLOR4.
      SUBROUTINE CJLOR4(PMB,V1,V2,NEW)
C     ********************************
C-- LORENTZ BOOST OF V1 TO V2 BY PMB
C-- IF NEW=0 BOOST PARAMETERS FROM  PREVIOUS CALL ARE USED
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION PMB(4),V1(4),V2(4),BETA(3),GABETA(3)
      IF(NEW.EQ.0) GO TO 10
      DO 1 J=1,3
1     BETA(J)=PMB(J)/PMB(4)
      GA=1./SQRT(1.-BETA(1)**2-BETA(2)**2-BETA(3)**2)
      DO 4 J=1,3
4     GABETA(J)=GA*BETA(J)
      GA1GA=GA/(1.+GA)
10    CONTINUE
      BEP=BETA(1)*V1(1)+BETA(2)*V1(2)+BETA(3)*V1(3)
      DO 2 J=1,3
2     V2(J)=V1(J)+(GA1GA*BEP+V1(4))*GABETA(J)
3     V2(4)=GA*(V1(4)+BEP)
      RETURN
      END
CDECK  ID>, CJLORL.
      SUBROUTINE CJLORL(ACT1,ACT2,NHEPI,NHEPF)
C     ****************************************
C-- LORENTZ TRANSFORM WITH INITIAL FRAME THE CMS OF ACT1 + ACT2
C-- WITH ACT1 DIRECTED ALONG Z AXIS, AND FINAL FRAME THAT WHERE
C-- ACT1 AND ACT2 HAVE THE INPUT VALUES
C-- NHEPI,NHEPF = INITIAL AND FINAL PARTICLES IN STREAM TO BOOST
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION ACT1(4),ACT2(4)
      DIMENSION A(4),B(4),AM(4),BCM(4)
      DIMENSION PIN(4),POUT(4)
C
      IF(NHEPI.GT.NHEPF) RETURN
C
C-- FIND LORENTZ TRANSFORM
C-- SUM AND DIFFRENCE
      DO 2 J=1,4
      A(J)=ACT1(J)+ACT2(J)
      B(J)=ACT1(J)-ACT2(J)
2     CONTINUE
C-- BOOST B TO CMS
      DO 1 J=1,3
1     AM(J)=-A(J)
      AM(4)=A(4)
      CALL CJLOR4(AM,B,BCM,1)
C-- FIND B DIRECTION IN CMS
      BCMT2=BCM(1)**2+BCM(2)**2
      IF(BCMT2.LT.1.E-30) GO TO 200
      BCMA2=BCMT2+BCM(3)**2
      BCMA=SQRT(BCMA2)
      CTH=BCM(3)/BCMA
      STH=SQRT(ABS(1.-CTH**2))
      BCMT=SQRT(BCMT2)
      CPH=BCM(1)/BCMT
      SPH=BCM(2)/BCMT
C
C-- BACK TRAIL
C-- PARTICLE ROTATION IN C.M. SYSTEM
      CALL CJROTP(NHEPI,NHEPF,CTH,STH,CPH,SPH)
C-- PARTICLE LORENTZ BOOST PROPER
200   CONTINUE
      NEW=1
      DO 201 I=NHEPI,NHEPF
      DO 202 J=1,4
202   PIN(J)=PHEP(J,I)
      CALL CJLOR4(A,PIN,POUT,NEW)
      NEW=0
      DO 203 J=1,4
203   PHEP(J,I)=POUT(J)
201   CONTINUE
      RETURN
      END
CDECK  ID>, CJMATC.
      SUBROUTINE CJMATC(IWG,WGTCAS)
C     *****************************
C-- MATCHES PARTONS FROM INITIAL CASCADES (CALLED BY CJHPRE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION WFDSDT(6)
C
C-- PREENTERING
      DO 10 IB=1,2
      IBEAM=IB
      NBOOK(IBEAM)=0
      ICANC(IBEAM)=0
      ZERO=0.
      CALL CJQSGE(IFLAIN(IB),ZERO,Y,QSQ)
      XM=(PXIN(IB)**2+PYIN(IB)**2)/(S*XIN(IB))
      CALL CJBOOK(IFLAIN(IB),0,XM,Y,XIN(IB),PXIN(IB),PYIN(IB),ZERO,YF)
10    CONTINUE
C
C-- MAIN LOOP
      DO 200 M=1,NALQ
      IF(NBOOK(1).EQ.0.OR.NBOOK(2).EQ.0) RETURN
      YQSQ=LOG(ALQI+DALQ*FLOAT(M))
      NENTR=0
      DO 100 IB=1,2
      IBEAM=IB
      NB=NBOOK(IB)
      ICANC(IB)=0
C-- EVOLVE ONE  M  STEP FURTHER
      DO 90 J=1,NB
      Y=PARACT(J,4,IB)
      IF(Y.GT.YQSQ) GO TO 90
      JX=J
      IBACK(IBEAM)=0
      CALL CJEVOL(JX,YQSQ)
      MNBOOK=MAX(MNBOOK,NBOOK(IB))
90    CONTINUE
      IF(ICANC(IB).EQ.0) GO TO 100
C-- CANCEL DECAYED PARTONS
      ICN=ICANC(IB)
      DO 91 I=1,ICN
      IN=NBKCNC(I,IB)
91    PARACT(IN,1,IB)=0.
      JC=0
      NB=NBOOK(IB)
      DO 92 J=1,NB
      JZ=PARACT(J,1,IB)
      IF(JZ.EQ.0) GO TO 92
      JC=JC+1
      DO 93 L=1,9
93    PARACT(JC,L,IB)=PARACT(J,L,IB)
92    CONTINUE
      NBOOK(IB)=NBOOK(IB)-ICN
      ICANC(IB)=0
100   CONTINUE
      NB1=NBOOK(1)
      NB2=NBOOK(2)
      IF(NB1.EQ.0.OR.NB2.EQ.0) RETURN
C-- CALCULATION OF HARD WEIGHT AND BOOKING
      DO 111 J2=1,NB2
111   NENT2(J2)=0
      DO 110 J1=1,NB1
      IF(YQSQ.LT.PARACT(J1,8,1)) GO TO 110
      IF(YQSQ.GT.PARACT(J1,9,1)) GO TO 110
      IFLA1=PARACT(J1,1,1)
      XM1=PARACT(J1,3,1)
      XP1=PARACT(J1,5,1)
      PX1=PARACT(J1,6,1)
      PY1=PARACT(J1,7,1)
      MFLA1=ABS(IFLA1)
      NENT1=0
      DO 120 J2=1,NB2
      IF(YQSQ.LT.PARACT(J2,8,2)) GO TO 120
      IF(YQSQ.GT.PARACT(J2,9,2)) GO TO 120
      IFLA2=PARACT(J2,1,2)
      XM2=PARACT(J2,3,2)
      XP2=PARACT(J2,5,2)
      PX2=PARACT(J2,6,2)
      PY2=PARACT(J2,7,2)
      MFLA2=ABS(IFLA2)
C
      SHAT=(XP1*XP2+XM1*XM2)*S-2.*(PX1*PX2+PY1*PY2)
      IF(SHAT.LT.3.*Q2VECT(M)) GO TO 120
      IF(KPRHEV.EQ.1) THEN
        IF(SHAT.LE.THRFLA(KFRFLA)) GO TO 120
      ELSEIF(KPRHEV.EQ.2) THEN
        IF(SHAT.LE.AM2HEV(KFRFLA)) GO TO 120
      ENDIF
      NENT1=1
      NENT2(J2)=1
C
      IM=IMATCH(MFLA1,MFLA2)
      IF(IM.EQ.2.AND.IFLA1*IFLA2.LT.0) IM=3
      IF(IM.EQ.9.AND.IFLA1*IFLA2.LT.0) IM=10
      IF(KPRHEV.EQ.1) THEN
        IF(IM.NE.3.AND.IM.NE.5.AND.IM.NE.10) GO TO 120
      ELSEIF(KPRHEV.EQ.2) THEN
        IF(IM.LE.5) GO TO 120
        IF(MFLA1.NE.KFRFLA.AND.MFLA2.NE.KFRFLA) GO TO 120
      ENDIF
C
      DSQ1=SQRT(ABS(1.-4./(1.+SHAT/Q2VECT(M))))
      T1=-SHAT*.5*(1.+DSQ1)
      U1=-SHAT*.5*(1.-DSQ1)
      IF(SHAT.GE.3.*Q2VECT(M+1)) THEN
        DSQ2=SQRT(ABS(1.-4./(1.+SHAT/Q2VECT(M+1))))
        T2=-SHAT*.5*(1.+DSQ2)
        U2=-SHAT*.5*(1.-DSQ2)
      ELSE
        T2=-SHAT*.5
        U2=T2
      ENDIF
      T=T1+(T2-T1)*RNCJ(0.)
      U=-SHAT-T
      CALL CJDSDT(IM,MFLA1,MFLA2,SHAT,T,U,WT1,WFDSDT)
      CALL CJDSDT(IM,MFLA1,MFLA2,SHAT,U,T,WT2,WFDSDT)
      NKINPT=NKINPT+2
      QSQ=2.*SHAT*T*U/(SHAT**2+T**2+U**2)
      DQSQ=Q2VECT(M+1)-Q2VECT(M)
      WGT=(WT1+WT2)
     1 *PI/(BALPHS*LOG(QSQ/ALAMBD**2)*SHAT)**2
     2 *(T2-T1)
      WGT=WGT*WGTCAS
      WGALQ(M,IWG,1)=WGALQ(M,IWG,1)+WGT
      WGALQ(M,IWG,2)=WGALQ(M,IWG,2)+WGTCAS*DQSQ
      NENTR=1
120   CONTINUE
C-- KEEP RECORD OF PARTONS TOO SOFT TO PASS THRESHOLD
      IF(NENT1.LE.0) THEN
        ICANC(1)=ICANC(1)+1
        NBKCNC(ICANC(1),1)=J1
      ENDIF
110   CONTINUE
C
      DO 130 J2=1,NB2
      IF(NENT2(J2).GT.0) GO TO 130
      ICANC(2)=ICANC(2)+1
      NBKCNC(ICANC(2),2)=J2
130   CONTINUE
      IF(NENTR.GT.0) WGALQ(M,IWG,3)=WGALQ(M,IWG,3)+WGTCAS*DQSQ
C-- CANCEL PARTONS TOO SOFT TO PASS THRESHOLD
      DO 250 IB=1,2
      IF(ICANC(IB).EQ.0) GO TO 250
      IF(ICANC(IB).EQ.NBOOK(IB)) RETURN
      ICN=ICANC(IB)
      DO 251 I=1,ICN
      IN=NBKCNC(I,IB)
251   PARACT(IN,1,IB)=0.
      JC=0
      NB=NBOOK(IB)
      DO 252 J=1,NB
      JZ=PARACT(J,1,IB)
      IF(JZ.EQ.0) GO TO 252
      JC=JC+1
      DO 253 L=1,9
253   PARACT(JC,L,IB)=PARACT(J,L,IB)
252   CONTINUE
      NBOOK(IB)=NBOOK(IB)-ICN
      ICANC(IB)=0
250   CONTINUE
C
200   CONTINUE
      RETURN
      END
CDECK  ID>, CJMBIA.
      SUBROUTINE CJMBIA(PMBIAS)
C     *************************
C-- GENERATES SPECTATOR JETS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPMB/CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR(9)
      REAL CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION PMBIAS(5)
      DIMENSION EPPR(2),EMPR(2),PMB(4),V1(4),V2(4),EPPRX(2)
      INTEGER IDLEAD(2)
C
      DATA ICALL/0/
C
C-- INITIALIZATION
      IF(ICALL.GT.0) GO TO 5
      ICALL=1
      ECLPRO=1.-EXP(-CLPRO)
      IDLEAD(1)=-1120
      IF(KPBAR.NE.1) IDLEAD(1)=1120
      IDLEAD(2)=1120
5     CONTINUE
C
C-- PAIR OF LEADING NUCLEONS
      EPPRX(1)=PMBIAS(4)+PMBIAS(3)
      EPPRX(2)=PMBIAS(4)-PMBIAS(3)
      NHEPH=NHEP
      NIT=0
8     CONTINUE
      NHEP=NHEPH
      DO 10 I=1,2
      IF(NHEP+1.GT.NMXHEP) GO TO 500
      NHEP=NHEP+1
9     CONTINUE
      NIT=NIT+1
      IF(NIT.GT.30) GO TO 400
      EPPR(I)=EPPRX(I)*(-LOG(1.-ECLPRO*RNCJ(I))/CLPRO)
      PT2=-PT2PRO*LOG(RNCJ(I+1))
      EMPR(I)=(AMASCJ(IDLEAD(I))**2+PT2)/EPPR(I)
      IF(EMPR(I).GT.EPPR(I)) GO TO 9
      PT=SQRT(PT2)
      PHIP=PI2*RNCJ(I+2)
      PHEP(1,NHEP)=PT*COS(PHIP)
      PHEP(2,NHEP)=PT*SIN(PHIP)
      PHEP(3,NHEP)=(-1.)**(I+1)*(EPPR(I)-EMPR(I))*.5
      PHEP(4,NHEP)=(EPPR(I)+EMPR(I))*.5
      PHEP(5,NHEP)=AMASCJ(IDLEAD(I))
C-- EXTRA PARTICLE INFO
      JMOHEP(1,NHEP)=0
      JMOHEP(2,NHEP)=0
      IDHEP(NHEP)=IDLEAD(I)
      JDAHEP(1,NHEP)=0
      JDAHEP(2,NHEP)=0
      ISTHEP(NHEP)=1
10    CONTINUE
C-- DETERMINE 4-MOMENTUM OF SOFT HADRON SYSTEM
      NHEPL=NHEP+1
      DO 11 J=1,4
11    PMB(J)=PMBIAS(J)-(PHEP(J,NHEP)+PHEP(J,NHEP-1))
      IF(PMB(4).LT.0.) GO TO 8
      W2=PMB(4)**2-PMB(1)**2-PMB(2)**2-PMB(3)**2
      IF(W2.LT.1.) GO TO 8
C-- CALL CJKNO TO GENERATE SOFT HADRON SYSTEM
      CALL CJKNO(SQRT(W2),PMB)
C-- LONG LORENTZ BOOST TO LAB SYSTEM
      IF(NHEP.LT.NHEPL) RETURN
      PMB(1)=0.
      PMB(2)=0.
      NEW=1
      DO 110 I=NHEPL,NHEP
      DO 111 J=1,4
111   V1(J)=PHEP(J,I)
      CALL CJLOR4(PMB,V1,V2,NEW)
      NEW=0
      DO 112 J=1,4
112   PHEP(J,I)=V2(J)
110   CONTINUE
      RETURN
400   IFAIL=1
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),1X,'NO. OF PARTICLES EXCEEDS ',I10
     &//1X,'IN SUBROUTINE CJMBIA'
     1//1X,'EVENT NO. =  ',I10
     3//1X,'INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJMESO.
      SUBROUTINE CJMESO(IFL1,IFL2,KEYSPN,KEYETA,IDMESO)
C     *************************************************
C-- BUILDS MESON OUT OF Q-QB PAIR
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      IFTOT=IFL1+IFL2
      IA1=ABS(IFL1)
      IA2=ABS(IFL2)
      IAX=MAX(IA1,IA2)
      IAM=MIN(IA1,IA2)
      ISPIN=INT(PVMESO(IAX)+RNCJ(0))*KEYSPN
C--
      IF(IFTOT.LT.0) THEN
        IDMESO=100*IAM+10*IAX+ISPIN
      ELSEIF(IFTOT.GT.0) THEN
        IDMESO=-(100*IAM+10*IAX+ISPIN)
      ELSE
        TMIX=RNCJ(0)*FLOAT(KEYETA)
        KM=IAX+3*ISPIN
        IA=1+INT(TMIX+CMIX(KM,1))+INT(TMIX+CMIX(KM,2))
        IDMESO=110*IA+ISPIN
      ENDIF
C--
      RETURN
      END
CDECK  ID>, CJMOVL.
      SUBROUTINE CJMOVL(A,B,N)
C     ************************
C-- ADAPTED FROM ISAJET
C          MOVE N CONSECUTIVE LOCATIONS FROM A TO B.
C          CAN BE REPLACED BY UCOPY FROM CERN LIBRARY.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N),B(N)
      DO 100 I=1,N
      B(I)=A(I)
100   CONTINUE
      RETURN
      END
CDECK  ID>, CJOVER.
      SUBROUTINE CJOVER
C     *****************
C-- TAKES ACTION IN DIMENSION OVERFLOW
C-- (IF KOVER.GT.0 JUST SETS IFAIL=1 AND EXECUTION GOES ON WITH SOME
C--  DIAGNOSTICS FOR THE 1ST 100 OVERFLOWS -- IF KOVER.LT.0 STOPS
C--  EXECUTION BY PRODUCING AN ARITHMETIC ERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJOVEC/SPYOVR,KOVER
C
      DATA ICALL/0/,MXOVER/100/
C
      ICALL=ICALL+1
      SPYOVR=FLOAT(ICALL)
      IFAIL=1
      IF(KOVER.GT.0..AND.ICALL.LT.MXOVER) THEN
        WRITE(ITLIS,5) ICALL
5     FORMAT(/' ***THIS EVENT IS IGNORED'
     1/' ***EXECUTION PROCEEDS'
     2/' ***(KOVER.GT.0, DIMENSION OVERFLOWS SO FAR',I10,')'  )
        RETURN
      ELSE
        WRITE(ITLIS,10) MXOVER
10    FORMAT(5(/1X,80(1H*))
     1//' ***',I10,' DIMENSION OVERFLOWS GENERATED IN THIS RUN'
     2 /' ***JOB ABORT'
     3/5(/1X,80(1H*)))
        STOP
      ENDIF
      END
CDECK  ID>, CJP4CR.
      SUBROUTINE CJP4CR(W,PMB,NHEPI,NHEPF,IFLAG)
C     ******************************************
C-- CORRECT TO HAVE ENERGY-MOMENTUM CONSERVATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION TM2V(NMXHEP)
      DIMENSION SUM(2),PMB(4)
C
      IF(NHEPI.GE.NHEPF) RETURN
C
      IFLAG=0
      WSQ=W**2
      NP=NHEPF-NHEPI+1
C-- TRANSVERSE MOMENTUM, FIRST
      DO 81 J=1,2
      SUM(J)=-PMB(J)
      DO 82 I=NHEPI,NHEPF
82    SUM(J)=SUM(J)+PHEP(J,I)
81    SUM(J)=SUM(J)/NP
      WMIN=0.
      DO 83 I=NHEPI,NHEPF
      DO 84 J=1,2
84    PHEP(J,I)=PHEP(J,I)-SUM(J)
      TM2V(I)=PHEP(5,I)**2+PHEP(1,I)**2+PHEP(2,I)**2
      WMIN=WMIN+SQRT(TM2V(I))
83    CONTINUE
      IF(W.LT.WMIN) GO TO 90
C-- LONGITUDINAL MOMENTUM AND ENERGY
      SUM3=0.
      SUM4=0.
      DO 85 I=NHEPI,NHEPF
      SUM3=SUM3+PHEP(3,I)
      PHEP(4,I)=SQRT(PHEP(3,I)**2+TM2V(I))
85    SUM4=SUM4+PHEP(4,I)
      F3=SUM3/SUM4
      SUM3=0.
      DO 86 I=NHEPI,NHEPF
      PHEP(3,I)=PHEP(3,I)-F3*PHEP(4,I)
86    SUM3=SUM3+ABS(PHEP(3,I))
      WMINSQ=WMIN**2
      FF=WSQ-WMINSQ
      F2=SQRT(FF)/SUM3
      DO 87 IT=1,20
      TEST=0.
      SUM3=0.
      DO 88 I=NHEPI,NHEPF
      PHEP(3,I)=F2*PHEP(3,I)
      SUM3=SUM3+ABS(PHEP(3,I))
      PHEP(4,I)=SQRT(PHEP(3,I)**2+TM2V(I))
      TEST=TEST+PHEP(4,I)
88    CONTINUE
      IF(ABS(TEST-W).LT.1.E-5) GO TO 89
      F2=W/TEST
      GG=TEST**2-WMINSQ
      IF(GG.GT.0.) F2=SQRT(FF/GG)
87    CONTINUE
90    CONTINUE
      IFLAG=1
89    CONTINUE
      RETURN
      END
CDECK  ID>, CJPDG.
      SUBROUTINE CJPDG(NHEPI)
C     ***********************
C-- CONVERTS ISAJET CODES TO PDG CODES IN /HEPEVT/ STREAM, STARTING
C-- FROM NHEPI UP TO NHEP
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      IF(NHEPI.GT.NHEP) RETURN
      DO 10 I=NHEPI,NHEP
10    IDHEP(I)=IPDGCJ(IDHEP(I))
      RETURN
      END
CDECK  ID>, CJPTAB.
      SUBROUTINE CJPTAB
C     *****************
C-- PRINTS PARTICLE AND DECAY TABLE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      CHARACTER*80 LINE
C
      ITAB=ABS(ITDKY)
      REWIND ITAB
1     READ(ITAB,2,END=100) LINE
2     FORMAT(A80)
      WRITE(ITLIS,3) LINE
3     FORMAT(1X,A80)
      GO TO 1
100   RETURN
      END
CDECK  ID>, CJQCDS.
      SUBROUTINE CJQCDS
C     *****************
C-- INITIALIZES QCD PARAMETERS USED BY CJEVOL
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCFUN/LFLAFX,LFLAFQ
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
      EXTERNAL F2LXCJ
      DATA ICALL/0/
C
      IF(ICALL.GT.0) RETURN
      ICALL=1
C
C-- QCD CONSTANTS
      COLORS=3.
      BALPHS=(11.*COLORS-2.*FLOAT(NFLAVS))/(12.*PI)
C
C-- BASIC CONSTANTS FOR EMISSION PROBABILITIES - SPACELIKE EVOLUTION
      PRO1=PAPICJ(1,ZSUP)-PAPICJ(1,ZSLW)
      PRO2=PAPICJ(2,ZSUP)-PAPICJ(2,ZSLW)
      PRO3=PAPICJ(3,ZSUP)-PAPICJ(3,ZSLW)
      PRO3=PRO3*FLOAT(NFLAVS)
      PROGLS=PRO2/(PRO2+PRO3)
      FACT=1./(2.*PI*BALPHS)
      PROFLA(1)=FACT*PRO1
      PROFLA(2)=FACT*(PRO2+PRO3)
C
C-- CONVERSION TABLE: F2INCJ, TABQRK INDEX --> INTERNAL FLAVOR CODE
      KODTBX(1)=1
      KODTBX(2)=-1
      KODTBX(3)=2
      KODTBX(4)=-2
      KODTBX(5)=3
      KODTBX(6)=-3
      KODTBX(7)=LGLU
C
C-- PREPARE X-TABLES
      ALXMIN=LOG(XMIN)
      DBIN=-ALXMIN/FLOAT(NXBIN)
      EPSI=.001
      DO 1 IX=1,NXBIN1
1     XV(IX)=ALXMIN+DBIN*FLOAT(IX-1)
C
      DO 8 J=1,7
      DO 8 IX=1,NXBIN
      LFLAFX=J
      TABQRK(IX,J)=ASIMCJ(XV(IX),XV(IX+1),EPSI,M,2,F2LXCJ)
8     CONTINUE
C
C-- CONVERT XV TO FINAL (LINEAR) FORM
      DO 2 IX=1,NXBIN1
2     XV(IX)=EXP(XV(IX))
C
C-- INTEGRALS OVER QUARKS AND GLUON PARTON DENSITIES
      WGQ=0.
      DO 10 J=1,6
      DO 10 IX=1,NXBIN
10    WGQ=WGQ+TABQRK(IX,J)
      WGG=0.
      DO 13 IX=1,NXBIN
13    WGG=WGG+TABQRK(IX,7)
C
      RETURN
      END
CDECK  ID>, CJQCDT.
      SUBROUTINE CJQCDT
C     *****************
C-- INITIALIZES PARAMETERS AND TABLES USED BY CJJETQ
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCFUN/LFLAFX,LFLAFQ
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      EXTERNAL FQRKCJ, FGLUCJ
      DATA ICALL/0/
C
      IF(ICALL.GT.0) RETURN
      ICALL=1
C
C-- QCD CONSTANTS
      COLORS=3.
      BALPHT=(11.*COLORS-2.*FLOAT(NFLAVT))/(12.*PI)
C
C-- CUTOFF PARAMETERS (QZFLHM() set in CJIALL)
      QZFL(LGLU)=QZFLHM(LGLU)
      IF(QZ.GT.QZFL(LGLU)) QZFL(LGLU)=QZ
      QZFLSQ(LGLU)=QZFL(LGLU)**2
      QTHRSQ(LGLU)=4.*QZFLSQ(LGLU)
      DO 1 L=1,6
      QZFL(L)=QZFLHM(L)
      IF(QZ.GT.QZFL(L)) QZFL(L)=QZ
      QZFLSQ(L)=QZFL(L)**2
1     QTHRSQ(L)=(QZFL(LGLU)+QZFL(L))**2
C
      IF(KYEVOL.GT.1) RETURN
C
C-- MAX QSQ FOR QCD TIMELIKE EVOLUTION
      QSQMXT=ECM**2
C
C-- PREPARE TABLES FOR MASS DEGRADATION OF PARTONS
      FACT=1./(2.*PI*BALPHT)
      ALMAX=LOG(QSQMXT)*(1.+1.E-6)
      EPSI=1.E-3
C
C-- CHECK IF MAXTAB IS ENOUGH
      KFLA=0
      OLQTHR=0.
      DO 20 L=1,7
      IF(ABS(QTHRSQ(L)-OLQTHR).LT.1.E-5.AND.L.NE.LGLU) GO TO 20
      OLQTHR=QTHRSQ(L)
      IF(L.GT.NFLAV.AND.L.NE.LGLU) GO TO 20
      KFLA=KFLA+1
20    CONTINUE
      IF(KFLA.GT.MAXTAB) GO TO 500
C
      KFLA=0
      OLQTHR=0.
      DO 10 L=1,7
      ALMIN(L)=LOG(QTHRSQ(L))
      DSTEP(L)=(ALMAX-ALMIN(L))/FLOAT(NTAB-1)
      IF(ABS(QTHRSQ(L)-OLQTHR).LT.1.E-5.AND.L.NE.LGLU) GO TO 10
      OLQTHR=QTHRSQ(L)
      IF(L.GT.NFLAV.AND.L.NE.LGLU) GO TO 10
      LFLAFQ=L
      KFLA=KFLA+1
      ALW=ALMIN(L)-DSTEP(L)
      BUP=ALMIN(L)
      TABPSQ(KFLA,1)=0.
C
      IF(L.NE.LGLU) THEN
C-- QUARKS
        DO 11 I=2,NTAB
        ALW=ALW+DSTEP(L)
        BUP=BUP+DSTEP(L)
11      TABPSQ(KFLA,I)=FACT*ASIMCJ(ALW,BUP,EPSI,M,2,FQRKCJ)
     &                 +TABPSQ(KFLA,I-1)
      ELSE
C-- GLUON
        DO 13 I=2,NTAB
        ALW=ALW+DSTEP(L)
        BUP=BUP+DSTEP(L)
13      TABPSQ(KFLA,I)=FACT*ASIMCJ(ALW,BUP,EPSI,M,2,FGLUCJ)
     &                 +TABPSQ(KFLA,I-1)
      ENDIF
10    KODTAB(L)=KFLA
C
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) MAXTAB,7,KFLA,KFLA
501   FORMAT(//' ***DIMENSIONS OF TABPSQ( , ) ARE INSUFFICIENT (TABPSQ('
     1,I1,',) AT PRESENT)'
     2/' *** ',I2,' PARTON TYPES HAVE BEEN REQUESTED WITH'
     3,I2,' DIFFERENT MINIMUM MASS CUTOFFS'
     4/' ***INCREASE MAXTAB TO ',I2)
      STOP
      END
CDECK  ID>, CJQSGE.
      SUBROUTINE CJQSGE(IFLA,YIN,Y,QSQ)
C     *********************************
C-- GENERATES EVOLUTION PARAMETER OF LEG (Y.GE.YIN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C
      LFLA=1
      IF(IFLA.EQ.LGLU) LFLA=2
      Y=-LOG(RNCJ(0.))/PROFLA(LFLA)+YIN
      ALQX=EXP(Y)
      IF(ALQX.GT.ALQF) ALQX=ALQF
      QSQ=EXP(ALQX*ALQZM+ALLAM2)
      RETURN
      END
CDECK  ID>, CJQTGE.
      SUBROUTINE CJQTGE(IFLA,XPSQ,PSQ,IGO)
C     ************************************
C-- GENERATES SQUARE MASS (PSQ) OF PARTON IN TIMELIKE QCD EVOLUTION
C-- IGO=0 IS RETURNED IF LEG EVOLUTION STOPS, OTHERWISE IGO=1
C-- INPUT:
C-- IFLA = ID CODE OF PARTON (PDG, ISAJET AND INTERNAL CODES ACCEPTED)
C-- XPSQ = STARTING VALUE (VIRTUALITY) OF SQUARE MASS OF PARTON
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      DATA ICALL/0/
C
      IF(ICALL.EQ.0) CALL CJQCDT
      ICALL=1
C
      MFLA=ABS(IFLA)
      IF(MFLA.EQ.IDGL) MFLA=LGLU
      IF(KYEVOL.GE.2) GO TO 100
      IF(XPSQ.GT.QSQMXT) XPSQ=QSQMXT
      KFLA=KODTAB(MFLA)
      IF(XPSQ.LE.QTHRSQ(MFLA)) GO TO 100
      RIX=(LOG(XPSQ)-ALMIN(MFLA))/DSTEP(MFLA)+1.
      IF(RIX.LE.1.) GO TO 100
      IX=RIX
      DIX=RIX-FLOAT(IX)
      TBX=TABPSQ(KFLA,IX)+(TABPSQ(KFLA,IX+1)-TABPSQ(KFLA,IX))*DIX
      TBGEN=TBX+LOG(RNCJ(0.))
C
      IF(TBGEN.LT.0.) GO TO 100
C
C-- LEG WILL CASCADE, GENERATE MASS
      IF(TBGEN.LT.TABPSQ(KFLA,IX)) GO TO 1
      PSQ=EXP((FLOAT(IX) - 1. + (TBGEN-TABPSQ(KFLA,IX))/
     1         (TABPSQ(KFLA,IX+1)-TABPSQ(KFLA,IX))) * DSTEP(MFLA)
     2        +  ALMIN(MFLA))
      IGO=1
      RETURN
C
1     CONTINUE
      IUP=IX
      ILW=1
3     IF(IUP.LE.ILW+1) GO TO 4
      IHALF=ILW+(IUP-ILW)/2
      IF(TBGEN.LT.TABPSQ(KFLA,IHALF)) THEN
        IUP=IHALF
      ELSE
        ILW=IHALF
      ENDIF
      GO TO 3
4     PSQ=EXP((FLOAT(ILW) - 1. + (TBGEN-TABPSQ(KFLA,ILW))/
     1         (TABPSQ(KFLA,ILW+1)-TABPSQ(KFLA,ILW))) * DSTEP(MFLA)
     2       +  ALMIN(MFLA))
      IGO=1
      RETURN
C
C-- LEG STOPS, MASS SET EQUAL TO CUTOFF
100   CONTINUE
      IF(XPSQ.GE.QZFLSQ(MFLA)) THEN
        PSQ=QZFLSQ(MFLA)
      ELSEIF(MFLA.NE.LGLU.AND.MFLA.GE.4) THEN
        PSQ=QZFLSQ(MFLA)
      ELSE
        PSQ=XPSQ
      ENDIF
      IGO=0
C
      RETURN
      END
CDECK  ID>, CJRCRY.
      SUBROUTINE CJRCRY(RVEC,LENV)
C         Add-and-carry random number generator proposed by
C         Marsaglia and Zaman in SIAM J. Scientific and Statistical
C             Computing, to appear probably 1990.
C         modified with enhanced initialization by F. James, 1990
C         (Subroutine names changed for COJETS.)
C         - Can start 10**9 disjont sequences of period 10**160 each,
C           by calling CJCRGO with an arbitrary 32-bit integer argument
C           INT.
C         - State of the generator given by CJRCUT can be repristinated
C           feeding it in by CJRCIN.
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for CJRCRY:                                  ++
C!!!      CALL CJRCRY (RVEC, LEN)   returns a vector RVEC of LEN     ++
C!!!                   32-bit random floating point numbers between  ++
C!!!                   zero and one.                                 ++
C!!!      CALL CJRCGO(INT)     initializes the generator from one    ++
C!!!                   32-bit integer INT                            ++
C!!!      CALL CJRCIN(IVEC)    restarts the generator from vector    ++
C!!!                   IVEC of 25 32-bit integers (see CJRCUT)       ++
C!!!      CALL CJRCUT(IVEC)    outputs the current values of the 25  ++
C!!!                 32-bit integer seeds, to be used for restarting ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      DIMENSION RVEC(LENV)
      DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
      PARAMETER (TWOP12=4096.)
      PARAMETER (ITWO24=2**24, ICONS=2147483563)
      SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24
      LOGICAL NOTYET
      DATA NOTYET/.TRUE./
      DATA I24,J24,CARRY/24,10,0./
C
C              Default Initialization by Multiplicative Congruential
      IF (NOTYET) THEN
         NOTYET = .FALSE.
         JSEED = 314159265
C777         WRITE(6,'(A,I12)') ' CJRCRY DEFAULT INITIALIZATION: ',JSEED
            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
         DO 50 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
   50    CONTINUE
         I24 = 24
         J24 = 10
         CARRY = 0.
         IF (SEEDS(24) .LT. SEEDS(14)) 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(I24) - SEEDS(J24) - CARRY
      IF (UNI .LT. 0.)  THEN
         UNI = UNI + 1.0
         CARRY = TWOM24
      ELSE
         CARRY = 0.
      ENDIF
      SEEDS(I24) = UNI
      I24 = I24 - 1
      IF (I24 .EQ. 0)  I24 = 24
      J24 = J24 - 1
      IF (J24 .EQ. 0)  J24 = 24
      RVEC(IVEC) = UNI
  100 CONTINUE
      RETURN
C           Entry to input and float integer seeds from previous run
      ENTRY CJRCIN(ISDEXT)
         TWOM24 = 1.
         DO 195 I= 1, 24
  195    TWOM24 = TWOM24 * 0.5
C777  WRITE(6,'(A)') ' FULL INITIALIZATION OF CJRCRY WITH 25 INTEGERS:'
C777  WRITE(6,'(5X,5I12)') ISDEXT
      DO 200 I= 1, 24
      SEEDS(I) = REAL(ISDEXT(I))*TWOM24
  200 CONTINUE
      CARRY = REAL(MOD(ISDEXT(25),10))*TWOM24
      ISD = ISDEXT(25)/10
      I24 = MOD(ISD,100)
      ISD = ISD/100
      J24 = ISD
      RETURN
C                    Entry to ouput seeds as integers
      ENTRY CJRCUT(ISDEXT)
      DO 300 I= 1, 24
         ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12)
  300 CONTINUE
      ICARRY = 0
      IF (CARRY .GT. 0.)  ICARRY = 1
      ISDEXT(25) = 1000*J24 + 10*I24 + ICARRY
      RETURN
C                    Entry to initialize from one integer
      ENTRY CJRCGO(INSEED)
      JSEED = INSEED
C777  WRITE(6,'(A,I12)') ' CJRCRY INITIALIZED FROM SEED ',INSEED
      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
         DO 350 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
  350    CONTINUE
         I24 = 24
         J24 = 10
         CARRY = 0.
         IF (SEEDS(24) .LT. SEEDS(14)) CARRY = TWOM24
      RETURN
      END
CDECK  ID>, CJREPT.
      SUBROUTINE CJREPT
C     *****************
C-- REPEATS EVENT, CHANGING ONLY DECAY OF CHOSEN HEAVY FLAVOR PARTICLES
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MXCUEV=50,MXCUEJ=50)
      COMMON/CJCUES/CUEV(MXCUEV,10,2),CUE(MXCUEJ,6)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      COMMON/CJPTHD/PTHARD,WEIGHT
      REAL PTHARD,WEIGHT
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      LOGICAL ACCEPT
      DATA NACCPL/0/
C
C-- PRELIMINARIES
      NHEPL=NHEP
      ND=0
      DO 10 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 10
      INTC=INIDCJ(IDHEP(I))
      IF(INTC.EQ.0) GO TO 10
      IF(KDECAY(INTC).GE.0) GO TO 10
      ND=ND+1
      IF(ND.GT.MXCUEJ) GO TO 502
      CUE(ND,1)=I
10    CONTINUE
      IF(ND.EQ.0) THEN
        WRITE(ITLIS,9)
9     FORMAT(5(/),' ***ERROR IN CJREPT: ND = 0'
     &/' ***JOB ABORT'
     &)
        STOP
      ENDIF
      IF(NOPDG.EQ.0) CALL CJPDG(1)
C
C-- REPEAT LOOP
      DO 100 LDUM=1,NREPET
      NHEP=NHEPL
      DO 101 I=1,ND
      IPD=CUE(I,1)
      ISTHEP(IPD)=1
      IF(NOPDG.EQ.0) IDHEP(IPD)=ISACJ(IDHEP(IPD))
      CALL CJDECP(IPD)
      IF(NOPDG.EQ.0) IDHEP(IPD)=IPDGCJ(IDHEP(IPD))
101   CONTINUE
      CALL CJDECY(NHEPL+1,0)
      MNHEP=MAX(MNHEP,NHEP)
      IF(NOPDG.EQ.0) CALL CJPDG(NHEPL+1)
      IF(NHEP+1.GT.NMXHEP) GO TO 500
      PHEP(1,NHEP+1)=PTHARD
      MNHEP=MAX(MNHEP,NHEP+1)
      NEVHEP=NEVHEP+1
      ACCEPT=.TRUE.
      CALL CJUSER(ACCEPT)
      IF(.NOT.ACCEPT) NEVHEP=NEVHEP-1
      IF(NEVHEP.NE.NACCPL) THEN
        IF(NEVHEP.LE.NDUMP.AND.
     &  (MOD(NEVHEP,NJUMP).EQ.1.OR.NJUMP.EQ.1))
     *  CALL CJDUMP
        NACCPL=NEVHEP
      ENDIF
100   CONTINUE
C
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN
501   FORMAT(5(/),1X,'***NUMBER OF PARTICLES EXCEEDS ',I10
     1//1X,'***IN SUBROUTINE CJREPT'
     1//1X,'***EVENT NO. = ',I10
     3//1X,'***INCREASE NMXHEP'
     4//1X,'***JOB IS ABORTED'
     5)
      STOP
502   WRITE(ITLIS,503) MXCUEJ
503   FORMAT(//' ***NUMBER OF ELEMENTS IN CUE (/CJCUES/) EXCEEDS',I10
     &//' ***IN SUBROUTINE CJREPT'
     &//' ***INCREASE MXCUEJ'
     &//' ***THIS EVENT IS NEGLECTED - EXECUTION CONTINUES'
     &)
      IFAIL=1
      RETURN
      END
CDECK  ID>, CJRINP.
      SUBROUTINE CJRINP(IFL)
C     **********************
C--  READ IN USER DATA
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIDRU/IDVER,IDATVR,IDG(2)
      COMMON/CJCVER/DAVERS
      CHARACTER*9 DAVERS
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPFRA/PSQRK,PVMESO(6),PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ(5),FRALOG(5),EPSPET(3),EFGMIN,FRAMAS(4)
      REAL PSQRK,PVMESO,PBARYO,PUS1,PUD3,PUS3,PSS3
     &,SIGMAQ,SIGMAG,FRALOQ,FRALOG,EPSPET,EFGMIN,FRAMAS
      COMMON/CJPMB/CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR(9)
      REAL CLPRO,PT2PRO,FPTMB,FMULMB,RETPIZ,RPAIR
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      COMMON/CJTOTA/SIGTOT
      REAL SIGTOT
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      CHARACTER*8 LABLCJ
      CHARACTER*8 REAC
      CHARACTER*2 WTYPE
      CHARACTER*12 ZWFORC
      CHARACTER*8 TTL(10),WORD,BLANK,DUMMY
      CHARACTER*8 HFLAV,HFLAV2
      CHARACTER*2 B1,B2
      CHARACTER*8 STRUC
      DIMENSION LOC(100),MDEC(NDFORC)
      DATA BLANK/'        '/
      DATA LOC/100*0/
C
C          ENTRY
      KFRFLA=0
      VERSN=IDVER/100.
      WRITE(ITLIS,10) VERSN,DAVERS
10    FORMAT('1',2(/T2,80('*'))
     1/T2,23('*'),'  COJETS VERSION',F6.2,1X,A9,'  ',23('*')
     2,2(/T2,80('*')))
      WRITE(ITLIS,11)
   11 FORMAT(//' USER COMMANDS'/1X,13('='))
      WRITE(ITLIS,88)
88    FORMAT(' ')
C
C-- READ TITLE
c   ==========
      READ(ITCOM,1) TTL
    1 FORMAT(10A8)
      WRITE(ITLIS,2) TTL
    2 FORMAT(' ',10A8)
      WRITE(ITLIS,88)
C
C-- READ ENERGY AND NO. OF EVENTS
c   =============================
      READ(ITCOM,*) ECM,NLEAVE,NDUMP,NJUMP
      WRITE(ITLIS,*) ECM,NLEAVE,NDUMP,NJUMP
      WRITE(ITLIS,88)
      NJUMP=MAX(NJUMP,1)
      NDUMP=NDUMP*NJUMP
C
C-- READ REACTION
C   =============
      READ(ITCOM,3) REAC
    3 FORMAT(A8)
      WRITE(ITLIS,4) REAC
   4  FORMAT(1X,A8)
C
      IF(REAC.EQ.'TWOJET  ') THEN
        IEVTYP=1
      ELSEIF(REAC.EQ.'E+E-    ') THEN
        IEVTYP=5
      ELSEIF(REAC.EQ.'DRELLYAN') THEN
        IEVTYP=3
      ELSEIF(REAC.EQ.'MINBIAS ') THEN
        IEVTYP=1
      ELSEIF(REAC.EQ.'SUPERSYM'.OR.REAC.EQ.'SUSY    ') THEN
        WRITE(ITLIS,41) REAC
41      FORMAT(/' ***',A8,' NOT ACTIVATED -- JOB TERMINATED')
        STOP
      ELSEIF(REAC.EQ.'WPAIR   ') THEN
        WRITE(ITLIS,41) REAC
        STOP
      ELSE
        WRITE(ITLIS,70)
70      FORMAT(//' ***YOU FORGOT TO SELECT A PROCESS FOR GENERATION.'
     *    /' -- AVAILABLE AT PRESENT ARE: ',
     *    /'TWOJET, DRELLYAN, MINBIAS')
        STOP
      ENDIF
C
C
   21 CONTINUE
      NSEL=0
C
C          READ KEYWORD. FOR EACH RECOGNIZED KEYWORD READ CORRESPONDING
C          VARIABLES AND SET LOC FLAG.
C
      NSEL=0
100   CONTINUE
      WRITE(ITLIS,88)
      READ(ITCOM,3) WORD
      WRITE(ITLIS,4) WORD
      NSEL=NSEL+1
C          KEYWORD STOP
      IF(WORD.EQ.'STOP    ') THEN
        GO TO 101
C
C   KEYWORDS
C-- MAX LOC = 77 (76 is free)
C-- ============
C
C-- BASIC
C   =====
      ELSEIF(WORD.EQ.'BEAMS   ') THEN
        READ(ITCOM,*)  B1,B2
        WRITE(ITLIS,*) B1,B2
        IF((B1.EQ.'AP'.AND.B2.EQ.'P').OR.(B2.EQ.'AP'.AND.B1.EQ.'P'))
     *  THEN
          KPBAR=1
        ELSEIF(B1.EQ.'P'.AND.B2.EQ.'P') THEN
          KPBAR=0
        ELSE
          WRITE(ITLIS,62)
62        FORMAT(/' ***ONLY ',8H'AP','P',' AND ',7H'P','P',' ACCEPTED'
     *    ,' AS BEAM PAIRS -- JOB ABORT')
          IFL=1
        ENDIF
        LOC(21)=NSEL
      ELSEIF(WORD.EQ.'PTLIMITS') THEN
        READ(ITCOM,*)  PTMIN,PTMAX
        WRITE(ITLIS,*) PTMIN,PTMAX
        IF(REAC.NE.'TWOJET  ') THEN
          WRITE(ITLIS,51)
51        FORMAT(/' ***SELECTED REACTION IS NOT TWOJET'
     *    ,' -- THIS COMMAND WILL BE IGNORED')
          GO TO 100
        ENDIF
        PTMAXX=ECM*.45
        IF(PTMAX.GT.PTMAXX) WRITE(ITLIS,43) PTMAXX
43      FORMAT(/' ***PTMAX TOO LARGE FOR ECM -- TRUNCATED AT PTMAX = '
     *  ,E12.5)
        IF(PTMAX.EQ.0.) PTMAX=PTMAXX
        PTMAX=MIN(PTMAX,REAL(PTMAXX))
        IF(PTMIN.GT.PTMAX) THEN
          WRITE(ITLIS,42)
42        FORMAT(/' ***INVALID RANGE FOR PTLIM'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(1)=NSEL
      ELSEIF(WORD.EQ.'NSIGMA  ') THEN
        READ(ITCOM,*)  NSIGMA
        WRITE(ITLIS,*) NSIGMA
        LOC(56)=NSEL
      ELSEIF(WORD.EQ.'NPRESH  ') THEN
        READ(ITCOM,*)  NPRESH
        WRITE(ITLIS,*) NPRESH
        LOC(17)=NSEL
      ELSEIF(WORD.EQ.'WTYPE   ') THEN
        IF(LOC(3).NE.0) THEN
          READ(ITCOM,*)  DUMMY
          WRITE(ITLIS,*) DUMMY
          WRITE(ITLIS,86)
86        FORMAT(/' ***ONLY ONE WTYPE COMMAND IS ALLOWED --'
     *   ,' THIS COMMAND WILL BE IGNORED')
          GO TO 100
        ENDIF
        READ(ITCOM,*)  WTYPE
        WRITE(ITLIS,*) WTYPE
        IF(REAC.NE.'DRELLYAN') THEN
          WRITE(ITLIS,47)
47        FORMAT(/' ***SELECTED REACTION IS NOT DRELLYAN'
     *    ,' -- THIS COMMAND WILL BE IGNORED')
          GO TO 100
        ELSEIF(WTYPE.EQ.'GM') THEN
          IEVTYP=4
        ELSEIF(WTYPE.EQ.'Z ') THEN
          IEVTYP=2
        ELSEIF(WTYPE.EQ.'W ') THEN
          IEVTYP=3
        ELSE
          WRITE(ITLIS,48)
48        FORMAT(/' ***INCORRECT INPUT FOR WTYPE (ALLOWED INPUTS: '
     *    ,13H'GM','Z','W'),' -- DRELLYAN JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(3)=NSEL
      ELSEIF(WORD.EQ.'DYLIMITS') THEN
        READ(ITCOM,*)  BOMSMN,BOMSMX
        WRITE(ITLIS,*) BOMSMN,BOMSMX
        IF(REAC.NE.'DRELLYAN') THEN
          WRITE(ITLIS,47)
          GO TO 100
        ENDIF
        BOXX=ECM*.8
        IF(BOMSMX.GT.BOXX) WRITE(ITLIS,45) BOXX
45      FORMAT(/' ***UPPER LIMIT FOR DYMASS TOO LARGE FOR ECM'
     *  ,' -- TRUNCATED AT ',E12.5)
        IF(BOMSMN.GE.BOMSMX) THEN
          WRITE(ITLIS,44)
44        FORMAT(/' ***INVALID RANGE FOR DYMASS'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        IF(ABS(BOMSMN-BOMSMX)/BOMSMN.GT.BRATIO) WRITE(ITLIS,46) BRATIO
46      FORMAT(/' ***WARNING: RELATIVE DYMASS RANGE WIDER THAN ',F6.2)
        LOC(2)=NSEL
      ELSEIF(WORD.EQ.'X-STRUCT') THEN
        READ(ITCOM,*)  STRUC
        WRITE(ITLIS,*) STRUC
        IF(STRUC.EQ.'NA3     ') THEN
          IFUNCX=0
        ELSEIF(STRUC.EQ.'EHLQ1   ') THEN
          IFUNCX=1
        ELSEIF(STRUC.EQ.'EHLQ2   ') THEN
          IFUNCX=2
        ELSEIF(STRUC.EQ.'TUNG1   ') THEN
          IFUNCX=3
        ELSEIF(STRUC.EQ.'TUNG2   ') THEN
          IFUNCX=4
        ELSEIF(STRUC.EQ.'TUNG3   ') THEN
          IFUNCX=5
        ELSEIF(STRUC.EQ.'TUNG4   ') THEN
          IFUNCX=6
        ELSE
          WRITE(ITLIS,63)
63        FORMAT(/' ***BAD INPUT (ONLY INPUTS ACCEPTED: '
     *    ,22H'EHLQ1','EHLQ2','NA3')
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(22)=NSEL
      ELSEIF(WORD.EQ.'TLEAVE  ') THEN
        READ(ITCOM,*)  TLEAVE
        WRITE(ITLIS,*) TLEAVE
        LOC(23)=NSEL
      ELSEIF(WORD.EQ.'RANSEED') THEN
        LOC(76)=1
        READ(ITCOM,*) ISEED
        WRITE(ITLIS,*) ISEED
        IF(ISEED.LT.-2147483647.OR.ISEED.GT.2147483647) THEN
          WRITE(ITLIS,*)
          WRITE(ITLIS,*)
     &    ' ***RANDOM NUMBER GENERATOR SEED ISEED MUST BE:'
          WRITE(ITLIS,*)
     &    ' ***-2147483648 <= ISEED <= 2147483647'
          WRITE(ITLIS,*)
     &    ' ***JOB WILL BE ABORTED'
          IFL=1
          GO TO 100
        ENDIF
        CALL CJRCGO(ISEED)
C
C-- KEYS
C   ====
      ELSEIF(WORD.EQ.'KYEVOL  ') THEN
        READ(ITCOM,*)  KYEVOL
        WRITE(ITLIS,*) KYEVOL
        IF(KYEVOL.LT.0.OR.KYEVOL.GT.3) THEN
          WRITE(ITLIS,54)
54        FORMAT(/' ***BAD INPUT (ACCEPTED VALUES: 0,1,2,3)'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(12)=NSEL
      ELSEIF(WORD.EQ.'KYWQED  ') THEN
        READ(ITCOM,*)  KYWQED
        WRITE(ITLIS,*) KYWQED
        IF(REAC.NE.'DRELLYAN') THEN
          WRITE(ITLIS,47)
          GO TO 100
        ENDIF
          IF(KYWQED.NE.0.AND.KYWQED.NE.1.AND.KYWQED.NE.2) THEN
          WRITE(ITLIS,49)
49        FORMAT(/' ***UNACCEPTABLE VALUE (0: NO QED RADIATION;'
     *    ,' 1: O(ALFA) CORRECTED LPA; 2: PURE O(ALFA)'
     *    /' ***JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        IF(IEVTYP.EQ.4.AND.KYWQED.EQ.2) THEN
          KYWQED=1
          WRITE(ITLIS,73)
73        FORMAT(/1X,'***KYWQED HAS BEEN CHANGED TO 1'
     *    /1X,'***FOR THE DRELL-YAN L-L+ CONTINUUM QED RADIATION IN THE'
     *    ,' O(ALPHA) APPROXIMATION IS NOT AVAILABLE')
        ENDIF
        LOC(5)=NSEL
      ELSEIF(WORD.EQ.'KEEQED  ') THEN
        READ(ITCOM,*)  KEEQED
        WRITE(ITLIS,*) KEEQED
        IF(REAC.NE.'E+E-    ') THEN
          WRITE(ITLIS,131)
          GO TO 100
        ENDIF
        IF(KEEQED.NE.0.AND.KEEQED.NE.2) THEN
          WRITE(ITLIS,138)
138       FORMAT(/' ***UNACCEPTABLE VALUE (0: NO QED RADIATION;'
     *    ,' 2: QED RADIATION O(ALPHA) (BKJ)'
     *    /' ***JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(66)=NSEL
      ELSEIF(WORD.EQ.'KYTQCD  ') THEN
        READ(ITCOM,*)  KYTQCD
        WRITE(ITLIS,*) KYTQCD
        IF(KYTQCD.NE.0.AND.KYTQCD.NE.1.AND.KYTQCD.NE.3) THEN
          WRITE(ITLIS,154)
154       FORMAT(/' ***BAD INPUT (ACCEPTED VALUES: 0,1,3)'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(53)=NSEL
      ELSEIF(WORD.EQ.'KYTQED  ') THEN
        READ(ITCOM,*)  KYTQED
        WRITE(ITLIS,*) KYTQED
        IF(KYTQED.NE.0.AND.KYTQED.NE.1) THEN
          WRITE(ITLIS,149)
149       FORMAT(/' ***UNACCEPTABLE VALUE (0: NO QED RADIATION;'
     *    ,' 1: MULTIPLE QED RADIATION WITH LLA)'
     *    /' ***JOB WILL BE ABORTED')
        IFL=1
        ENDIF
        LOC(54)=NSEL
      ELSEIF(WORD.EQ.'NOFRGM  ') THEN
        READ(ITCOM,*)  NOFRGM
        WRITE(ITLIS,*) NOFRGM
        LOC(14)=NSEL
      ELSEIF(WORD.EQ.'NODECY  ') THEN
        READ(ITCOM,*)  NODECY
        WRITE(ITLIS,*) NODECY
        LOC(18)=NSEL
      ELSEIF(WORD.EQ.'NOBROA  ') THEN
        READ(ITCOM,*)  NOBROA
        WRITE(ITLIS,*) NOBROA
        LOC(73)=NSEL
      ELSEIF(WORD.EQ.'NOPDG   ') THEN
        READ(ITCOM,*)  NOPDG
        WRITE(ITLIS,*) NOPDG
        LOC(62)=NSEL
C
C-- CHANNEL FORCE
C   =============
      ELSEIF(WORD.EQ.'HEAVYQRK') THEN
        READ(ITCOM,*)  HFLAV
        WRITE(ITLIS,*) HFLAV
        IF(REAC.NE.'TWOJET  ') THEN
          WRITE(ITLIS,51)
          GO TO 100
        ENDIF
        IF(LOC(9).GT.0.OR.LOC(10).GT.0.OR.LOC(11).GT.0
     *  .OR.LOC(57).GT.0) THEN
          WRITE(ITLIS,52)
52        FORMAT(/' ***MULTIPLE HEAVYQRK, FUSION, FLAVEX, GSPLIT'
     *    ,' COMMANDS',' -- THIS COMMAND WILL BE IGNORED')
          GO TO 100
        ENDIF
        DO 120 L=4,6
        IF(HFLAV.NE.LABLCJ(L)) GO TO 120
        KFRFLA=L
        GO TO 121
120     CONTINUE
        WRITE(ITLIS,53) (LABLCJ(L),L=4,6)
53      FORMAT(/' ***UNACCEPTABLE INPUT (ALLOWED INPUTS ARE '
     *  ,3(A8,','),' -- JOB WILL BE ABORTED')
        IFL=1
121     CONTINUE
        NFLAV=MAX(NFLAV,KFRFLA)
        KPRHEV=3
        LOC(9)=NSEL
      ELSEIF(WORD.EQ.'FUSION  ') THEN
        READ(ITCOM,*)  HFLAV
        WRITE(ITLIS,*) HFLAV
        IF(REAC.NE.'TWOJET  ') THEN
          WRITE(ITLIS,51)
          GO TO 100
        ENDIF
        IF(LOC(9).GT.0.OR.LOC(10).GT.0.OR.LOC(11).GT.0
     *  .OR.LOC(57).GT.0) THEN
          WRITE(ITLIS,52)
          GO TO 100
        ENDIF
        DO 122 L=4,6
        IF(HFLAV.NE.LABLCJ(L)) GO TO 122
        KFRFLA=L
        GO TO 123
122     CONTINUE
        WRITE(ITLIS,53)
        IFL=1
123     CONTINUE
        NFLAV=MAX(NFLAV,KFRFLA)
        KPRHEV=1
        LOC(10)=NSEL
      ELSEIF(WORD.EQ.'FLAVEX  ') THEN
        READ(ITCOM,*)  HFLAV
        WRITE(ITLIS,*) HFLAV
        IF(REAC.NE.'TWOJET  ') THEN
          WRITE(ITLIS,51)
          GO TO 100
        ENDIF
        IF(LOC(9).GT.0.OR.LOC(10).GT.0.OR.LOC(11).GT.0
     *  .OR.LOC(57).GT.0) THEN
          WRITE(ITLIS,52)
          GO TO 100
        ENDIF
        DO 124 L=4,6
        IF(HFLAV.NE.LABLCJ(L)) GO TO 124
        KFRFLA=L
        GO TO 125
124     CONTINUE
        WRITE(ITLIS,53)
        IFL=1
125     CONTINUE
        NFLAV=MAX(NFLAV,KFRFLA)
        KPRHEV=2
        LOC(11)=NSEL
      ELSEIF(WORD.EQ.'GSPLIT  ') THEN
        READ(ITCOM,*)  HFLAV
        WRITE(ITLIS,*) HFLAV
        IF(REAC.NE.'TWOJET  ') THEN
          WRITE(ITLIS,51)
          GO TO 100
        ENDIF
        IF(LOC(9).GT.0.OR.LOC(10).GT.0.OR.LOC(11).GT.0
     *  .OR.LOC(57).GT.0) THEN
          WRITE(ITLIS,52)
          GO TO 100
        ENDIF
        DO 126 L=4,6
        IF(HFLAV.NE.LABLCJ(L)) GO TO 126
        KFRFLA=L
        GO TO 127
126     CONTINUE
        WRITE(ITLIS,53)
        IFL=1
127     CONTINUE
        NFLAV=MAX(NFLAV,KFRFLA)
        KPRHEV=4
        LOC(57)=NSEL
      ELSEIF(WORD.EQ.'ZWFORCE ') THEN
        IF(LOC(3).EQ.0) THEN
          READ(ITCOM,*)  ZWFORC
          WRITE(ITLIS,*) ZWFORC
          WRITE(ITLIS,83)
83    FORMAT(/' ***ZWFORCE COMMAND MUST APPEAR AFTER WTYPE COMMAND --'
     *,' JOB WILL BE ABORTED')
          IFL=1
          GO TO 100
        ENDIF
        READ(ITCOM,*)  ZWFORC
        WRITE(ITLIS,*) ZWFORC
        IF(REAC.NE.'DRELLYAN') THEN
          WRITE(ITLIS,47)
          GO TO 100
        ENDIF
        IF(IEVTYP.EQ.3) THEN
          ND1=IDB(INIDCJ(IDWP))
          ND2=ND1+NDECW-1
        ELSE
          ND1=IDB(INIDCJ(IDZ))
          ND2=ND1+NDECZ-1
        ENDIF
        LPF=0
        IF(ZWFORC.EQ.'E') THEN
          LPF=12
        ELSEIF(ZWFORC.EQ.'MU') THEN
          LPF=14
        ELSEIF(ZWFORC.EQ.'TAU') THEN
          LPF=16
        ELSEIF(ZWFORC.EQ.LABLCJ(4)) THEN
          LPF=4
        ELSEIF(ZWFORC.EQ.LABLCJ(5)) THEN
          LPF=5
        ELSEIF(ZWFORC.EQ.LABLCJ(6)) THEN
          LPF=6
        ENDIF
        IF(LPF.GT.0) THEN
          DO 151 ND=ND1,ND2
          NOP=1
          DO 152 LD=1,NPDECX
152       IF(ABS(KDP(LD,ND)).EQ.LPF) NOP=0
          IF(NOP.EQ.0) THEN
            NFORCE=NFORCE+1
            IF(NFORCE.LE.MXFORC) THEN
              KFORCE(1,NFORCE)=MOTHER(ND)
              DO 153 LD=1,NPDECX
153           KFORCE(LD+1,NFORCE)=KDP(LD,ND)
            ELSE
              WRITE(ITLIS,58) MXFORC
              IFL=1
            ENDIF
          ENDIF
151       CONTINUE
        ELSEIF(ZWFORC.EQ.'QUARKS') THEN
          DO 156 ND=ND1,ND2
          NOP=1
          DO 157 LD=1,NPDECX
          IDA=ABS(KDP(LD,ND))
          IF(IDA.EQ.6) GO TO 156
157       IF(IDA.LT.10.AND.IDA.GT.0) NOP=0
          IF(NOP.EQ.0) THEN
            NFORCE=NFORCE+1
            IF(NFORCE.LE.MXFORC) THEN
              KFORCE(1,NFORCE)=MOTHER(ND)
              DO 158 LD=1,NPDECX
158           KFORCE(LD+1,NFORCE)=KDP(LD,ND)
            ELSE
              WRITE(ITLIS,58) MXFORC
              IFL=1
            ENDIF
          ENDIF
156       CONTINUE
        ELSE
          WRITE(ITLIS,159) (LABLCJ(L),L=4,6)
159       FORMAT(/' ***UNACCEPTABLE VALUE'
     *    /' ***ACCEPTED: E, MU, TAU, ',3(A8,','),'QUARKS'
     *    /' ***JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(4)=LOC(4)+1
      ELSEIF(WORD.EQ.'EEFORCE ') THEN
        READ(ITCOM,*)  ZWFORC
        WRITE(ITLIS,*) ZWFORC
        IF(REAC.NE.'E+E-    ') THEN
          WRITE(ITLIS,131)
131       FORMAT(/' ***SELECTED REACTION IS NOT E+E-'
     *    ,' -- THIS COMMAND WILL BE IGNORED')
          GO TO 100
        ENDIF
        ND1=IDB(INIDCJ(IDZ))
        ND2=ND1+NDECZ-1
        LPF=0
        IF(ZWFORC.EQ.LABLCJ(4)) THEN
          LPF=4
        ELSEIF(ZWFORC.EQ.LABLCJ(5)) THEN
          LPF=5
        ELSEIF(ZWFORC.EQ.LABLCJ(6)) THEN
          LPF=6
        ELSEIF(ZWFORC.EQ.'QUARKS') THEN
          DO 166 ND=ND1,ND2
          NOP=1
          DO 167 LD=1,NPDECX
          IDA=ABS(KDP(LD,ND))
          IF(IDA.EQ.6) GO TO 166
167       IF(IDA.LT.10.AND.IDA.GT.0) NOP=0
          IF(NOP.EQ.0) THEN
            NFORCE=NFORCE+1
            IF(NFORCE.LE.MXFORC) THEN
              KFORCE(1,NFORCE)=MOTHER(ND)
              DO 168 LD=1,NPDECX
168           KFORCE(LD+1,NFORCE)=KDP(LD,ND)
            ELSE
              WRITE(ITLIS,58) MXFORC
              IFL=1
            ENDIF
          ENDIF
166       CONTINUE
        ELSE
          WRITE(ITLIS,169) (LABLCJ(L),L=4,6)
169       FORMAT(/' ***UNACCEPTABLE VALUE'
     *    /' ***ACCEPTED: ',3(A8,','),'QUARKS'
     *    /' ***JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        IF(LPF.GT.0) THEN
          DO 161 ND=ND1,ND2
          NOP=1
          DO 162 LD=1,NPDECX
162       IF(ABS(KDP(LD,ND)).EQ.LPF) NOP=0
          IF(NOP.EQ.0) THEN
            NFORCE=NFORCE+1
            IF(NFORCE.LE.MXFORC) THEN
              KFORCE(1,NFORCE)=MOTHER(ND)
              DO 163 LD=1,NPDECX
163           KFORCE(LD+1,NFORCE)=KDP(LD,ND)
            ELSE
              WRITE(ITLIS,58) MXFORC
              IFL=1
            ENDIF
          ENDIF
161       CONTINUE
        ENDIF
        LOC(65)=LOC(65)+1
C
C-- DECAY CONTROL
C   =============
      ELSEIF(WORD.EQ.'HEAVYREP') THEN
        IF(LOC(20).GT.0) THEN
          WRITE(ITLIS,59)
59        FORMAT(/' ***HEAVYREP USED MORE THAN ONCE'
     *    ,' -- JOB WILL BE ABORTED')
          READ(ITCOM,*)  DUMMY,NDUMMY
          WRITE(ITLIS,*) DUMMY,' ',NDUMMY
          IFL=1
          GO TO 100
        ENDIF
        READ(ITCOM,*)  HFLAV2,NREPET
        WRITE(ITLIS,*) HFLAV2,' ',NREPET
        KREPET=0
        DO 95 L=4,6
95      IF(HFLAV2.EQ.LABLCJ(L)) KREPET=L
        IF(KREPET.EQ.0) THEN
          WRITE(ITLIS,92) (LABLCJ(L),L=4,6)
92      FORMAT(/' ***BAD 1ST ENTRY FOR HEAVYREP (ALLOWED INPUTS ARE '
     *  ,3(A8,','),' --- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        IF(IEVTYP.EQ.1.AND.KREPET.NE.KFRFLA) THEN
          WRITE(ITLIS,60)
60        FORMAT(
     *    /' ***WITH TWOJET, HEAVYREP CAN BE USED ONLY WITH'
     *    ,' HEAVY FLAVOR FORCING OF THE SAME TYPE AS IN THE HEAVYREP'
     *    ,' CARD'
     *    /' --- JOB WILL BE ABORTED')
          IFL=1
          GO TO 100
        ENDIF
        IF(IEVTYP.EQ.5.AND.(LOC(65).NE.1.OR.ZWFORC.NE.HFLAV2)) THEN
          WRITE(ITLIS,137)
137       FORMAT(/' ***WITH E+E-, HEAVYREP CAN BE USED ONLY WITH A'
     *    ,' FINAL CHANNEL SELECTION CONSISTENT'
     *    /' WITH THE FLAVOR SPECIFIED IN THE HEAVYREP CARD'
     *    /' --- JOB WILL BE ABORTED')
          IFL=1
          GO TO 100
        ENDIF
        IF((IEVTYP.EQ.2.OR.IEVTYP.EQ.4)
     &     .AND.(LOC(4).NE.1.OR.ZWFORC.NE.HFLAV2)) THEN
          WRITE(ITLIS,91)
91        FORMAT(/' ***WITH Z DRELLYAN, HEAVYREP CAN BE USED ONLY WITH'
     *    ,' A FLAVOR COMPATIBLE WITH THE Z DECAY CHANNEL FORCED'
     *    /' --- JOB WILL BE ABORTED')
          IFL=1
          GO TO 100
        ENDIF
        IF(IEVTYP.EQ.3.AND.(LOC(4).NE.1.OR.ZWFORC.NE.HFLAV2)) THEN
          WRITE(ITLIS,93)
93        FORMAT(/' ***WITH W DRELLYAN, HEAVYREP CAN BE USED ONLY WITH'
     *    ,' A FLAVOR COMPATIBLE WITH THE W DECAY CHANNEL FORCED'
     *    /' --- JOB WILL BE ABORTED')
          IFL=1
          GO TO 100
        ENDIF
        IF(NREPET.LE.0) THEN
          WRITE(ITLIS,76)
76        FORMAT(/' ***NO. OF EVENT REPETITIONS IN INPUT <= 0'
     *    ,' -- HAS BEEN RESET TO 1')
          NREPET=1
        ENDIF
        LOC(20)=NSEL
      ELSEIF(WORD.EQ.'STOPDECY') THEN
        READ(ITCOM,*)  MDEC1
        WRITE(ITLIS,*) MDEC1
        MDEC1=ISACJ(MDEC1)
        INTP=INIDCJ(MDEC1)
        IF(INTP.GT.0) THEN
          KDECAY(INTP)=0
          IF(KANTIP(INTP).EQ.1) KDECAY(INIDCJ(-MDEC1))=0
          NSTOPD=NSTOPD+1
          KSTOPD(NSTOPD)=MDEC1
        ELSE
        WRITE(ITLIS,79)
79      FORMAT(/' ***BAD INPUT -- LOOK AT PARTICLE PDG CODES'
     *  ,' IN PARTICLE TABLE -- JOB WILL BE ABORTED')
        IFL=1
        ENDIF
        LOC(13)=NSEL
      ELSEIF(WORD.EQ.'STOPDEC*') THEN
        READ(ITCOM,*)  MDEC1
        WRITE(ITLIS,*) MDEC1
        INTP=INIDCJ(MDEC1)
        IF(INTP.GT.0) THEN
          KDECAY(INTP)=0
          IF(KANTIP(INTP).EQ.1) KDECAY(INIDCJ(-MDEC1))=0
          NSTOPD=NSTOPD+1
          KSTOPD(NSTOPD)=MDEC1
        ELSE
        WRITE(ITLIS,55)
55      FORMAT(/' ***BAD INPUT -- LOOK AT PARTICLE ISAJET CODES'
     *  ,' IN PARTICLE TABLE -- JOB WILL BE ABORTED')
        IFL=1
        ENDIF
        LOC(15)=NSEL
      ELSEIF(WORD.EQ.'FORCE   ') THEN
        DO 78 L=1,NDFORC
78      MDEC(L)=0
        READ(ITCOM,*)  MDEC
        WRITE(ITLIS,*) MDEC
        IF(NFORCE.LT.MXFORC) THEN
          NFORCE=NFORCE+1
          DO 77 L=1,NDFORC
77        KFORCE(L,NFORCE)=ISACJ(MDEC(L))
        ELSE
          WRITE(ITLIS,58)
          IFL=1
        ENDIF
        LOC(16)=NSEL
      ELSEIF(WORD.EQ.'FORCE*  ') THEN
        DO 98 L=1,NDFORC
98      MDEC(L)=0
        READ(ITCOM,*)  MDEC
        WRITE(ITLIS,*) MDEC
        IF(NFORCE.LT.MXFORC) THEN
          NFORCE=NFORCE+1
          DO 57 L=1,NDFORC
57        KFORCE(L,NFORCE)=MDEC(L)
        ELSE
          WRITE(ITLIS,58) MXFORC
58        FORMAT(/' ***FORCE USED MORE THAN ',I6,' TIMES'
     *    ,' -- INCREASE MXFORC'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(19)=NSEL
      ELSEIF(WORD.EQ.'DECCTX  ') THEN
        READ(ITCOM,*)  DECCTX
        WRITE(ITLIS,*) DECCTX
        LOC(69)=NSEL
      ELSEIF(WORD.EQ.'DECRX   ') THEN
        READ(ITCOM,*)  DECRX
        WRITE(ITLIS,*) DECRX
        LOC(70)=NSEL
      ELSEIF(WORD.EQ.'DECRTX  ') THEN
        READ(ITCOM,*)  DECRTX
        WRITE(ITLIS,*) DECRTX
        LOC(71)=NSEL
      ELSEIF(WORD.EQ.'DECZX   ') THEN
        READ(ITCOM,*)  DECZX
        WRITE(ITLIS,*) DECZX
        LOC(72)=NSEL
C
C-- QCD ETC.
C   ========
      ELSEIF(WORD.EQ.'ALAMBD  ') THEN
        READ(ITCOM,*)  ALAMBD
        WRITE(ITLIS,*) ALAMBD
        LOC(25)=NSEL
      ELSEIF(WORD.EQ.'CUTJET  ') THEN
        READ(ITCOM,*)  CUTJET
        WRITE(ITLIS,*) CUTJET
        LOC(26)=NSEL
      ELSEIF(WORD.EQ.'QZEVOL  ') THEN
        READ(ITCOM,*)  QZEVOL
        WRITE(ITLIS,*) QZEVOL
        LOC(58)=NSEL
      ELSEIF(WORD.EQ.'PTCUT   ') THEN
        READ(ITCOM,*)  PTCUT
        WRITE(ITLIS,*) PTCUT
        LOC(32)=NSEL
      ELSEIF(WORD.EQ.'NFLAV   ') THEN
        READ(ITCOM,*)  NFLAV
        WRITE(ITLIS,*) NFLAV
        IF(NFLAV.LT.3.OR.NFLAV.GT.6) THEN
          WRITE(ITLIS,64)
64        FORMAT(/' ***BAD INPUT (ACCEPTED RANGE: 3 - 6)'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(31)=NSEL
      ELSEIF(WORD.EQ.'TOPMAS  ') THEN
        READ(ITCOM,*)  TOPMAS
        WRITE(ITLIS,*) TOPMAS
        QMAS(6)=TOPMAS
        IF(QMAS(6).LT.16.) THEN
          WRITE(ITLIS,155)
155       FORMAT(/' ***BAD INPUT (MINIMUM ACCEPTED'
     *    ,' VALUE FOR TOPMAS IS 16.)'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(28)=NSEL
      ELSEIF(WORD.EQ.'PT2INT  ') THEN
        READ(ITCOM,*)  PT2INT
        WRITE(ITLIS,*) PT2INT
        LOC(33)=NSEL
      ELSEIF(WORD.EQ.'FACTK   ') THEN
        READ(ITCOM,*)  FACTK
        WRITE(ITLIS,*) FACTK
        LOC(30)=NSEL
      ELSEIF(WORD.EQ.'SIGINL  ') THEN
        READ(ITCOM,*)  SIGINL
        WRITE(ITLIS,*) SIGINL
        LOC(29)=NSEL
C
C-- Z/W
C   ===
      ELSEIF(WORD.EQ.'SIN2W   ') THEN
        READ(ITCOM,*)  SIN2W
        WRITE(ITLIS,*) SIN2W
        LOC(27)=NSEL
      ELSEIF(WORD.EQ.'WMASS   ') THEN
        READ(ITCOM,*)  WMASS
        WRITE(ITLIS,*) WMASS
        WMASSM=10.
        IF(WMASS.LT.WMASSM) THEN
          WRITE(ITLIS,50) WMASSM
50        FORMAT(/' ***MASS OF W+ AND W- SET LOWER THAN ',E12.5
     *    ,' -- TOO LOW, JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        IF(REAC.EQ.'DRELLYAN'.AND.WMASS.GT.ECM-10.) THEN
          WRITE(ITLIS,85)
85        FORMAT(/' ***MASS OF W+ AND W- SET TOO HIGH FOR ECM'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(6)=NSEL
      ELSEIF(WORD.EQ.'ZMASS   ') THEN
        READ(ITCOM,*)  ZMASS
        WRITE(ITLIS,*) ZMASS
        WMASSM=10.
        IF(ZMASS.LT.WMASSM) THEN
          WRITE(ITLIS,84) WMASSM
84        FORMAT(/' ***MASS OF Z0 SET LOWER THAN ',E12.5
     *    ,' -- TOO LOW, JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        IF(REAC.EQ.'DRELLYAN'.AND.ZMASS.GT.ECM-10.) THEN
          WRITE(ITLIS,82)
82        FORMAT(/' ***MASS OF Z0 SET TOO HIGH FOR ECM'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(7)=NSEL
      ELSEIF(WORD.EQ.'WGAMMA  ') THEN
        READ(ITCOM,*)  WGAMMA
        WRITE(ITLIS,*) WGAMMA
        LOC(61)=NSEL
      ELSEIF(WORD.EQ.'ZGAMMA  ') THEN
        READ(ITCOM,*)  ZGAMMA
        WRITE(ITLIS,*) ZGAMMA
        LOC(64)=NSEL
      ELSEIF(WORD.EQ.'ZWTHRS  ') THEN
        READ(ITCOM,*)  ZWTHRS
        WRITE(ITLIS,*) ZWTHRS
        WMASSM=10.
        IF(ZWTHRS.LT.WMASSM) THEN
          WRITE(ITLIS,34) WMASSM
34        FORMAT(/' ***ZWTHRS SET LOWER THAN ',E12.5
     *    ,' -- TOO LOW, JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        IF(ZWTHRS.GT.ECM-10.) THEN
          WRITE(ITLIS,32)
32        FORMAT(/' ***ZWTHRS SET TOO HIGH FOR ECM'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(63)=NSEL
      ELSEIF(WORD.EQ.'GMCZW   ') THEN
        READ(ITCOM,*)  GMCZW
        WRITE(ITLIS,*) GMCZW
        LOC(77)=NSEL
C
C-- JET FRAGMENTATION
C   =================
      ELSEIF(WORD.EQ.'FRALOQ  ') THEN
        READ(ITCOM,*)  FRALOQ
        WRITE(ITLIS,*) FRALOQ
        LOC(35)=NSEL
      ELSEIF(WORD.EQ.'FRALOG  ') THEN
        READ(ITCOM,*)  FRALOG
        WRITE(ITLIS,*) FRALOG
        LOC(60)=NSEL
      ELSEIF(WORD.EQ.'SIGMAQ  ') THEN
        READ(ITCOM,*)  SIGMAQ
        WRITE(ITLIS,*) SIGMAQ
        LOC(34)=NSEL
      ELSEIF(WORD.EQ.'SIGMAG  ') THEN
        READ(ITCOM,*)  SIGMAG
        WRITE(ITLIS,*) SIGMAG
        LOC(59)=NSEL
      ELSEIF(WORD.EQ.'EPSPET  ') THEN
        READ(ITCOM,*)  EPSPET
        WRITE(ITLIS,*) EPSPET
        IFLEPS=0
        DO 68 L=1,3
        IF(EPSPET(L).GE.0..AND.EPSPET(L).LE.1.) GO TO 68
        IFLEPS=1
68      CONTINUE
        IF(IFLEPS.EQ.1) THEN
          WRITE(ITLIS,66)
          IFL=1
        ENDIF
        LOC(40)=NSEL
      ELSEIF(WORD.EQ.'EFGMIN  ') THEN
        READ(ITCOM,*)  EFGMIN
        WRITE(ITLIS,*) EFGMIN
        LOC(74)=NSEL
      ELSEIF(WORD.EQ.'FRAMAS  ') THEN
        READ(ITCOM,*)  FRAMAS
        WRITE(ITLIS,*) FRAMAS
        LOC(75)=NSEL
      ELSEIF(WORD.EQ.'PSQRK   ') THEN
        READ(ITCOM,*)  PSQRK
        WRITE(ITLIS,*) PSQRK
        LOC(36)=NSEL
      ELSEIF(WORD.EQ.'PVMESO  ') THEN
        READ(ITCOM,*)  PVMESO
        WRITE(ITLIS,*) PVMESO
        IFLPV=0
        DO 65 L=1,6
        IF(PVMESO(L).GE.0..AND.PVMESO(L).LE.1.) GO TO 65
        IFLPV=1
65      CONTINUE
        IF(IFLPV.EQ.1) THEN
          WRITE(ITLIS,66)
66        FORMAT(/' ***BAD RANGE (ACCEPTED 0. - 1. FOR EACH ENTRY)'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(37)=NSEL
      ELSEIF(WORD.EQ.'CMIX    ') THEN
        READ(ITCOM,*)  CMIX
        WRITE(ITLIS,*) CMIX
        IFLCMX=0
        DO 69 L1=1,6
        DO 69 L2=1,2
        IF(CMIX(L1,L2).GE.0..AND.CMIX(L1,L2).LE.1.) GO TO 69
        IFLCMX=1
69      CONTINUE
        IF(IFLCMX.EQ.1) THEN
          WRITE(ITLIS,66)
          IFL=1
        ENDIF
        LOC(41)=NSEL
      ELSEIF(WORD.EQ.'PBARYO  ') THEN
        READ(ITCOM,*)  PBARYO
        WRITE(ITLIS,*) PBARYO
        IF(PBARYO.LT.0..OR.PBARYO.GT.1.) THEN
          WRITE(ITLIS,67)
67        FORMAT(/' ***BAD RANGE (ACCEPTED 0. - 1.)'
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
        LOC(39)=NSEL
      ELSEIF(WORD.EQ.'PUS1    ') THEN
        READ(ITCOM,*)  PUS1
        WRITE(ITLIS,*) PUS1
        IF(PUS1.LT.0..OR.PUS1.GT.1.) THEN
          WRITE(ITLIS,67)
          IFL=1
        ENDIF
        LOC(38)=NSEL
      ELSEIF(WORD.EQ.'PUD3    ') THEN
        READ(ITCOM,*)  PUD3
        WRITE(ITLIS,*) PUD3
        IF(PUD3.LT.0..OR.PUD3.GT.1.) THEN
          WRITE(ITLIS,67)
          IFL=1
        ENDIF
        LOC(44)=NSEL
      ELSEIF(WORD.EQ.'PUS3    ') THEN
        READ(ITCOM,*)  PUS3
        WRITE(ITLIS,*) PUS3
        IF(PUS3.LT.0..OR.PUS3.GT.1.) THEN
          WRITE(ITLIS,67)
          IFL=1
        ENDIF
        LOC(45)=NSEL
      ELSEIF(WORD.EQ.'PSS3    ') THEN
        READ(ITCOM,*)  PSS3
        WRITE(ITLIS,*) PSS3
        IF(PSS3.LT.0..OR.PSS3.GT.1.) THEN
          WRITE(ITLIS,67)
          IFL=1
        ENDIF
        LOC(53)=NSEL
C
C-- DECAYS
C   ======
      ELSEIF(WORD.EQ.'BZDMIX  ') THEN
        READ(ITCOM,*)  BZDMIX
        WRITE(ITLIS,*) BZDMIX
        IF(BZDMIX.LT.0..OR.BZDMIX.GT.1.) THEN
          WRITE(ITLIS,67)
          IFL=1
        ENDIF
        LOC(42)=NSEL
      ELSEIF(WORD.EQ.'BZSMIX  ') THEN
        READ(ITCOM,*)  BZSMIX
        WRITE(ITLIS,*) BZSMIX
        IF(BZSMIX.LT.0..OR.BZSMIX.GT.1.) THEN
          WRITE(ITLIS,67)
          IFL=1
        ENDIF
        LOC(43)=NSEL
      ELSEIF(WORD.EQ.'CND1    ') THEN
        READ(ITCOM,*)  CND1
        WRITE(ITLIS,*) CND1
        LOC(67)=NSEL
      ELSEIF(WORD.EQ.'CND2    ') THEN
        READ(ITCOM,*)  CND2
        WRITE(ITLIS,*) CND2
        LOC(68)=NSEL
C
C-- BEAM JETS
C   =========
      ELSEIF(WORD.EQ.'CLPRO   ') THEN
        READ(ITCOM,*)  CLPRO
        WRITE(ITLIS,*) CLPRO
        LOC(46)=NSEL
      ELSEIF(WORD.EQ.'PT2PRO  ') THEN
        READ(ITCOM,*)  PT2PRO
        WRITE(ITLIS,*) PT2PRO
        LOC(47)=NSEL
      ELSEIF(WORD.EQ.'FPTMB   ') THEN
        READ(ITCOM,*)  FPTMB
        WRITE(ITLIS,*) FPTMB
        LOC(48)=NSEL
      ELSEIF(WORD.EQ.'FMULMB  ') THEN
        READ(ITCOM,*)  FMULMB
        WRITE(ITLIS,*) FMULMB
        LOC(49)=NSEL
      ELSEIF(WORD.EQ.'RETPIZ  ') THEN
        READ(ITCOM,*)  RETPIZ
        WRITE(ITLIS,*) RETPIZ
        LOC(50)=NSEL
      ELSEIF(WORD.EQ.'RPAIR   ') THEN
        READ(ITCOM,*)  RPAIR
        WRITE(ITLIS,*) RPAIR
        LOC(51)=NSEL
C
C-- NONE OF THE ABOVE
C   =================
      ELSE
        WRITE(ITLIS,71)
71      FORMAT(//' ***NOT A RECOGNIZABLE PARAMETER'
     *  ,' -- JOB WILL BE ABORTED')
        IFL=1
      ENDIF
C
      GO TO 100
C
C-- FINAL CHECKS FOR ERRORS OR DEFAULT SETUPS
C   =========================================
101   CONTINUE
C-- CONTINUUM DRELLYAN
      IF(LOC(2).GT.0) THEN
        IF(IEVTYP.NE.4) THEN
          WRITE(ITLIS,72)
72        FORMAT(/' ***SELECTED PROCESS IS NOT CONTINUUM DRELLYAN'
     *    ,' -- DYLIMITS COMMAND WILL BE IGNORED')
        ELSEIF(BOMSMN.LE.QZEVOL) THEN
          WRITE(ITLIS,170) BOMSMN,QZEVOL
170       FORMAT(/' ***LOWER LIMIT FOR DY CONTINUUM MASS = ',E12.5
     2    ,' SMALLER THAN QZEVOL = ',E12.5
     *    ,' -- JOB WILL BE ABORTED')
          IFL=1
        ENDIF
      ENDIF
      IF(IEVTYP.EQ.4.AND.LOC(2).EQ.0) THEN
        WRITE(ITLIS,171)
171     FORMAT(/' ***DY CONTINUUM MASS INTERVAL HAS NOT BEEN DEFINED'
     *  ,' -- JOB WILL BE ABORTED')
        IFL=1
      ENDIF
C-- IF REPETITION OF HEAVY FLAVOR DECAYS IS ACTIVATED THEN ALWAYS
C-- KEEP ALSO UNSTABLE PARTICLES
      IF(KREPET.NE.0) NOUNST=0
C-- COUNT FORCINGS OF Z AND W DECAYS
      NACTZ=0
      NACTW=0
      IF(NFORCE.GT.0) THEN
        DO 179 LD=1,NFORCE
        IF(ABS(KFORCE(1,LD)).EQ.90) NACTZ=NACTZ+1
179     IF(ABS(KFORCE(1,LD)).EQ.80) NACTW=NACTW+1
      ENDIF
C-- DEFAULT ZWFORCE: ALL DECAY MODES EXCEPT THOSE INCLUDING TOP
      IF(((IEVTYP.EQ.2.OR.IEVTYP.EQ.4).AND.NACTZ.EQ.0)
     &    .OR.(IEVTYP.EQ.3.AND.NACTW.EQ.0)) THEN
        IF(IEVTYP.EQ.3) THEN
          ND1=IDB(INIDCJ(IDWP))
          ND2=ND1+NDECW-1
        ELSE
          ND1=IDB(INIDCJ(IDZ))
          ND2=ND1+NDECZ-1
        ENDIF
        DO 256 ND=ND1,ND2
        DO 257 LD=1,NPDECX
        IDA=ABS(KDP(LD,ND))
257     IF(IDA.EQ.6) GO TO 256
        NFORCE=NFORCE+1
        IF(NFORCE.LE.MXFORC) THEN
          KFORCE(1,NFORCE)=MOTHER(ND)
          DO 258 LD=1,NPDECX
258       KFORCE(LD+1,NFORCE)=KDP(LD,ND)
        ELSE
          WRITE(ITLIS,58) MXFORC
          IFL=1
        ENDIF
256     CONTINUE
      ENDIF
C-- DEFAULT EEFORCE FOR E+E- : 'QUARKS'
      IF(IEVTYP.EQ.5.AND.NACTZ.EQ.0) THEN
        ND1=IDB(INIDCJ(IDZ))
        ND2=ND1+NDECZ-1
        DO 176 ND=ND1,ND2
        NOP=1
        DO 177 LD=1,NPDECX
        IDA=ABS(KDP(LD,ND))
        IF(IDA.GT.NFLAV) GO TO 176
177     IF(IDA.LT.10.AND.IDA.GT.0) NOP=0
        IF(NOP.EQ.0) THEN
          NFORCE=NFORCE+1
          IF(NFORCE.LE.MXFORC) THEN
            KFORCE(1,NFORCE)=MOTHER(ND)
            DO 178 LD=1,NPDECX
178         KFORCE(LD+1,NFORCE)=KDP(LD,ND)
          ELSE
            WRITE(ITLIS,58) MXFORC
            IFL=1
          ENDIF
        ENDIF
176     CONTINUE
      ENDIF
C-- NODECY INHIBITS HEAVYREP
      IF(NODECY.EQ.1) THEN
        KREPET=0
        NREPET=1
      ENDIF
C-- IF KYEVOL=3 SET KYTQCD=3
      IF(KYEVOL.EQ.3) KYTQCD=3
C-- IF FRAMAS(4) OUTSIDE RANGE, RESET IT WITHIN RANGE
      IF(FRAMAS(4).LE.0.) THEN
        WRITE(ITLIS,*)
        WRITE(ITLIS,*)
     &  ' ***BAD RANGE FOR FRAMAS(4): 0. < FRAMAS(4) <= 0.75*CUTJET'
        WRITE(ITLIS,*)
     &  ' -- FRAMAS(4) HAS BEEN RESET TO 1.E-3'
        FRAMAS(4)=1.E-3
      ELSEIF(FRAMAS(4).GT.0.75*QZ) THEN
        WRITE(ITLIS,*)
        WRITE(ITLIS,*)
     &  ' ***BAD RANGE FOR FRAMAS(4): 0. < FRAMAS(4) <= 0.75*CUTJET'
        WRITE(ITLIS,*)
     &  ' -- FRAMAS(4) HAS BEEN RESET TO 0.75*CUTJET'
        FRAMAS(4)=0.75*QZ
      ENDIF
      RETURN
      END
CDECK  ID>, CJROTP.
      SUBROUTINE CJROTP(NPI,NPF,CT,ST,CP,SP)
C     **************************************
C-- ROTATES PARTICLES NPI-NPF INCLUDED
C-- CT, ST = COSINUS AND SINUS OF POLAR ANGLE
C-- CP, SP =    "          "      AZIMUTHAL ANGLE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      IF(NPI.GT.NPF) RETURN
C
      DO 121 IP=NPI,NPF
      P3        =PHEP(3,IP)*CT-PHEP(1,IP)*ST
      PHEP(1,IP)=PHEP(3,IP)*ST+PHEP(1,IP)*CT
      PHEP(3,IP)=P3
      P1        =PHEP(1,IP)*CP-PHEP(2,IP)*SP
      PHEP(2,IP)=PHEP(1,IP)*SP+PHEP(2,IP)*CP
      PHEP(1,IP)=P1
121   CONTINUE
      RETURN
      END
CDECK  ID>, CJRTAB.
      SUBROUTINE CJRTAB
C     *****************
C-- READS PARTICLE LABELS, MASSES, CHARGES AND DECAY MODES FROM TABLE FI
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJMAXN/MNHEP,MNBOOK,MMBOOK,MNRAD,MNCUEV,MNCUEJ
      DIMENSION LDEC(6)
      CHARACTER*8 CHALAB
      CHARACTER*6 PRBEG,DCBEG,XX
      DATA PRBEG,DCBEG/'$PRBEG','$DCBEG'/
C
      ITAB=ABS(ITDKY)
C
C-- LOOK FOR $PRBEG
      LC=0
1     READ(ITAB,2) XX
      LC=LC+1
      IF(LC.GT.1000) GO TO 521
2     FORMAT(A6)
      IF(XX.NE.PRBEG) GO TO 1
C-- READ PARTICLE DATA
10    READ(ITAB,11) ID,IPDG,CHALAB,CHARGP,AM,WIDP,WCP,TIMP
11    FORMAT(2I8,2X,A8,F6.2,3F11.5,F14.5)
      IF(ID.EQ.9999) GO TO 20
      IDA=ABS(ID)
      IF(IDA.EQ.0) GO TO 10
      INTC=INIDCJ(ID)
C-- PARTICLES
      IF(INTC.NE.0) THEN
        IDHEPF(INTC)=ID
        CHAP(INTC)=CHALAB
        LCHARG(INTC)=CHARGP
        IF(PMAS(INTC).LT.1.E-30) PMAS(INTC)=AM
        WIDTHP(INTC)=WIDP
        WCUTP(INTC)=WCP
        CTAU(INTC)=TIMP
        IF(ID.GT.0.OR.ID.EQ.-20) THEN
          KANTIP(INTC)=0
        ELSE
          KANTIP(INIDCJ(-ID))=1
          KANTIP(INTC)=1
        ENDIF
        IF(IDA.EQ.6) THEN
          IF(QMAS(IDA).LT.1.E-30) QMAS(IDA)=AM
          IF(ID.GT.0) THEN
            CHAQ(IDA,1)=CHALAB
          ELSE
            CHAQ(IDA,2)=CHALAB
          ENDIF
          IF(ID.GT.0) CHARGQ(IDA)=CHARGP
        ENDIF
C-- QUARKS
      ELSEIF(IDA.LE.6) THEN
        IF(QMAS(IDA).LT.1.E-30) QMAS(IDA)=AM
        IF(ID.GT.0) THEN
          CHAQ(IDA,1)=CHALAB
        ELSE
          CHAQ(IDA,2)=CHALAB
        ENDIF
        IF(ID.GT.0) CHARGQ(IDA)=CHARGP
C-- GLUON
      ELSEIF(ID.EQ.9) THEN
        CHAGL=CHALAB
        IDGL=ID
C-- DIQUARKS
      ELSEIF(MOD(IDA/10,10).EQ.0) THEN
        K1=IDA/1000
        K2=MOD(IDA/100,10)
        K4=MOD(IDA,10)
        IF(ID.GT.0) THEN
          CHADQ(K1,K2,K4+1,1)=CHALAB
        ELSE
          CHADQ(K1,K2,K4+1,2)=CHALAB
        ENDIF
      ENDIF
      GO TO 10
C-- LOOK FOR $DCBEG
20    LC=0
21    READ(ITAB,2) XX
      LC=LC+1
      IF(LC.GT.1000) GO TO 523
      IF(XX.NE.DCBEG) GO TO 21
C-- READ DECAY DATA
      KERROR=0
      KWARN=0
      WRITE(ITLIS,527)
527   FORMAT(5(/)
     &,' ERROR & WARNING MESSAGES FOR COJETS DECAY TABLE'
     &/' ***********************************************'
     &)
30    KDC=0
      IDL=0
      IFL=0
31    READ(ITAB,*) ID,ME,BR,(LDEC(I),I=1,5)
C-- NEW MOTHER: COMPUTE CBR'S OF PREVIOUS MOTHER
      IF(ID.NE.IDL.AND.IDL.NE.0) THEN
        TBR=0.
        DO 46 I=KDCI,KDC
46      TBR=TBR+CBR(I)
        IF(TBR.NE.0.) THEN
          DO 36 I=KDCI,KDC
          CBR(I)=CBR(I)/TBR
36        IF(I.GT.KDCI) CBR(I)=CBR(I)+CBR(I-1)
          CBR(KDC)=1.
        ENDIF
        ZERO=0.
        IF(ABS(TBR-1.).GT.1.E-5.AND.TBR.NE.ZERO) THEN
          KWARN=KWARN+1
          WRITE(ITLIS,35) IDL,TBR
35    FORMAT(/' ***WARNING:'
     &,' SUM OF BRS FOR',I8,' =',E12.5,' DIFFERENT FROM 1'
     &/' ***EXECUTION CONTINUES WITH BRS NORMALIZED TO SUM=1')
        ENDIF
      ENDIF
      IF(ID.EQ.0) GO TO 40
C-- CHECK DECAY ENTRY
      LDEC(6)=ID
      DO 33 L=1,6
      IF(L.NE.6.AND.LDEC(L).EQ.0) GO TO 33
      IF(INIDCJ(LDEC(L)).NE.0) GO TO 33
      IF(L.EQ.6) GO TO 34
      IDA=ABS(LDEC(L))
      IF(IDA.GT.0.AND.IDA.LE.6) GO TO 33
      IF(IDA.EQ.9) GO TO 33
      ID3=MOD(IDA,100)/10
      IDX=IDA/10000
      IF(ID3.EQ.0.AND.IDX.EQ.0) THEN
        ID1=IDA/1000
        ID2=MOD(IDA,1000)/100
        IF(ID1.GT.0.AND.ID1.LE.6.AND.ID2.GT.0.AND.ID2.LE.6) GO TO 33
      ENDIF
C-- INCORRECT ENTRY IN DECAY TABLE
34    CONTINUE
      KERROR=KERROR+1
      WRITE(ITLIS,512) LDEC(L),ID,ME,BR,(LDEC(L1),L1=1,5)
512   FORMAT(/' ***ERROR: INCORRECT INPUT ',I10,' AT LINE'
     1/1X,2I10,E12.3,5I10)
      IFL=1
33    CONTINUE
C-- CHECK CONSISTENCY FOR DAUGHTER MASSES
      IF(ABS(ID).EQ.80.OR.ABS(ID).EQ.90) GO TO 37
      INID=INIDCJ(ID)
      DIFF=PMAS(INID)
      IFPART=0
      NDIN=0
      DO 41 L=1,5
      IF(LDEC(L).EQ.0) GO TO 41
      NDIN=L
      INID=INIDCJ(LDEC(L))
      IF(INID.NE.0) THEN
        DIFF=DIFF-PMAS(INID)
      ELSE
        IFPART=1
      ENDIF
41    CONTINUE
C-- if no daughters, skip line
      IF(NDIN.EQ.0) GO TO 31
      IF(NDIN.GT.1.AND.DIFF.LE.0.) THEN
        KERROR=KERROR+1
        IFL=1
        WRITE(ITLIS,529) DIFF,ID,ME,BR,(LDEC(L1),L1=1,5)
529   FORMAT(/1X
     &,'***ERROR: (PARENT MASS) - (SUM OF DAUGHTER MASSES) = ',E10.3
     &,' AT LINE'/1X,2I10,E12.3,5I10)
      ELSEIF(IFPART.EQ.1.AND.DIFF.LT.1.) THEN
        KWARN=KWARN+1
        WRITE(ITLIS,530) DIFF,ID,ME,BR,(LDEC(L1),L1=1,5)
530   FORMAT(/1X
     &,'***WARNING: (PARENT MASS) - (SUM OF PARTICLE MASSES) = ',E10.3
     &,' < 1. GEV AT LINE'/1X,2I10,E12.3,5I10/1X
     &,'***ERRORS MAY BE GENERATED DURING QUARK STRING HADRONIZATION')
      ENDIF
37    CONTINUE
C-- CHECK FOR CHARGE BALANCE
      CHARGT=CHRGCJ(ID)
      DO 42 L=1,5
      IF(LDEC(L).EQ.0) GO TO 42
      CHARGT=CHARGT-CHRGCJ(LDEC(L))
42    CONTINUE
      IF(ABS(CHARGT).GT..1) THEN
        KWARN=KWARN+1
        WRITE(ITLIS,540) CHARGT,ID,ME,BR,(LDEC(L1),L1=1,5)
540   FORMAT(/1X
     &,'***WARNING: (PARENT CHARGE) - (SUM OF DAUGHTER CHARGES) = '
     &,E10.3,' AT LINE'/1X,2I10,E12.3,5I10)
      ENDIF
C-- ENTRY ACCEPTED
      KDC=KDC+1
      IF(KDC.GT.MAXDEC) GO TO 513
C-- SET IDB WHEN FIRST APPEARANCE OF MOTHER
      IF(ID.NE.IDL) THEN
        IDL=ID
        INTC=INIDCJ(ID)
        IDB(INTC)=KDC
        IF(KANTIP(INTC).EQ.1) IDB(INIDCJ(-ID))=KDC
        KDCI=KDC
        KDINS=KDC
      ELSE
        KDINS=KDCI
        DO 43 KDR=KDC-1,KDCI,-1
        IF(BR.LT.CBR(KDR)) THEN
          KDINS=KDR+1
          GO TO 44
        ENDIF
43      CONTINUE
44      CONTINUE
      ENDIF
C-- ORDER DECAY CHANNELS FOR DECREASING BR
      IF(KDINS.LT.KDC) THEN
        DO 45 KDR=KDC,KDINS+1,-1
        MOTHER(KDR)=MOTHER(KDR-1)
        MATRX(KDR)=MATRX(KDR-1)
        CBR(KDR)=CBR(KDR-1)
        DO 45 L=1,NPDECX
        KDP(L,KDR)=KDP(L,KDR-1)
45      CONTINUE
      ENDIF
      MOTHER(KDINS)=ID
      MATRX(KDINS)=ME
      CBR(KDINS)=BR
      DO 32 L=1,NPDECX
32    KDP(L,KDINS)=LDEC(L)
      GO TO 31
C-- EXIT
40    NDECT=KDC
      CLOSE(ITAB)
      WRITE(ITLIS,528) KERROR,KWARN
528   FORMAT(/' # ERRORS =',I5,'   # WARNINGS =',I5,5(/))
      IF(IFL.GT.0) GO TO 525
      RETURN
C
C-- ABNORMAL EXIT
513   WRITE(ITLIS,514) MAXDEC
514   FORMAT(5(/),' ***NO. OF DECAY CHANNELS FOUND WHILE READING'
     1,' DECAY DATA TABLE EXCEEDS ',I10
     3/' ***INCREASE MAXDEC'
     4/' ***JOB ABORT')
      STOP
521   WRITE(ITLIS,522)
522   FORMAT(5(/),' ***ERROR IN THE DATA TABLE FILE'
     1/' ***SET LINE WITH $PRBEG, LEFT ADJUSTED, IMMEDIATELY BEFORE'
     2,' BEGINNING OF PARTICLE PARAMETER DATA'
     3/' ***JOB ABORT')
      STOP
523   WRITE(ITLIS,524)
524   FORMAT(5(/),' ***ERROR IN THE DATA TABLE FILE'
     1/' ***SET LINE WITH $DCBEG, LEFT ADJUSTED, IMMEDIATELY BEFORE'
     2,' BEGINNING OF PARTICLE DECAY DATA'
     3/' ***JOB ABORT')
      STOP
525   WRITE(ITLIS,526)
526   FORMAT(/' ***JOB ABORT')
      STOP
      END
CDECK  ID>, CJSTAB.
      SUBROUTINE CJSTAB
C     *****************
C-- REDUCES PARTICLE STREAM TO STABLE PARTICLES ONLY
C-- JMOHEP SET TO 0
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      IF(NHEP.EQ.0) RETURN
      IP=0
      DO 1 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 1
      IP=IP+1
      DO 2 J=1,5
2     PHEP(J,IP)=PHEP(J,I)
      IDHEP(IP)=IDHEP(I)
      JMOHEP(1,IP)=0
      JMOHEP(2,IP)=0
      JDAHEP(1,IP)=0
      JDAHEP(2,IP)=0
      ISTHEP(IP)=1
1     CONTINUE
      NHEP=IP
      RETURN
      END
CDECK  ID>, CJTBK1.
      SUBROUTINE CJTBK1(IBOOK,IFLA1,TPSQ1,X1T,PX1T,PY1T,IBOOK1)
C     *********************************************************
C-- BOOKS TIMELIKE PARTONS GENERATED BY CJEVOL
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      MBK=MBOOK(IBEAM)
      MBK=MBK+1
      IF(MBK.GT.MXSPE) GO TO 500
      MBOOK(IBEAM)=MBK
      IBOOK1=MBK
      PARSPE(MBK,1,IBEAM)=PX1T
      PARSPE(MBK,2,IBEAM)=PY1T
      PARSPE(MBK,3,IBEAM)=X1T*ECM
      PARSPE(MBK,4,IBEAM)=IBOOK
      PARSPE(MBK,5,IBEAM)=-TPSQ1
      PARSPE(MBK,6,IBEAM)=IFLA1
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) MXINQ,NEVOL
501   FORMAT(5(/),' ***NUMBER OF INITIAL STATE PARTONS EXCEEDS',I10
     1 //' ***CASCADE NO. =',I10,'  IN CJTBK1'
     3 //' ***INCREASE MXINQ'
     2 //' ***JOB ABORT'
     5 )
      STOP
      END
CDECK  ID>, CJTBK2.
      SUBROUTINE CJTBK2(IFLAS,QSQS,XS,PXS,PYS)
C     ****************************************
C--  SUPPLEMENTS CJTBK1 FOR SPACELIKE PARTONS (USED FOR HISTORY)
C--  PARACT(MBKS, , ) FOR MBKS.GT.1 USED FOR STORAGE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      MBK=MBOOK(IBEAM)
      MBKS=MBK+1
      PARACT(MBKS,1,IBEAM)=PXS
      PARACT(MBKS,2,IBEAM)=PYS
      PARACT(MBKS,3,IBEAM)=XS*ECM
      PARACT(MBKS,5,IBEAM)=-SQRT(QSQS)
      PARACT(MBKS,6,IBEAM)=IFLAS
      RETURN
      END
CDECK  ID>, CJTDCY.
      SUBROUTINE CJTDCY(NTOP,IDC)
C     ***************************
C-- DECAYS TOP PSEUDOSCALAR PARTICLES WITH POSITION NTOP IN
C-- PARTICLE STREAM INTO IDC DECAY CHANNEL (INTERNAL CODING)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
C-- Set NDFORC = NPDECX +1, and look for formats applying to KFORCE
      PARAMETER (NDFORC=6,MXFORC=100)
      COMMON/CJFORC/NFORCE,KFORCE(NDFORC,MXFORC),NSTOPD,KSTOPD(352)
      COMMON/CJIFAI/IFAIL,IFLGHV,NHVREJ
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION NTOPD(3),LKDP(3)
      DIMENSION V1(4),V2(4),PBOOST(4)
      PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
C
      IF(ISTHEP(NTOP).NE.1) RETURN
      KEYBRL=KYEVOL
      IRADLL=KYWQED
      KYEVOL=KYTQCD
      KYWQED=KYTQED
C
C-- TOP PRIMARY DECAY ID'S (KINEMATICS DEALT WITH LATER)
      DO 100 LD=1,3
      NHEP=NHEP+1
      IF(NHEP+3.GT.NMXHEP) GO TO 500
100   NTOPD(LD)=NHEP
C-- CHARGE CONJUGATE DECAY PRODUCTS, WHEN NECESSARY
      IDTOP=IDHEP(NTOP)
      ISTM=SIGN(1,IDTOP*MOTHER(IDC))
      DO 101 LD=1,3
101   LKDP(LD)=ISTM*KDP(LD,IDC)
      IST=SIGN(1,IDTOP)
C-- PICK UP BOTTOM PARTON
      DO 102 LD=1,3
      IF(IST*LKDP(LD).NE.5) GO TO 102
      IDHEP(NTOPD(3))=LKDP(LD)
      LKDP(LD)=0
      GO TO 103
102   CONTINUE
C-- PICK UP "W" DECAY PRODUCTS (FOR W+, "PARTICLE" FIRST)
103   DO 104 LD=1,3
      IF(IST*LKDP(LD).GT.0) THEN
        IDHEP(NTOPD(1))=LKDP(LD)
        LKDP(LD)=0
      ELSEIF(IST*LKDP(LD).LT.0) THEN
        IDHEP(NTOPD(2))=LKDP(LD)
        LKDP(LD)=0
      ENDIF
104   CONTINUE
C-- CHECK DECAY ENTRY
      IF(LKDP(1)+LKDP(2)+LKDP(3).NE.0) THEN
        WRITE(ITLIS,512) MOTHER(IDC),CBR(IDC),(KDP(LD,IDC),LD=1,NPDECX)
512     FORMAT(5(/),1X,'***INCORRECT INPUT IN DECAY DATA TABLE'
     &  ,' AT LINE'/1X,I10,E12.3,9I10
     &  /1X,'(CHECK MADE IN SUBROUTINE CJTDCY)'
     &  /1X,'***JOB ABORT')
        STOP
      ENDIF
C
C-- DECAY TOPOLOGY
C-- WORKING REF. FRAME IS VIRTUAL 'W' REST FRAME
C-- PHASE SPACE AND MATRIX ELEMENT FACTORS TREATED IN THE APPROXIMATION
C-- OF MASSLESS 'W' DECAY LEPTONS/QUARKS AND B-JET MASS GIVEN BY QCD
C-- RADIATION ONLY
C-- GENERATE 'W' MASS
      TMASS=PHEP(5,NTOP)
      ID1=IDHEP(NTOPD(1))
      ID2=IDHEP(NTOPD(2))
      IF(ABS(ID1).GE.10) THEN
        WMIN=AMASCJ(ID1)+AMASCJ(ID2)+.5
      ELSE
        WMIN=QZFL(ABS(ID1))+QZFL(ABS(ID2))
      ENDIF
      WPHSPX=PAWT(TMASS,WMIN,QZFL(5))
      WMATX=TMASS**4/16.
      ADRMIN=ATAN((WMIN**2-WMASS**2)/(WMASS*WGAMMA))
      ADRMAX=ATAN(((TMASS-QZFL(5))**2-WMASS**2)/(WMASS*WGAMMA))
11    DR=TAN((ADRMAX-ADRMIN)*RNCJ(0.)+ADRMIN)
      WVRM=SQRT(DR*WMASS*WGAMMA+WMASS**2)
C-- GENERATE B JET VIRTUALITY FOR PHASE SPACE, MATRIX ELEMENT CALCS.
C-- (ACTUAL B JET MASS, FOR KINEMATICS, CALCULATED AFTER FRAGMENTATION)
      XQSQB=(TMASS-WVRM)**2
      CALL CJQTGE(5,XQSQB,QSQB,IGO)
      BJMASS=SQRT(QSQB)
      IF(WVRM+BJMASS.GE.TMASS) GO TO 11
C-- MODULATION BY PHASE SPACE FACTOR
      PBTCM=PAWT(TMASS,WVRM,BJMASS)
      WPHSP=PBTCM
      IF(RNCJ(0.)*WPHSPX.GT.WPHSP) GO TO 11
C-- MODULATION BY MATRIX ELEMENT ('W' REST FRAME)
      PB=PBTCM*TMASS/WVRM
      PBSQ=PB**2
      EB=SQRT(BJMASS**2+PBSQ)
      ET=SQRT(TMASS**2+PBSQ)
      CTHWRF=-1.+2.*RNCJ(0.)
      WMAT=WVRM**2/4.*(ET+PB*CTHWRF)*(EB-PB*CTHWRF)
      IF(RNCJ(0.)*WMATX.GT.WMAT) GO TO 11
C
C-- HANDLE 'W' DECAY
      IF(ABS(IDHEP(NTOPD(1))).GT.9) THEN
C-- LEPTONIC DECAYS
        CALL CJBLEP(0,NTOP,0,WVRM,NTOPD(1),NTOPD(2),CTHWRF,0)
        JDAHEP(1,NTOP)=NTOPD(1)
        JDAHEP(2,NTOP)=NHEP
        ISTHEP(NTOP)=2
      ELSE
C-- TWO JET DECAYS
        CALL CJBJET(0,NTOP,0,WVRM,NTOPD(1),NTOPD(2),CTHWRF,0)
        IF(IFLGHV.EQ.1) RETURN
        IF(IFAIL.EQ.1) RETURN
        JDAHEP(1,NTOP)=NTOPD(1)
        JDAHEP(2,NTOP)=NTOPD(3)
        ISTHEP(NTOP)=2
      ENDIF
C
C-- HANDLE B JET
      PHEP(1,NTOPD(3))=0.
      PHEP(2,NTOPD(3))=0.
      PHEP(3,NTOPD(3))=PB
      PHEP(4,NTOPD(3))=EB
      PHEP(5,NTOPD(3))=SQRT(QSQB)
      JMOHEP(1,NTOPD(3))=NTOP
      JMOHEP(2,NTOPD(3))=0
      JDAHEP(1,NTOPD(3))=0
      JDAHEP(2,NTOPD(3))=0
      ISTHEP(NTOPD(3))=1
      NHEPB=NHEP+1
      NJB1=NHEP+1
      CALL CJJETQ(NTOPD(3))
      NJB2=NHEP
      NHEPF=NHEP
      IF(NOFRGM.EQ.0) CALL CJHADR(NTOPD(3),NHEPF,0)
C-- MASS OF HADRONIZED B JET
      DO 19 J=1,4
      V1(J)=0.
      DO 19 I=NHEPB,NHEP
19    IF(ISTHEP(I).EQ.1) V1(J)=V1(J)+PHEP(J,I)
      BJHMAS=SQRT(ABS(V1(4)**2-V1(1)**2-V1(2)**2-V1(3)**2))
C-- ALIGN B-JET ALONG 3RD AXIS
      IF(NJB2.LT.NJB1) GO TO 20
      IF(V1(2).EQ.0..AND.V1(1).EQ.0) THEN
        PHIP=0.
      ELSE
        PHIP=ATAN2(V1(2),V1(1))
      ENDIF
      CP=COS(PHIP)
      SP=SIN(PHIP)
      SP=-SP
      PMT2=V1(1)**2+V1(2)**2
      PMT=SQRT(PMT2)
      PM=SQRT(PMT2+V1(3)**2)
      CT=V1(3)/PM
      ST=PMT/PM
      ST=-ST
      NHEPF=NHEP
      CALL CJROTP(NJB1,NHEPF,CT,ST,CP,SP)
20    CONTINUE
C
C-- SET FINAL KINEMATICS
      EBF=EB
      PBF=SQRT(ABS(EBF**2-BJHMAS**2))
      ETF=SQRT(TMASS**2+PBF**2)
C-- BOOST BACK TO TOP REST FRAME
C-- ARBITRARY PHI, COS(THETA) ROTATION IN TOP REST FRAME
C-- FINAL BOOST TO LABORATORY (TOP MOMENTUM)
      CHR= ETF/TMASS
      SHR=-PBF/TMASS
      CT=-1.+2.*RNCJ(0.)
      ST=SQRT(ABS(1.-CT**2))
      PHIP=PI2*RNCJ(0.)
      CP=COS(PHIP)
      SP=SIN(PHIP)
      DO 21 J=1,4
21    PBOOST(J)=PHEP(J,NTOP)
      NEW=1
      DO 22 IP=NTOPD(1),NHEP
      DO 23 J=1,4
23    V1(J)=PHEP(J,IP)
      ER   =V1(4)*CHR+V1(3)*SHR
      V1(3)=V1(4)*SHR+V1(3)*CHR
      V1(4)=ER
      P3   =V1(3)*CT-V1(1)*ST
      V1(1)=V1(3)*ST+V1(1)*CT
      V1(3)=P3
      P1   =V1(1)*CP-V1(2)*SP
      V1(2)=V1(1)*SP+V1(2)*CP
      V1(1)=P1
      CALL CJLOR4(PBOOST,V1,V2,NEW)
      NEW=0
      DO 24 J=1,4
24    PHEP(J,IP)=V2(J)
C-- VHEP
22    CONTINUE
C
C-- EXIT
120   KYEVOL=KEYBRL
      KYWQED=IRADLL
      RETURN
C
C-- ABNORMAL EXIT
500   WRITE(ITLIS,501) NMXHEP,NEVGEN+1
501   FORMAT(5(/),' ***NUMBER OF PARTICLES EXCEEDS',I10
     1//' ***IN SUBROUTINE CJTDCY'
     1//' ***EVENT NO. =  ',I10
     3//' ***INCREASE NMXHEP'
     4)
      CALL CJOVER
      RETURN
      END
CDECK  ID>, CJTEVO.
      SUBROUTINE CJTEVO(IACT1,IACT2)
C     ******************************
C-- BOOKS INITIAL CASCADES
C-- HANDLES EVOLUTION OF TIMELIKE PARTONS DUE TO INITIAL RADIATION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJENTR/S,QSQ,YQSQ,XING(2),XMING(2)
     &,PXING(2),PYING(2),IFLING(2),ICHING(2),IPACH
      PARAMETER (MXINQ=150)
      COMMON/CJEVLC/PARACT(MXINQ,9,2),PARSPE(MXINQ,6,2)
     &,IBEAM,NBOOK(2),JBOOK,MBOOK(2),MXSPE
     &,NEVOL,ISTOP(2),IBACK(2)
     &,ICANC(2),NBKCNC(MXINQ,2),NENT2(MXINQ)
      COMMON/CJINMA/XIN(2),PXIN(2),PYIN(2),TPRETB
     &,IFLAIN(2),IMATCH(7,7),IMATBO(7,7),NKINPT
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
C-- LOOP ON THE TWO PARTON CASCADES
      IB=1
100   CONTINUE
C-- PRELIMINARIES
      IF(NHEP+1.GT.NMXHEP) GO TO 560
      JDAHEP(1,NHEP+1)=0
      JDAHEP(2,NHEP+1)=0
      IF(IB.EQ.1) IACT1=NHEP+1
      IF(IB.EQ.2) IACT2=NHEP+1
C...Pick up from 1st PARACT (special use) position MBK in PARSPE of
C...timelike parton which is sister of terminal (interactive) spacelike
C...parton. Information on the latter is stored in PARACT at position
C...MBK+1.
      MBK=PARACT(1,2,IB)
      MBKS=MBK+1
5     IF(MBK.EQ.0) GO TO 8
C-- PAIR OF SPACELIKE AND TIMELIKE SISTERS
      NHEPS=NHEP+1
      NHEPT=NHEP+2
      NHEP=NHEP+2
      IF(NHEP+2.GT.NMXHEP) GO TO 560
C-- BOOK SPACELIKE PARTON
      PHEP(1,NHEPS)=PARACT(MBKS,1,IB)
      PHEP(2,NHEPS)=PARACT(MBKS,2,IB)
      PHEP(5,NHEPS)=PARACT(MBKS,5,IB)
      PMT2=PHEP(1,NHEPS)**2+PHEP(2,NHEPS)**2
      EPP=PARACT(MBKS,3,IB)
      EPM=PMT2/EPP
      IF(IB.EQ.1) THEN
        PHEP(3,NHEPS)= .5*(EPP-EPM)
      ELSE
        PHEP(3,NHEPS)=-.5*(EPP-EPM)
      ENDIF
      PHEP(4,NHEPS)=.5*(EPP+EPM)
      ISTHEP(NHEPS)=2
      IDHEP(NHEPS)=JDENCJ(INT(PARACT(MBKS,6,IB)))
C...JDAHEP(,NHEPS), JMOHEP(,NHEPS) set elsewhere
      DO 11 J=1,4
11    VHEP(J,NHEPS)=0.
C-- BOOK TIMELIKE PARTON
      PHEP(1,NHEPT)=PARSPE(MBK,1,IB)
      PHEP(2,NHEPT)=PARSPE(MBK,2,IB)
      EPP=PARSPE(MBK,3,IB)
      IFLA=PARSPE(MBK,6,IB)
      PSQX=ABS(PARSPE(MBK,5,IB))
      CALL CJQTGE(IFLA,PSQX,PSQ,IGO)
      AMT2=PHEP(1,NHEPT)**2+PHEP(2,NHEPT)**2+PSQ
      EPM=AMT2/EPP
      IF(IB.EQ.1) THEN
        PHEP(3,NHEPT)= .5*(EPP-EPM)
      ELSE
        PHEP(3,NHEPT)=-.5*(EPP-EPM)
      ENDIF
      PHEP(4,NHEPT)=.5*(EPP+EPM)
      PHEP(5,NHEPT)=SQRT(PSQ)
      IF(KYEVOL.LT.2) THEN
        ISTHEP(NHEPT)=1
      ELSE
        ISTHEP(NHEPT)=2
      ENDIF
      IDHEP(NHEPT)=JDENCJ(IFLA)
C...JMOHEP(,NHEPT) set elsewhere
      JDAHEP(1,NHEPT)=0
      JDAHEP(2,NHEPT)=0
      DO 12 J=1,4
12    VHEP(J,NHEPT)=0.
C...Develop timelike parton shower off timelike sister (NHEP changed
C...in CJJETQ)
      CALL CJJETQ(NHEPT)
C--  BOOK S MOTHER --> S DAUGHTER + T DAUGHTER RELATIONSHIP
      NHEPMO=NHEP+1
      IF(NHEP+1.GT.NMXHEP) GO TO 560
      JMOHEP(1,NHEPS)=NHEPMO
      JMOHEP(2,NHEPS)=0
      JMOHEP(1,NHEPT)=NHEPMO
      JMOHEP(2,NHEPT)=0
      JDAHEP(1,NHEPMO)=NHEPS
      JDAHEP(2,NHEPMO)=NHEPT
C
C-- GO RECURSIVELY ONE STEP BACKWARD
      MBK=PARSPE(MBK,4,IB)
      MBKS=MBK+1
      GO TO 5
C
8     CONTINUE
C--  INITIAL S PARTON (from /CJENTR/)
      NHEP=NHEP+1
      IF(NHEP.GT.NMXHEP) GO TO 560
      PHEP(1,NHEP)=PXING(IB)
      PHEP(2,NHEP)=PYING(IB)
      PHEP(5,NHEP)=-QZEVOL
      PMT2=PHEP(1,NHEP)**2+PHEP(2,NHEP)**2
      EPP=XING(IB)*ECM
      EPM=PMT2/EPP
      IF(IB.EQ.1) THEN
        PHEP(3,NHEP)= .5*(EPP-EPM)
      ELSE
        PHEP(3,NHEP)=-.5*(EPP-EPM)
      ENDIF
      PHEP(4,NHEP)=.5*(EPP+EPM)
      ISTHEP(NHEP)=2
      IDHEP(NHEP)=JDENCJ(IFLING(IB))
      JMOHEP(1,NHEP)=0
      JMOHEP(2,NHEP)=0
      DO 13 J=1,4
13    VHEP(J,NHEP)=0.
C-- LOOP BACK TO SECOND PARTON CHAIN
      IB=IB+1
      IF(IB.GT.2) RETURN
      GO TO 100
C
C-- ABNORMAL EXIT
560   WRITE(ITLIS,561) NMXHEP
561   FORMAT(5(/),' ***NHEP EXCEEDS',I10,' (CJTEVO)'
     1 //' ***INCREASE NMXHEP'
     2 //' ***JOB ABORT'
     5 )
      STOP
      END
CDECK  ID>, CJTHRS.
      SUBROUTINE CJTHRS(IFRW,NHEPI,NHEPF)
C     ***********************************
C-- ALIGNS THRUST AXIS ALONG POSITIVE Z AXIS
C-- IFRW CLOSER TO POSITIVE DIRECTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION PTHRST(3),PTHL(3)
C
      DATA ERRMAX/1.E-3/,NITERX/100/
C
      IF(NHEPI.GT.NHEPF) RETURN
C
C-- FIND THRUST AXIS
      CTL=1.
      CPL=1.
      SPL=0.
      PTHL(1)=0.
      PTHL(2)=0.
      PTHL(3)=1.
      NITER=0
10    CONTINUE
      NITER=NITER+1
      DO 11 J=1,3
11    PTHRST(J)=0.
      DO 12 I=NHEPI,NHEPF
      IF(ISTHEP(I).NE.1) GO TO 12
      CS=PTHL(1)*PHEP(1,I)+PTHL(2)*PHEP(2,I)
     *  +PTHL(3)*PHEP(3,I)
      IF(CS.LT.0.) GO TO 12
      DO 13 J=1,3
13    PTHRST(J)=PTHRST(J)+PHEP(J,I)
12    CONTINUE
      PT2=PTHRST(1)**2+PTHRST(2)**2
      IF(PT2.LE.0.) THEN
        CT=CTL
        ST=SQRT(ABS(1.-CT**2))
        CP=CPL
        SP=SPL
        GO TO 20
      ENDIF
      PT=SQRT(PT2)
      PP=SQRT(PTHRST(3)**2+PT2)
      CT=PTHRST(3)/PP
      ST=SQRT(ABS(1.-CT**2))
      CP=PTHRST(1)/PT
      SP=PTHRST(2)/PT
      IF(ABS(CT-CTL).LT.ERRMAX.AND.ABS(SP-SPL).LT.ERRMAX
     *.AND.ABS(CP-CPL).LT.ERRMAX) GO TO 20
      IF(NITER.GT.NITERX) GO TO 20
      CTL=CT
      CPL=CP
      SPL=SP
      DO 14 J=1,3
14    PTHL(J)=PTHRST(J)
      GO TO 10
C
C-- ROTATE
20    CONTINUE
C-- IF IFRW COMES CLOSE TO NEGATIVE DIRECTION, REFLECTION
      CS=PHEP(1,IFRW)*PTHRST(1)+PHEP(2,IFRW)*PTHRST(2)
     &  +PHEP(3,IFRW)*PTHRST(3)
      IF(CS.LT.0.) THEN
        CT=-CT
        CP=-CP
        SP=-SP
      ENDIF
      CALL CJROTP(NHEPI,NHEPF,CT,ST,CP,SP)
C
      RETURN
      END
CDECK  ID>, CJTLFT.
      SUBROUTINE CJTLFT(TLEFT)
C     ************************
C-- GIVES TIME LEFT FOR EXECUTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      REAL TLE
      TLE=3.E6
      TLEFT=TLE
      RETURN
      END
CDECK  ID>, CJWANG.
      SUBROUTINE CJWANG(IQRKFW,IPD,IPD1,IPD2,COSROT)
C     **********************************************
C-- GENERATES V-A COSROT=COS(THETA) IN W DECAYS
C-- THETA IS ANGLE BETWEEN FINAL QUARK, OR NEGATIVE LEPTON, OR NEUTRINO
C-- AND INITIAL QUARK
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
C
      IDA1=ABS(IDHEP(IPD1))
      IDA2=ABS(IDHEP(IPD2))
      IF(IDA1.EQ.6.OR.IDA2.EQ.6) THEN
        PCM=ABS(PHEP(IPD1,3))
        E1=PHEP(4,IPD1)
        E2=PHEP(4,IPD2)
        AM2X=(E1+PCM)*(E2+PCM)
2       C=-1.+2.*RNCJ(0)
        AM2=(E1+PCM*C)*(E2+PCM*C)
        IF(AM2X*RNCJ(0).GT.AM2) GO TO 2
      ELSE
        C=2.*RNCJ(0)**(1./3.)-1.
      ENDIF
C
      IF(IQRKFW.LT.0) C=-C
      IF(IDHEP(IPD).EQ.IDWM) C=-C
      COSROT=C
C
      RETURN
      END
CDECK  ID>, CJWDEC.
      SUBROUTINE CJWDEC(S,XMW,XM,XGWTOT,ALFA,Q0,QE,QN,QK)
C     ***************************************************
C-- MODIFICATIONS: S,XMW,XM,XGWTOT,ALFA,Q0 GIVEN AS INPUT PARAMETERS
C--                COMMON BLOCK /PRMSWD/ ELIMINATED
C------------------------------------------------------------
C LEPTONIC DECAY OF W- BOSON PRODUCED FROM Q QBAR PAIR
C
C     AUTHORS    F.A.BERENDS AND R.KLEISS
C
C    INFORMATION ON THIS PROGRAM IS FOUND IN
C    F.A. BERENDS AND R. KLEISS, "HARD PHOTON CORRECTIONS IN
C    W AND Z DECAY ", LEIDEN UNIVERSITY PREPRINT (1983).
C    PLEASE REFER TO THIS PAPER WHEN USING THIS PROGRAM |
C
C
C PARAMETERS: S (CM ENERGY OF LEPTON PAIR SQUARED IN GEV**2);
C             XM (LEPTON MASS IN GEV)
C             XMW,XGWTOT (W MASS AND WIDTH IN GEV)
C THESE PARAMETERS MUST BE SUPPLIED IN THE COMMON 'PRMSWD'
C-----------------------------------------------------------
C IT IS ASSUMED THAT THE QUARKS ARE IN THEIR CMS SYSTEM.
C INITIAL STATE CORRECTIONS LIKE SOFT GLUON EMISSION ARE
C NOT INCLUDED.
C THE EFFECT OF THE CABIBBO ANGLE IS INCLUDED.
C THE MASS AND WIDTH OF THE W ARE ASSUMED TO BE RELATED
C TO EACH OTHER BY THE SIMPLE WEINBERG-SALAM RULE; THIS
C IS A VERY GOOD APPROXIMATION AS SHOWN BY CONSOLI ET AL.
C THE COUPLING CONSTANTS OF THE LEPTONS ARE DEFINED TO
C BE SUCH THAT THEY YIELD PRECISELY THE GIVEN LEPTONIC
C WIDTH IF WE NEGLECT THE (VERY TINY) COMPLETE QED EFFECT.
C IN ORDER TO GET THE EVENT SAMPLE FOR W+ EVENTS, ALL
C FOUR-MOMENTA ARE TO BE INVERTED (EXCEPT THE ENERGIES,
C OF COURSE), AND ALL PARTICLES RELABELLED AS THEIR
C ANTIPARTICLES.
C--------------------------------------------------------CJWDEC.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION RNCJ
      DOUBLE PRECISION S,XMW,XM,XGWTOT,ALFA,Q0,QE,QN,QK
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      DIMENSION QE(4),QN(4),QK(4)
C     DATA INITI /0/
C     IF(INITI.NE.0) GOTO 1000
C----------------------------------- INITIALIZATION STEP ---
C     INITI=1
      DATA SOLD/0.D0/
      IF(ABS(S-SOLD).LT..01) GO TO 1000
      SOLD=S
C SOME CONSTANTS
      EB=SQRT(S)/2.
C--      ALFA INITIALIZED BY COMMON
      PIG=3.1415926536D0
      BARN=3.8937D+05/EB**2
      XM2=(XM/EB)**2
      XL=LOG(4./XM2)
      XK0=Q0/EB
C SOME CONSTANTS CONNECTED WITH W BOSON
      XMU=37.281D0
      SINW=XMU/XMW
      XGW=ALFA/12.*XMW**3/XMU**2
      XGCOR=1.+ALFA/PIG*(77./24D0-PIG**2/3.D0)
      XGW=XGW*XGCOR
      FRHARD=ALFA/PIG*(LOG(1./XK0)*(XL-2.)
     .  -3./4.*XL - PIG**2/6.D0 + 53./24.D0)
      FRHARD=FRHARD/XGCOR
C FERMION COUPLING CONSTANTS TO  W
C REMEMBER SUPPRESSION OF QUARK COUPLING BY
C THE COSINE OF THE CABIBBO ANGLE
      EQED=SQRT(4.*PIG*ALFA)
      GL=EQED/SQRT(8.)/SINW
      GQ=GL*0.973D0
C
C     WRITE(ITLIS,1)
    1 FORMAT(1H0,90(1H-),/,
     . 29H0 THIS IS ROUTINE ''CJWDEC''  )
C LOWEST ORDER CROSS SECTION
      W2=16.*((1.-XMW/S)**2 + (XMW*XGWTOT/S)**2)
      SIG0=1./(3.*PIG)
     .    *(GL*GQ)**2
     .    *4./W2
     .    *BARN
C
C     WRITE(ITLIS,2)      S,   XMW,    XM,XGWTOT,    EB,  ALFA,
C    .            PIG,  BARN,   XM2,    XL,   XK0,   XMU,
C    .          SINW, XGCOR,   XGW,FRHARD,  EQED,    GL,
C    .            GQ,    W2,  SIG0
    2 FORMAT(1H0,6D15.6)
C     WRITE(ITLIS,21) XMW,XGWTOT,XGW,SIG0,XK0,FRHARD
   21 FORMAT(1H0,90(1H-),/,
     . 39H MASS OF W- BOSON                     =,F15.6,4H GEV,/,
     . 39H TOTAL WIDTH OF W- BOSON              =,F15.6,4H GEV,/,
     . 39H LEPTONIC WIDTH (+ QED CORRECTION)    =,F15.6,4H GEV,/,
     . 39H LOWEST ORDER PRODUCTION CROSSECTION  =,D15.6,3H NB,/,
     . 36H MINIMUM ENERGY OF ''HARD'' PHOTONS ,/,
     . 39H IN FRACTIONS OF SQRT(S)/2            =,F15.6,/,
     . 39H FRACTION OF HARD BREMSSTRAHLUNG      =,F15.6)
C------------------------------ END OF INITIALIZATION -----------
 1000 CONTINUE
C------------------------------ GENERATION STEP -----------------
C CHOOSE BETWEEN HARD OR SOFT
      IF(RNCJ(1.).LT.FRHARD) GOTO 2000
C----------------------------- START OF SOFT PART -----------------
C GENERATE ANGLES
      CN=1.-2.*RNCJ(2.)**(1./3.D0)
      SN=SQRT(1.-CN*CN)
C CONSTRUCT MOMENTA WITHOUT NORMALIZATION AND TRIVIAL ROTATION
      QN(4)=1.
      QN(3)=CN
      QN(2)=0.
      QN(1)=SN
      QE(4)=1.
      QE(3)=-CN
      QE(2)=0.
      QE(1)=-SN
      DO 3 I=1,4
    3 QK(I)=0.
      GOTO 3000
C----------------------------- END OF SOFT PART -------------------
 2000 CONTINUE
C----------------------------- START OF HARD PART -----------------
C GENERATE VALUES FOR XK AND V1 USING APPROXIMATION
    4 XK=XK0**RNCJ(3.)
      XKM=1.-XK
      V1=XK*(XM2/(4.*XKM))**RNCJ(4.)
C DEFINE F1 AS FOUR TIMES FI(1) OF NOTES
      F1=(4. - 4.*XK + 4.*V1 + 2.*XK**2 - 6.*XK*V1 + 8.*V1**2)/(XK*V1)
     .  -XM2/V1**2
     .  -4.*(1.+V1**2)/XK**2
C REJECT UNTIL V1 AND K ACCEPTED
      WKV=XK*V1/4.*F1
      IF(WKV.LT.2.D0*RNCJ(5.)) GOTO 4
C
C TAKE RANDOM VALUES FOR CN AND FG
    5 CN=-1.+2.*RNCJ(6.)
      FG=2.*PIG*RNCJ(7.)
      SN=SQRT(1.-CN*CN)
      CFG=COS(FG)
C CALCULATE VARIOUS DOT-PRODUCTS
      VG=2.*V1*(1.-XK)/(XK*(1.-V1))
      CG=VG-1.
      SG=SQRT(VG*(2.-VG))
      Z= CN*CG + SN*SG*CFG
      V=1.-V1
      QQ=4.
      QPU=2.
      QPD=2.
      QPN=2.*V
      QKK=2.*XK
      QPE=QQ-QPN-QKK
      PUPN=V*(1.+CN)
      PDPN=V*(1.-CN)
      PUK =XK*(1.+Z)
      PDK =XK*(1.-Z)
      PUPE=QPU-PUPN-PUK
      PDPE=QPD-PDPN-PDK
      PEK =2.*V1
      PNK =2.*(XK-V1)
      PEPN=2.*XKM
C CALCULATE MULTIDIFFERENTIAL DISTRIBUTION
C     YB= -XM2*PDPN**2/PEK**2
C    . +( PDPN*( QQ/2.*(PUPE+PUK) + PUPE*QPE
C    .            -PEK*(QPU +PUK)            )
C    .   +PUPE*( PEPN*PDK - PDPE*PNK         ) )/(PEK*QKK)
C    . +( PDPN*( -QQ*PUPE - PUK*QPE + PEK*QPU + PUK*PEK)
C    .   +PUPE*(  QPD*PNK - QPN*PDK + PDK*PNK          ))/QKK**2
      YB= -XM2*PDPN**2/PEK**2
     . + QQ*PNK/(2.*QKK**2*PEK)*(PUPE**2+PDPN**2)
C CALCULATE WEIGHT: REJECT UNTIL ANGLES ACCEPTED
      WANGL=YB/F1
      IF(WANGL.LT.2.D0*RNCJ(8.)) GOTO 5
C
C CONSTRUCT MOMENTA UNNORMALIZED AND UNROTATED
      QN(4)=V
      QN(3)=V*CN
      QN(2)=0.
      QN(1)=V*SN
      QK(4)=XK
      QK(3)=XK*Z
      QK(2)=XK*SG*SIN(FG)
      QK(1)=XK*(SN*CG - CN*SG*CFG)
      DO 6 I=1,4
    6 QE(I)= -QN(I) - QK(I)
      QE(4)=2.+QE(4)
C CHECK ON MASSES
      XMN=QN(4)**2-QN(3)**2-QN(2)**2-QN(1)**2
      XMK=QK(4)**2-QK(3)**2-QK(2)**2-QK(1)**2
      XME=QE(4)**2-QE(3)**2-QE(2)**2-QE(1)**2
C---------------------------- END OF HARD PART -----------------
 3000 CONTINUE
C NORMALIZE AND ROTATE VECTORS
      DO 7 I=1,4
      QN(I)=EB*QN(I)
      QK(I)=EB*QK(I)
    7 QE(I)=EB*QE(I)
      FI=2.*PIG*RNCJ(9.)
      CF=COS(FI)
      SF=SIN(FI)
      QN1  =  QN(1)*CF + QN(2)*SF
      QN(2)= -QN(1)*SF + QN(2)*CF
      QN(1)= QN1
      QK1  =  QK(1)*CF + QK(2)*SF
      QK(2)= -QK(1)*SF + QK(2)*CF
      QK(1)= QK1
      QE1  =  QE(1)*CF + QE(2)*SF
      QE(2)= -QE(1)*SF + QE(2)*CF
      QE(1)= QE1
C
      RETURN
      END
CDECK  ID>, CJWRAD.
      SUBROUTINE CJWRAD(W,WL,N,NORAD)
C     *******************************
C------------------------------------------------------------------
C-- CALCULATES RADIATIVE DECAYS OF W (--> LEPTON+NEUTRINO+PHOTONS)
C-- MULTIPLE PHOTON EMISSION IS INCLUDED
C-- CONVERSION OF PHOTONS INTO CHARGED LEPTON PAIRS IS NEGLECTED
C-- W = W BOSON  MASS IN GEV
C-- WL = CHARGED LEPTON MASS IN GEV
C-- N = TOTAL NUMBER OF LEPTONS + PHOTONS IN DECAY
C-- NORAD = 1 : NO RADIATION
C--
C-- FINAL STATE PARTICLE MOMENTA STORED IN ARRAY P(I,J) BELONGING
C-- TO COMMON BLOCK /JET/.
C-- P(I,J) CONTAINS PARAMETERS OF PARTICLE I (I=1,N) -- I = 1
C-- CORRESPONDS TO THE NEUTRINO, I = N TO THE CHARGED LEPTON. (ALL
C-- PARAMETERS ARE IN GEV UNITS).
C-- THE Z AXIS CORRESPONDS TO THE DIRECTION OPPOSITE TO THE
C-- MOMENTUM OF PARTICLE WITH I = 1.
C--     P(I,1) = X MOMENTUM COMPONENT
C--     P(I,2) = Y    "         "
C--     P(I,3) = Z    "         "
C--     P(I,4) = ENERGY
C--     P(I,5) = MASS
C--
C-- A FINITE ENERGY RESOLUTION CUTOFF IS USED -- ITS VALUE IS
C-- CONTAINED IN THE VARIABLE EPSI, AND IS EXPRESSED IN UNITS OF
C-- THE W BOSON MASS -- IT CAN BE ARBITRARILY CHANGED BY THE USER
C-- (COMPATIBLY WITH MACHINE PRECISION AND STORAGE SPACE)
C------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION RNCJ,P,W,WL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXRAD=100)
      COMMON/CJZWRA/P(MAXRAD,5)
C
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 10
      PIG=4.*ATAN(1.)
      ALPHA=1./137.03604
      EPSI=5.E-8
      TAU=1./(ALPHA/PIG*(-LOG(EPSI)-3./4.+EPSI-EPSI**2/4.))
10    CONTINUE
C
      ICALL=ICALL+1
      AL=WL
      ALSQ=AL**2
      QSQX=W**2
      S=W**2
      QSQMN=ALSQ
11    CONTINUE
C-- DEVELOP 1ST LEG -- INITIAL KINEMATICS
      IF(NORAD.NE.1) THEN
        BP1SQ=-10.*S
        CALL CJWRQZ(QSQX,BP1SQ,EL,PSQ,Z,TAU,S,QSQMN,ALSQ,EPSI,GMSQ)
      ELSE
        PSQ=QSQMN
      ENDIF
C-- (CORRECT TO REPRODUCE O(ALPHA) RESULTS FOR SINGLE EMISSIONS)
      IF(PSQ.LE.QSQMN) GO TO 12
      XN=1.-PSQ/S
      XL=Z*(2.-XN)
      RATIO=(XL**2+XN**2)*(1.-XL)/((2.-XL-XN)*(1.+Z**2))
      IF(RNCJ(0.).GT.RATIO) GO TO 11
12    CONTINUE
      PCM=(S-PSQ)/(2.*W)
      EL=SQRT(PSQ+PCM**2)
      EN=PCM
C-- BOOK NEUTRINO
      N=1
      P(N,1)=0.
      P(N,2)=0.
      P(N,3)=-PCM
      P(N,4)=PCM
      P(N,5)=0.
      IF(PSQ.GT.QSQMN) GO TO 100
C-- NO RADIATION -- BOOK CHARGED LEPTON
      N=N+1
      P(N,1)=0.
      P(N,2)=0.
      P(N,3)=PCM
      P(N,4)=EL
      P(N,5)=AL
      RETURN
100   CONTINUE
C-- INITIAL SETTING FOR EMISSION LOOP
      PX=0.
      PY=0.
      PMSQ=EL**2-PSQ
      PM=SQRT(PMSQ)
      PZ=PM
200   CONTINUE
C-- BRANCHING LOOP
      XP1SQ=PSQ-2.*(1.-Z)*EL*(EL-PM)
      BP1SQ=PSQ-2.*(1.-Z)*EL*(EL+PM)
      CALL CJWRQZ(XP1SQ,BP1SQ,EL,P1SQ,Z1,TAU,S,QSQMN,ALSQ,EPSI,GMSQ)
      EL1=Z*EL
      PM1SQ=EL1**2-P1SQ
      PM1=SQRT(PM1SQ)
      EG=EL-EL1
      PZ1=(PM**2+PM1SQ-EG**2)/(2.*PM)
      PTRSQ=PM1SQ-PZ1**2
      IF(PTRSQ.LT.0.) PTRSQ=0.
      PTR=SQRT(PTRSQ)
      PHI=2.*PIG*RNCJ(0.)
      PTRX=PTR*COS(PHI)
      PTRY=PTR*SIN(PHI)
C-- ROTATION PARAMETERS FOR SECONDARIES
      PT=SQRT(PX**2+PY**2)
      IF(PT.LT.1.E-10) GO TO 210
      CT=PZ/PM
      ST=PT/PM
      CP=PX/PT
      SP=PY/PT
210   CONTINUE
C-- BOOK PHOTON
      PGX=-PTRX
      PGY=-PTRY
      PGZ=PM-PZ1
C-- ROTATE PHOTON BEFORE BOOKING
      IF(PT.LT.1.E-10) GO TO 220
      UX=CT*PGX+ST*PGZ
      UY=PGY
      UZ=-ST*PGX+CT*PGZ
      PGX=CP*UX-SP*UY
      PGY=SP*UX+CP*UY
      PGZ=UZ
220   CONTINUE
      N=N+1
      IF(N.GT.MAXRAD) GO TO 500
      P(N,1)=PGX
      P(N,2)=PGY
      P(N,3)=PGZ
      P(N,4)=EG
      P(N,5)=0.
C-- GO TO NEXT STEP OR EXIT
      PSQ=P1SQ
      EL=EL1
      PX=PTRX
      PY=PTRY
      PZ=PZ1
      PM=PM1
      Z=Z1
C-- ROTATE SECONDARY LEPTON BEFORE BOOKING OR GOING ON
      IF(PT.LT.1.E-10) GO TO 230
      UX=CT*PX+ST*PZ
      UY=PY
      UZ=-ST*PX+CT*PZ
      PX=CP*UX-SP*UY
      PY=SP*UX+CP*UY
      PZ=UZ
230   CONTINUE
      IF(PSQ.GT.QSQMN) GO TO 200
C-- STOP CASCADE -- BOOK CHARGED LEPTON
      N=N+1
      IF(N.GT.MAXRAD) GO TO 500
      P(N,1)=PX
      P(N,2)=PY
      P(N,3)=PZ
      P(N,4)=EL
      P(N,5)=AL
      RETURN
C-- ABNORMAL ENDING
500   WRITE(ITLIS,501) MAXRAD,ICALL
501   FORMAT(5(/),' ***NUMBER OF PARTICLES IN CJWRAD EXCEEDS', I5
     1//' ***CALL NO. =',I10
     3//' ***INCREASE MAXRAD'
     4//' ***JOB ABORT'
     5)
      STOP
      END
CDECK  ID>, CJWRQZ.
      SUBROUTINE CJWRQZ(XPSQ,BP1SQ,EL,PSQ,Z,TAU,S,QSQMN,ALSQ,EPSI,GMSQ)
C     *****************************************************************
C------------------------------------------------------------------
C-- GENERATES PSQ (OF PARENT) AND Z (LEPTON FRACTION) IN BRANCHING
C-- CALLED BY CJWRAD
C------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION RNCJ
C
C-- GENERATE PSQ
      GPSQ=XPSQ
      IF(GPSQ.LT.QSQMN) GO TO 50
10    RR=RNCJ(0.)
      IF(RR.LT.(QSQMN/GPSQ)**(1./TAU)) GO TO 15
      PSQ=GPSQ*RR**TAU
      IF(PSQ.LT.BP1SQ) GO TO 15
      IF(PSQ.LT.QSQMN) GO TO 50
      GO TO 16
15    IF(BP1SQ.LE.QSQMN) GO TO 50
      PSQ=BP1SQ
16    CONTINUE
C-- GENERATE Z
20    Z=1.-EPSI**RNCJ(0.)
      WFUN=(1.+Z**2)/2.
      IF(RNCJ(0.).GT.WFUN) GO TO 20
C-- CHECK WITH Z LIMITS -- IF NOT, EVOLVE FURTHER
      IF(BP1SQ.LT.-4.*S) GO TO 60
      ZLW=1.-(PSQ-ALSQ)/(2.*EL*(EL-SQRT(EL**2-PSQ)))
      IF(Z.LT.ZLW) GO TO 40
      RETURN
C-- Z CHECK FOR 1ST EMISSION
60    PCM=(S-PSQ)/(2.*SQRT(S))
      EL=SQRT(PSQ+PCM**2)
      ZLW=1.-(PSQ-ALSQ)/(2.*EL*(EL-PCM))
      ZUP=1.-(PSQ-ALSQ)/(2.*EL*(EL+PCM))
      IF(Z.LT.ZLW) GO TO 40
      IF(Z.GT.ZUP) GO TO 40
      RETURN
40    GPSQ=PSQ
      GO TO 10
C-- LEG STOPS -- NO BRANCHING
50    PSQ=ALSQ
      RETURN
      END
CDECK  ID>, CJZANG.
      SUBROUTINE CJZANG(IQRKFW,ID1,COSROT)
C     ************************************
C-- GENERATES W-S COSROT=COS(THETA)  FOR CMS ROTATION IN Z DECAY
C-- THETA IS ANGLE BETWEEN FINAL QUARK, OR NEGATIVE LEPTON, OR NEUTRINO
C-- AND INITIAL QUARK
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
C
C-- NOTE: LXI,SX ETC. DEFINED FROM OUTSIDE
      RHO4=0.
      IF(ABS(ID1).EQ.6) RHO4=SZ(3)/SX
      FS1=SX*DS*DEN
      FS2=SX**2*DEN
      ABW1=SZF(1,LXI,LXF)*(1.+RHO4)
     *    +SZF(2,LXI,LXF)*(1.+RHO4)*FS1
     *    +(SZF(5,LXI,LXF)+RHO4*SZF(6,LXI,LXF))*FS2
      ABW2=SQRT(ABS(1.-RHO4))*(SZF(7,LXI,LXF)*FS1+SZF(8,LXI,LXF)*FS2)
      ABW3=(1.-RHO4)*(SZF(1,LXI,LXF)+SZF(2,LXI,LXF)*FS1
     *     +SZF(5,LXI,LXF)*FS2)
      ABWX=ABS(ABW1)+ABS(ABW2)+ABS(ABW3)
12    C=-1.+2.*RNCJ(FS1)
      ABW=ABW1+ABW2*C+ABW3*C**2
      IF(ABWX*RNCJ(FS2).GT.ABW) GO TO 12
      IF(IQRKFW.LT.0) C=-C
      COSROT=C
C
      RETURN
      END
CDECK  ID>, CJZDEC.
      SUBROUTINE CJZDEC(S,XM,CVL,CAL,CVQ,CAQ,QQ,XMZ,XGZ,ALFA,Q0
     &,QP,QM,QK)
C     *********************************************************
C-- MODIFIED: S,XM,CVL,CAL,CVQ,CAQ,QQ,XMZ,XGZ,ALFA,Q0 GIVEN IN INPUT
C--           COMMON BLOCK /PARRAM/ ELIMINATED
C------------------------------------------------------------
C LEPTONIC DECAY OF Z0 BOSON PRODUCED FROM Q QBAR PAIR
C
C     AUTHORS    F.A.BERENDS AND R.KLEISS
C
C    INFORMATION ON THIS PROGRAM IS FOUND IN
C    F.A. BERENDS AND R. KLEISS, "HARD PHOTON CORRECTIONS IN
C    W AND Z DECAY ", LEIDEN UNIVERSITY PREPRINT (1983).
C    PLEASE REFER TO THIS PAPER WHEN USING THIS PROGRAM |
C
C
C PARAMETERS: S (CM ENERGY OF LEPTON PAIR SQUARED IN GEV**2);
C             XM (LEPTON MASS IN GEV)
C             CVL,CAL (LEPTON VECTOR/AXIAL VECTOR COUPLING)
C             CVQ,CAQ (SAME FOR QUARK)
C             QQ (QUARK ELECTRIC CHARGE)
C             XMZ,XGZ (Z0 MASS AND WIDTH IN GEV)
C THESE PARAMETERS MUST BE SUPPLIED IN THE COMMON 'PARRAM'
C FOR THE CONVENTIONS OF THE COUPLING CONSTANTS, SEE
C F.A.BERENDS,R.KLEISS AND S.JADACH,
C NUCL.PHYS.B202(1982)63-88,TABLE ON PAGE 83.
C THIS GIVES THE CONVENTIONS IN THE GLASHOW-WEINBERG-SALAM
C 'STANDARD MODEL'
C-----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C--
      DOUBLE PRECISION RNCJ
      DOUBLE PRECISION S,XM,CVL,CAL,CVQ,CAQ,QQ,XMZ,XGZ,ALFA,Q0,QP,QM,QK
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      DIMENSION QP(4),QM(4),QK(4)
C     DATA INITI /0/
C     IF(INITI.NE.0) GOTO 1000
C----------------------------------- INITIALIZATION STEP ---
C     INITI=1
      DATA SOLD/0.D0/
      IF(ABS(S-SOLD).LT..01) GO TO 1000
      SOLD=S
      WCUMUL=0.
      ICUMUL=0
      ONE = 1.
      EB=.5*SQRT(S)
      XM2=(XM/EB)**2
      BARN=3.8938D+05/EB**2
C------------------------------- XK0=ENERGY CUTOFF / BEAM ENERGY
      XK0=Q0/EB
      PIG=4.*ATAN(ONE)
      A0=(CVL**2+CAL**2)*(CVQ**2+CAQ**2)
      B0=8.*CVL*CAL*CVQ*CAQ
      FCMAX=2.*A0+ABS(B0)
      Z2=16.*((1.-XMZ**2/S)**2 + (XMZ*XGZ/S)**2)
C TOTAL LOWEST ORDER CROSS SECTION
      SIG0=16.*ALFA**2*PIG*QQ**2*A0/Z2*BARN/3.D0
C TOTAL WITH SOFT + VIRTUAL CORRECTIONS
      XLS=LOG(4./XM2)
      SIGS=SIG0*( 1. + 2.*ALFA/PIG*
     . ( LOG(XK0)*(XLS-1.) + 3./4.*XLS + PIG**2/6. - 1.) )
C TOTAL APPROXIMATE HARD CROSS SECTION
      SIGH=SIG0* 2.*ALFA/PIG*( -LOG(XK0)*XLS - PIG**2/6. )
C CORRECTIONS
      DELS=(SIGS/SIG0-1.)*100.
      DELH=(SIGH/SIG0   )*100.
      DELT=DELS+DELH
C FRACTION OF HARD EVENTS IN TRIAL SAMPLE
      FRHRD=DELH/(100.+DELT)
      WMAX=1.05D0
C     WRITE(ITLIS,1) EB,XM2,BARN,XK0,A0,B0,FCMAX,Z2,FRHRD,WMAX,
C    . S,XM,CVL,CAL,CVQ,CAQ,QQ,XMZ,XGZ,
C    . SIG0,SIGS,SIGH,DELS,DELH,DELT
    1 FORMAT(1H0,96(1H-),/,
     . 12X,30H THIS IS ROUTINE ''CJZDEC'' | ,/,
     . 1X,8D12.4,/,1X,2F12.4,/,
     . 1X,27HCENTRE OF MASS ENERGY       ,D12.4,7H GEV**2 ,/,
     . 1X,27HMASS OF LEPTON              ,D12.4,4H GEV ,/,
     . 1X,27HLEPTON COUPLING: VECTOR     ,D12.4,/,
     . 1X,27H                 AXIAL V.   ,D12.4,/,
     . 1X,27HQUARK COUPLING : VECTOR     ,D12.4,/,
     . 1X,27H                 AXIAL V.   ,D12.4,/,
     . 1X,27HQUARK E.M. CHARGE           ,D12.4,/,
     . 1X,27HZ0 BOSON : MASS             ,D12.4,4H GEV ,/,
     . 1X,27H           WIDTH            ,D12.4,4H GEV ,/,
     . 1X,27HLOWEST ORDER CROSS SECTION  ,D12.4,9H NANOBARN ,/,
     . 1X,27HWITH SOFT + VIRTUAL CORR.   ,D12.4,9H NANOBARN ,/,
     . 1X,27HAPPROXIMATE HARD CONTRIB.   ,D12.4,9H NANOBARN ,/,
     . 1X,27HSOFT PHOTON CORRECTION      ,F12.4,8H PERCENT ,/,
     . 1X,27HHARD APPROX.CORRECTION      ,F12.4,8H PERCENT ,/,
     . 1X,27HTOTAL CORRECTION (APPR.)    ,F12.4,8H PERCENT )
C--------------------------------------------------------------
 1000 CONTINUE
C------------------------ START OF EVENT GENERATION STEP ------
C GENERATE VALUE OF QP SOLID ANGLE (BOTH HARD OR SOFT)
    2 C= -1. + 2.*RNCJ(1.)
      WC= (A0*(1.+C*C)+B0*C)/FCMAX
      IF(WC.LT.RNCJ(2.)) GOTO 2
      SC=SQRT(1.-C*C)
      FC=2.*PIG*RNCJ(3.)
      CFC=COS(FC)
      SFC=SIN(FC)
C------------------------ CHOSE BETWEEN HARD AND SOFT PART ----
      IF(RNCJ(4.).GT.FRHRD) GOTO 2000
C------------------------ HARD PART CHOSEN -----------------------
C ADD TO EVENT COUNTER FOR FINDING REAL CROSS SECTION
      ICUMUL=ICUMUL+1
C GENERATE VALUE FOR K
    3 XK=XK0**RNCJ(5.)
      WK=1. + LOG(1.-XK)/XLS
      IF(WK.LT.RNCJ(6.)) GOTO 3
C GENERATE VALUE FOR FG
      FG=2.*PIG*RNCJ(7.)
      CFG=COS(FG)
      SFG=SIN(FG)
C GENERATE VALUE FOR Y1
      YMIN=XM2*XK/(2.*(1.-XK))
      YMAX=2.*XK+YMIN
      Y1=YMIN* (YMAX/YMIN)**RNCJ(8.)
      IF(RNCJ(9.).GT.0.5D0) Y1=YMAX-Y1
C CONSTRUCT MOMENTA AND CHECK ON KINEMATICS BY MASS SHELL
      X=1.-XK+.5*(Y1-YMIN)
      CG=(2.*(1.-XK)/X-2.+XK)/XK
      SG=(1.-CG*CG)
      IF(SG.LT.0.D0) CG=CG/ABS(CG)
      SG=SQRT(1.-CG*CG)
      SG=DSQRT(1.-CG*CG)
C QK VECTOR
      QK(4)=XK
      QK(3)=XK*(C*CG-SC*SG*CFG)
      QK(2)=XK*((C*SG*CFG + SC*CG)*SFC + SG*SFG*CFC)
      QK(1)=XK*((C*SG*CFG + SC*CG)*CFC - SG*SFG*SFC)
C QP VECTOR
      QP(4)=X
      QP(3)=X*C
      QP(2)=X*SC*SFC
      QP(1)=X*SC*CFC
C QM VECTOR
      DO 4 I=1,4
    4 QM(I)=-QP(I)-QK(I)
      QM(4)=2.+QM(4)
C CHECK ON MASSES
      XMK=QK(4)**2-QK(3)**2-QK(2)**2-QK(1)**2
      XMP=QP(4)**2-QP(3)**2-QP(2)**2-QP(1)**2
      XMM=QM(4)**2-QM(3)**2-QM(2)**2-QM(1)**2
C----------------------------------- CALCULATE WEIGHT ----
      C1=-QM(3)/QM(4)
      Y2=YMAX-Y1
      WW=(QM(4)**2*(A0*(1.+C1*C1) + B0*C1)*(1. - XM2*Y2/(2.*Y1) )+
     .    QP(4)**2*(A0*(1.+C*C  ) + B0*C )*(1. - XM2*Y1/(2.*Y2) ))
     . /(2.*(A0*(1.+C*C)+B0*C) )
C----------------------------------- REJECTION POINT -----
C CUMULATE WEIGHTS
      WCUMUL=WCUMUL+WW
      WSOFAR=WCUMUL/ICUMUL
      DSOFAR=WSOFAR*DELH
      IF(RNCJ(10.).GT.(WW/WMAX)) GOTO 1000
      GOTO 3000
C------------------------------------------------- SOFT PART CHOSEN ----
C APPLY IMMEDIATE REJECTION
 2000 IF(RNCJ(11.).GT.(1./WMAX)) GOTO 1000
      QP(4)=1.
      QP(3)=C
      QP(2)=SC*SFC
      QP(1)=SC*CFC
      QM(4)=1.
      DO 5 I=1,3
    5 QM(I)=-QP(I)
      DO 6 I=1,4
    6 QK(I)=0.D0
C----------------------------------- SCALE MOMENTA -------
 3000 DO 7 I=1,4
      QP(I)=EB*QP(I)
      QM(I)=EB*QM(I)
    7 QK(I)=EB*QK(I)
      RETURN
      END
CDECK  ID>, CJZGEN.
      SUBROUTINE CJZGEN(IFUN,ZLW,ZUP,FLAG,Z)
C     **************************************
C-- GENERATES Z IN TIMELIKE EVOLUTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION WGTMAX(3)
      DATA WGTMAX/2.,1.125,1./
C
      IF(FLAG.GT.0.) GO TO 100
      IF(IFUN.EQ.1) GO TO 1
      IF(IFUN.EQ.2) GO TO 2
      IF(IFUN.EQ.3) GO TO 3
C
C-- QUARK BRANCHING
1     CONTINUE
      ALLW=LOG(1.-ZLW)
      ALUP=LOG(1.-ZUP)
      DZ=ALLW-ALUP
11    RR=RNCJ(0.)
      Z1=EXP(RR*DZ+ALUP)
      Z=1.-Z1
      WFUN=1.+Z**2
      IF(RNCJ(0.).GT.WFUN/WGTMAX(IFUN)) GO TO 11
      RETURN
C
C-- GLUON BRANCHING INTO TWO GLUONS
2     CONTINUE
C     LOG(0.5)
      ALLW=-.6931471
      ALUP=LOG(1.-ZUP)
      DZ=ALLW-ALUP
21    RR=RNCJ(0.)
      Z1=EXP(RR*DZ+ALUP)
      Z=1.-Z1
      A=Z**2
      B=Z1**2
      WFUN=(A+B+A*B)/Z
      IF(RNCJ(0.).GT.WFUN/WGTMAX(IFUN)) GO TO 21
      IF(RNCJ(0.).GT.0.5) Z=Z1
      RETURN
C
C-- GLUON BRANCHING INTO Q-QB
3     CONTINUE
      Z=ZLW+(ZUP-ZLW)*RNCJ(0.)
      WFUN=Z**2+(1.-Z)**2
      IF(RNCJ(0.).GT.WFUN) GO TO 3
      RETURN
C
100   Z=ZUP
      RETURN
      END
CDECK  ID>, CJZGES.
      SUBROUTINE CJZGES(IFUN,Z,IFLAQ)
C     *******************************
C-- GENERATES Z IN SPACELIKE EVOLUTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C
      DIMENSION WGTMAX(3)
      DATA WGTMAX/2.,1.125,1./
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 30
      ICALL=1
      ALLW=LOG(1.-ZSLW)
C     LN(0.5)
      ALLWG=-.6931471
      ALUP=LOG(1.-ZSUP)
      DZ=ALLW-ALUP
      DZG=ALLWG-ALUP
30    CONTINUE
C
      IF(IFUN.EQ.1) GO TO 1
      IF(IFUN.EQ.2) GO TO 2
      IF(IFUN.EQ.3) GO TO 3
C
C-- QUARK BRANCHING
1     CONTINUE
11    RR=RNCJ(0.)
      Z1=EXP(RR*DZ+ALUP)
      Z=1.-Z1
      WFUN=1.+Z**2
      IF(RNCJ(0.).GT.WFUN/WGTMAX(IFUN)) GO TO 11
      RETURN
C
C-- GLUON BRANCHING INTO TWO GLUONS
2     CONTINUE
21    RR=RNCJ(0.)
      Z1=EXP(RR*DZG+ALUP)
      Z=1.-Z1
      A=Z**2
      B=Z1**2
      WFUN=(A+B+A*B)/Z
      IF(RNCJ(0.).GT.WFUN/WGTMAX(IFUN)) GO TO 21
      IF(RNCJ(0.).GT.0.5) Z=Z1
      RETURN
C
C-- GLUON BRANCHING INTO Q-QB
3     CONTINUE
      Z=ZSLW+(ZSUP-ZSLW)*RNCJ(0.)
      Z1=1.-Z
      WFUN=Z**2+Z1**2
      IF(RNCJ(0.).GT.WFUN) GO TO 3
      IFLAQ=INT(NFLAVS*RNCJ(0))+1
      RETURN
C
      END
CDECK  ID>, CJZLIM.
      SUBROUTINE CJZLIM(PSQ,QZ1SQ,QZ2SQ,ZLW,ZUP,FLAG)
C     ***********************************************
C-- CALCULATES LIMITS FOR Z - INPUT, SQUARE MASSES
C-- TIMELIKE EVOLUTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      FLAG=-1.
      IF(SQRT(PSQ).LT.(SQRT(QZ1SQ)+SQRT(QZ2SQ))) GO TO 10
      B=-(1.+QZ1SQ/PSQ-QZ2SQ/PSQ)
      C=QZ1SQ/PSQ
      DISCR=B**2/4.-C
      IF(DISCR.LT.0.) GO TO 10
      SQDIS=SQRT(DISCR)
      ZLW=-B/2.-SQDIS
      ZUP=-B/2.+SQDIS
      RETURN
10    FLAG=1.
      ZLW=0.5
      ZUP=0.5
      RETURN
      END
CDECK  ID>, CJZLMS.
      SUBROUTINE CJZLMS(PSQ,QZSQ,ZLW,ZUP,FLAG)
C     ****************************************
C-- CALCULATES LIMITS FOR Z WHEN SECONDARY MASSES ARE EQUAL
C-- INPUT, SQUARE MASSES -- TIMELIKE EVOLUTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      FLAG=-1.
      IF(PSQ.LT.4.*QZSQ) GO TO 10
      D=SQRT(.25-QZSQ/PSQ)
      ZLW=.5-D
      ZUP=.5+D
      RETURN
10    FLAG=1.
      ZLW=.5
      ZUP=.5
      RETURN
      END
CDECK  ID>, CJZRAD.
      SUBROUTINE CJZRAD(W,WL,N,NORAD)
C     *******************************
C------------------------------------------------------------------
C-- CALCULATES RADIATIVE DECAYS OF Z0 (--> L-L+  +  PHOTONS)
C-- (ALSO USABLE FOR DRELL-YAN VIRTUAL PHOTON DECAY)
C-- MULTIPLE PHOTON EMISSION IS INCLUDED
C-- CONVERSION OF PHOTONS INTO CHARGED LEPTON PAIRS IS NEGLECTED
C-- W = Z0 MASS IN GEV (OR DRELL-YAN VIRTUAL PHOTON MASS)
C-- WL = LEPTON MASS IN GEV
C-- N = TOTAL NUMBER OF LEPTONS + PHOTONS IN DECAY
C-- NORAD = 1 : NO RADIATION
C--
C-- FINAL STATE PARTICLE MOMENTA STORED IN ARRAY P(I,J) BELONGING
C-- TO COMMON BLOCK /JET/.
C-- P(I,J) CONTAINS PARAMETERS OF PARTICLE I (I=1,N) -- I = 1 AND N
C-- CORRESPOND TO THE TWO LEPTONS. (ALL PARAMETERS IN GEV UNITS).
C-- THE Z AXIS CORRESPONDS TO THE DIRECTION OPPOSITE TO THE
C-- MOMENTUM OF PARTICLE WITH I = 1.
C--     P(I,1) = X MOMENTUM COMPONENT
C--     P(I,2) = Y    "         "
C--     P(I,3) = Z    "         "
C--     P(I,4) = ENERGY
C--     P(I,5) = MASS
C--
C-- A FINITE PHOTON MASS IS USED AS CUTOFF -- ITS VALUE IS CONTAINED
C-- IN THE VARIABLE GM, AND CAN BE ARBITRARILY CHANGED BY THE USER
C-- (COMPATIBLY WITH MACHINE PRECISION AND STORAGE SPACE)
C------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION RNCJ,P,W,WL
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      PARAMETER (MAXRAD=100)
      COMMON/CJZWRA/P(MAXRAD,5)
C
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 10
      PIG=4.*ATAN(1.)
      ALPHA=1./137.03604
      GM=5.E-6
      GMSQ=GM**2
10    CONTINUE
C
      ICALL=ICALL+1
      AL=WL
      ALSQ=AL**2
      QSQX=(W-AL)**2
      S=W**2
      EPSI=(GM/W)**2
      QSQMN=(AL+GM)**2
      QSQOPC=2.*QSQMN
      TAU=1./(ALPHA/PIG*(-LOG(EPSI)-3./4.+EPSI-EPSI**2/4.))
11    CONTINUE
C-- DEVELOP 1ST LEG -- INITIAL KINEMATICS
      IF(NORAD.NE.1) THEN
        CALL CJZRQZ(QSQX,PSQ,Z,ZC,TAU,S,QSQMN,ALSQ,EPSI,GMSQ)
      ELSE
        PSQ=QSQMN
      ENDIF
C-- CORRECT TO REPRODUCE O(ALPHA) RESULTS FOR SINGLE EMISSIONS
      IF(PSQ.LE.QSQMN) GO TO 14
      XL2=1.-PSQ/S
      XL1=1.-ZC*XL2
      RATIO=(XL1**2+XL2**2)/(1.+Z**2)
      IF(RNCJ(0.).GT.RATIO) GO TO 11
14    CONTINUE
C
      AM=SQRT(PSQ)
      PCMSQ=(S-(AM+AL)**2)*(S-(AM-AL)**2)/(4.*S)
      IF(PCMSQ.LT.0.) GO TO 11
      PCM=SQRT(PCMSQ)
      E1=SQRT(PSQ+PCMSQ)
      E2=SQRT(ALSQ+PCMSQ)
      IF(PSQ.LE.QSQMN) GO TO 12
      PPLUS=E1+PCM
      QSQOP=S*(1.-XL1)
      IF(QSQOP.LE.QSQOPC) GO TO 11
12    CONTINUE
C-- BOOK IDLE LEPTON
      N=1
      P(N,1)=0.
      P(N,2)=0.
      P(N,3)=-PCM
      P(N,4)=E2
      P(N,5)=AL
      IF(PSQ.GT.QSQMN) GO TO 100
C-- NO RADIATION -- BOOK 2ND LEPTON
      N=N+1
      P(N,1)=0.
      P(N,2)=0.
      P(N,3)=PCM
      P(N,4)=E1
      P(N,5)=AL
      RETURN
100   CONTINUE
C-- INITIAL SETTING FOR EMISSION LOOP
      PX=0.
      PY=0.
      X=1.
200   CONTINUE
C-- BRANCHING LOOP
      XP1SQ=Z*(PSQ-GMSQ/ZC)
      CALL CJZRQZ(XP1SQ,P1SQ,Z1,ZC1,TAU,S,QSQMN,ALSQ,EPSI,GMSQ)
      PTRSQ=Z*ZC*PSQ-ZC*P1SQ-Z*GMSQ
      IF(PTRSQ.LT.0.) GO TO 11
      PTR=SQRT(PTRSQ)
      PHI=2.*PIG*RNCJ(0.)
      PTRX=PTR*COS(PHI)
      PTRY=PTR*SIN(PHI)
C-- BOOK PHOTON
      PGX=ZC*PX-PTRX
      PGY=ZC*PY-PTRY
      XG=X*ZC
      PP=PPLUS*XG
      PTGSQ=PGX**2+PGY**2
      IF(N.EQ.1) PM=(Z*PSQ-P1SQ+GMSQ)/PPLUS
      IF(N.GT.1) PM=(PTGSQ+GMSQ)/PP
      PGZ=(PP-PM)/2.
      EG=SQRT(PTGSQ+PGZ**2)
      N=N+1
      IF(N.GT.MAXRAD) GO TO 500
      P(N,1)=PGX
      P(N,2)=PGY
      P(N,3)=PGZ
      P(N,4)=EG
      P(N,5)=0.
C-- GO TO NEXT STEP OR EXIT
      PSQ=P1SQ
      X=X*Z
      PX=Z*PX+PTRX
      PY=Z*PY+PTRY
      IF(PSQ.LE.QSQMN) GO TO 300
      Z=Z1
      ZC=ZC1
      GO TO 200
300   CONTINUE
C-- STOP CASCADE -- BOOK 2ND LEPTON
      N=N+1
      IF(N.GT.MAXRAD) GO TO 500
      PP=PPLUS*X
      PM=(PX**2+PY**2+ALSQ)/PP
      PZ=(PP-PM)/2.
      E=(PP+PM)/2.
      P(N,1)=PX
      P(N,2)=PY
      P(N,3)=PZ
      P(N,4)=E
      P(N,5)=AL
      RETURN
C-- ABNORMAL ENDING
500   WRITE(ITLIS,501) MAXRAD,ICALL
501   FORMAT(5(/),' ***NUMBER OF PARTICLES IN CJZRAD EXCEEDS', I5
     1//' ***CALL NO. =',I10
     3//' ***INCREASE MAXRAD'
     5)
      STOP
      END
CDECK  ID>, CJZRQZ.
      SUBROUTINE CJZRQZ(XPSQ,PSQ,Z,ZC,TAU,S,QSQMN,ALSQ,EPSI,GMSQ)
C     ***********************************************************
C------------------------------------------------------------------
C-- CALLED BY CJZRAD
C-- GENERATES PSQ (OF PARENT) AND Z (LEPTON FRACTION) IN BRANCHING
C------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION RNCJ
C
C-- GENERATE PSQ
      GPSQ=XPSQ
      IF(GPSQ.LT.QSQMN) GO TO 50
10    RR=RNCJ(0.)
      IF(RR.LT.(QSQMN/GPSQ)**(1./TAU)) GO TO 50
      PSQ=GPSQ*RR**TAU
      IF(PSQ.LE.QSQMN) GO TO 50
C-- GENERATE Z
20    ZC=EPSI**RNCJ(0.)
      Z=1.-ZC
      WFUN=(1.+Z**2)/2.
      IF(RNCJ(0.).GT.WFUN) GO TO 20
      ZCLWX=GMSQ/PSQ
      IF(ZC.LE.ZCLWX) GO TO 40
C-- FINAL CHECK WITH Z LIMITS -- IF NOT, EVOLVE FURTHER
      B2M=(1.+(ALSQ-GMSQ)/PSQ)/2.
      C=ALSQ/PSQ
      DISCR=B2M**2-C
      SQDIS=0.
      IF(DISCR.LT.0.) GO TO 30
      SQDIS=SQRT(DISCR)
30    ZLW=B2M-SQDIS
      ZUP=B2M+SQDIS
      IF(Z.LE.ZLW) GO TO 40
      IF(Z.GE.ZUP) GO TO 40
      RETURN
40    GPSQ=PSQ
      GO TO 10
C-- LEG STOPS -- NO BRANCHING
50    PSQ=ALSQ
      RETURN
      END
CDECK  ID>, COJETS.
      SUBROUTINE COJETS(JTDKY,JTEVT,JTCOM,JTLIS)
C     ******************************************
C-- USER CALLING ROUTINE FOR COJETS
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--
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      LOGICAL ACCEPT
C
C-- SET DEFAULT VALUES (OLD BLOCK DATA)
      CALL CJDATA
C
C-- UPDATE UNITS ACCORDING TO INPUT ARGUMENTS
      IF(JTDKY.NE.0) ITDKY=JTDKY
      IF(JTEVT.NE.0) ITEVT=JTEVT
      IF(JTCOM.NE.0) ITCOM=ABS(JTCOM)
      IF(JTLIS.NE.0) ITLIS=ABS(JTLIS)
C
C-- INITIALIZE PROGRAM PARAMETERS
      CALL CJIALL
C
C-- ELIMINATE UNSTABLE PARTICLES: TRUE/FALSE
      IF(ITEVT.GE.0) NOUNST=0
C
C-- INITIALIZE USER STUFF
      CALL CJUSER(ACCEPT)
C
C-- READ INITIAL VALUE OF LEFT OVER CPU TIME
      CALL CJTLFT(TLEFT)
      TINIT=TLEFT
C
C-- CALL GENERATING ROUTINE
      CALL CJGEVE
C
C-- END RUN
      CALL CJHEAT(TINIT)
      CALL CJUSER(ACCEPT)
C
C-- PRINT PARTICLE AND DECAY TABLE
      IF(ITDKY.GT.0) CALL CJPTAB
      RETURN
      END
CDECK  ID>, GAMMCJ.
      FUNCTION GAMMCJ(X)
C     ******************
C-- GAMMA FUNCTION FROM CERN PROGRAM LIBRARY (GAMMA --> GAMMCJ)
      DOUBLE PRECISION GAMMCJ,X
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      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(Z .GT. 0.0) GO TO 1
      IF(Z .EQ. AINT(Z)) 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 GAMMCJ=
     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
      GAMMCJ=3.141592653589793/(SIN(3.141592653589793*X)*GAMMCJ)
      RETURN
    5 GAMMCJ=0.
      WRITE(ITLIS,10) Z
      RETURN
   10 FORMAT(1X,'GAMMCJ ... ARGUMENT IS NON-POSITIVE INTEGER = ',E20.5)
      END
CDECK  ID>, DEXGCJ.
      FUNCTION DEXGCJ(A2,S,T,UQ)
C     **************************
C-- G-QH --> G-QH ,  A2=MASS*2 OF HEAVY QUARK
C-- ZERO INITIAL MASSES
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DEXGCJ=0.
      U=UQ+2.*A2
      UMN=0.
      IF(U.GT.UMN) RETURN
      DEXGCJ=-2.*S*U/T**2
     1 +(4./9.)*(-S*U+A2*(U-2.*S))/(A2-S)**2
     2 +(4./9.)*(-S*U+A2*(S-2.*U))/(A2-U)**2
     3 -(1./9.)*A2*(S+U)/((A2-U)*(A2-S))
     4 +(S*U+1.5*S*A2)/(T*(A2-S))
     5 +(S*U+1.5*U*A2)/(T*(A2-U))
      RETURN
      END
CDECK  ID>, DEXQCJ.
      FUNCTION DEXQCJ(A2,S,T,UQ)
C     **************************
C-- Q-QH --> Q-QH ,  A2=MASS*2 OF HEAVY QUARK
C-- ZERO INITIAL MASSES
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DEXQCJ=0.
      U=UQ+2.*A2
      UMN=0.
      IF(U.GT.UMN) RETURN
      DEXQCJ=(4./9.)*(S**2+U**2+4.*T*A2)/T**2
      RETURN
      END
CDECK  ID>, DHFICJ.
      FUNCTION DHFICJ(A2,S,TQ,UQ)
C     ***************************
C-- QHB-QH --> QHB-QH  F=I
C-- A2 = MASS*2  OF HEAVY QUARKS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DHFICJ=0.
      T=TQ+A2
      U=UQ+A2
      TUMN=-(.5*SQRT(S)-SQRT(.25*S-A2))**2
      IF(T.GT.TUMN) RETURN
      IF(U.GT.TUMN) RETURN
      S2=S**2
      T2=T**2
      U2=U**2
      DHFICJ=(4./9.)*((U2+T2+2.*A2*(S-T-U+A2))/S2
     1               +(U2+S2-2.*A2*(U+S)+A2**2)/T2)
     2      -(8./27.)*(U2-A2*(2.*U-S)+A2**2)/(T*S)
      RETURN
      END
CDECK  ID>, DHIDCJ.
      FUNCTION DHIDCJ(A2,S,TQ,UQ)
C     ***************************
C-- QHI-QHI --> QHI-QHI  ID.
C-- A2 = MASS**2  OF HEAVY QUARKS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DHIDCJ=0.
      T=TQ+A2
      U=UQ+A2
      TUMN=-(.5*SQRT(S)-SQRT(.25*S-A2))**2
      IF(T.GT.TUMN) RETURN
      IF(U.GT.TUMN) RETURN
      S2=S**2
      T2=T**2
      U2=U**2
      DHIDCJ=(4./9.)*((S2+U2-2.*(S+U)+A2**2)/T2
     1              +(S2+T2-2.*(S+T)+A2**2)/U2)
     2     -(8./27.)*(S2-3.*S*A2)/(U*T)
      RETURN
      END
CDECK  ID>, DHNICJ.
      FUNCTION DHNICJ(A2,B2,S,TQ,UQ)
C     ******************************
C-- QHI-QHJ --> QHI-QHJ  NON-ID.
C-- A2, B2 = MASS**2 OF FINAL HEAVY QUARKS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DHNICJ=0.
      AB2=0.5*(A2+B2)
      T=TQ+AB2
      U=UQ+AB2
      TUMN=((A2-B2)**2-(S-SQRT((S+A2-B2)**2-4.*S*A2))**2)/(4.*S)
      IF(T.GT.TUMN) RETURN
      IF(U.GT.TUMN) RETURN
      DHNICJ=(4./9.)*(S**2+U**2-(A2+B2)*(S+U)+A2*B2)/T**2
      RETURN
      END
CDECK  ID>, DHVGCJ.
      FUNCTION DHVGCJ(A2,S,TQ,UQ)
C     ***************************
C-- G-G --> QHB-QH ,  A2=MASS*2 OF HEAVY QUARK
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DHVGCJ=0.
      T=TQ+A2
      U=UQ+A2
      TUMN=-(.5*SQRT(S)-SQRT(.25*S-A2))**2
      IF(T.GT.TUMN) RETURN
      IF(U.GT.TUMN) RETURN
      DHVGCJ=(3./4.)*TQ*UQ/S**2
     1+(1./6.)*(TQ*UQ-2.*A2*(2.*A2+TQ))/TQ**2
     2+(1./6.)*(TQ*UQ-2.*A2*(2.*A2+UQ))/UQ**2
     3-(1./24.)*A2*(S-4.*A2)/(TQ*UQ)
     4+(3./8.)*(TQ*UQ+A2*(UQ-TQ))/(S*TQ)
     5+(3./8.)*(TQ*UQ+A2*(TQ-UQ))/(S*UQ)
      RETURN
      END
CDECK  ID>, DHVQCJ.
      FUNCTION DHVQCJ(A2,S,TQ,UQ)
C     ***************************
C-- QB-Q --> QHB-QH ,  A2=MASS**2 OF HEAVY QUARK
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DHVQCJ=0.
      T=TQ+A2
      U=UQ+A2
      TUMN=-(.5*SQRT(S)-SQRT(.25*S-A2))**2
      IF(T.GT.TUMN) RETURN
      IF(U.GT.TUMN) RETURN
      DHVQCJ=(4./9.)*(TQ**2+UQ**2+2.*A2*S)/S**2
      RETURN
      END
CDECK  ID>, EHL1CJ.
      FUNCTION EHL1CJ(X,Q2,IP)
C     ************************
C-- EHLQ EVOLVED PARTON DENSITIES TIMES X -- SET 2
C-- IP=1,8 -- GLUON, UV, DV, US, S, C, B, T
C-- REV.MOD.PHYS., 56 (1984) 579, ERRATUM 58 (1986) 1065.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TCX(6),TCQ(6)
      DIMENSION LA(8),C(6,6,8),D(6,6,8),TM(8,2),AM(8)
      DIMENSION C1(6,6),C2(6,6),C3(6,6),C4(6,6),C5(6,6),C6(6,6),C7(6,6)
      DIMENSION C8(6,6),D1(6,6),D2(6,6),D3(6,6),D4(6,6),D5(6,6),D6(6,6)
      DIMENSION D7(6,6),D8(6,6)
      DATA LA/6,3,4,5*7/,AM/6*0.,5.5,30./
C-- DATA EHLQ SET 1, 1986
      DATA C1/
     *  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 C2/
     *  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 C3/
     *  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 C4/
     *  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 C5/
     *  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 C6/
     *  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 C7/
     *  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 C8/
     *  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 D1/
     * 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 D2/
     *  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 D3/
     *  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 D4/
     *  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 D5/
     *  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 D6/
     *  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 D7/
     *  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 D8/
     *  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/
      DATA ICALL/0/
      IF(ICALL.GT.0) GO TO 10
      ICALL=1
      ALAMBE=.200
      ALAMB2=ALAMBE*ALAMBE
      TX=LOG(1.E8/ALAMB2)
      TMM=LOG(5./ALAMB2)
      DO 1 M1=1,6
      DO 1 M2=1,2
1     TM(M1,M2)=TMM
      TM(7,1)=8.1905
      TM(7,2)=TM(7,1)
      TM(8,1)=11.5528
      TM(8,2)=TM(8,1)
      DO 2 M1=1,6
      DO 2 M2=1,6
      C(M1,M2,1)=C1(M1,M2)
      C(M1,M2,2)=C2(M1,M2)
      C(M1,M2,3)=C3(M1,M2)
      C(M1,M2,4)=C4(M1,M2)
      C(M1,M2,5)=C5(M1,M2)
      C(M1,M2,6)=C6(M1,M2)
      C(M1,M2,7)=C7(M1,M2)
      C(M1,M2,8)=C8(M1,M2)
      D(M1,M2,1)=D1(M1,M2)
      D(M1,M2,2)=D2(M1,M2)
      D(M1,M2,3)=D3(M1,M2)
      D(M1,M2,4)=D4(M1,M2)
      D(M1,M2,5)=D5(M1,M2)
      D(M1,M2,6)=D6(M1,M2)
      D(M1,M2,7)=D7(M1,M2)
      D(M1,M2,8)=D8(M1,M2)
2     CONTINUE
10    CONTINUE
      IF(IP.LT.7) GO TO 20
      EHL1CJ=0.
      B2=1.-4.*AM(IP)**2/(Q2*(1.-X))
      IF(B2.LT.0.) RETURN
20    CONTINUE
      T=LOG(Q2/ALAMB2)
      IF(X.LE..1) GO TO 200
      X1=(2.*X-1.1)/0.9
      T1=(2.*T-(TX+TM(IP,1)))/(TX-TM(IP,1))
      CALL CJEB(X1,TCX)
      CALL CJEB(T1,TCQ)
      EHL1CJ=0.
      DO 101 MX=1,6
      DO 101 MQ=1,6
101   EHL1CJ=EHL1CJ+C(MX,MQ,IP)*TCX(MX)*TCQ(MQ)
      EHL1CJ=EHL1CJ*(1.-X)**LA(IP)
      IF(EHL1CJ.LT.0.) EHL1CJ=0.
      RETURN
200   Y=(2.*LOG(X)+11.51293)/6.90776
      T1=(2.*T-(TX+TM(IP,2)))/(TX-TM(IP,2))
      CALL CJEB(Y,TCX)
      CALL CJEB(T1,TCQ)
      EHL1CJ=0.
      DO 201 MX=1,6
      DO 201 MQ=1,6
201   EHL1CJ=EHL1CJ+D(MX,MQ,IP)*TCX(MX)*TCQ(MQ)
      EHL1CJ=EHL1CJ*(1.-X)**LA(IP)
      IF(EHL1CJ.LT.0.) EHL1CJ=0.
      RETURN
      END
CDECK  ID>, EHL2CJ.
      FUNCTION EHL2CJ(X,Q2,IP)
C     ************************
C-- EHLQ EVOLVED PARTON DENSITIES TIMES X -- SET 2
C-- IP=1,8 -- GLUON, UV, DV, US, S, C, B, T
C-- REV.MOD.PHYS., 56 (1984) 579, ERRATUM 58 (1986) 1065.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION TCX(6),TCQ(6)
      DIMENSION LA(8),C(6,6,8),D(6,6,8),TM(8,2),AM(8)
      DIMENSION C1(6,6),C2(6,6),C3(6,6),C4(6,6),C5(6,6),C6(6,6),C7(6,6)
      DIMENSION C8(6,6),D1(6,6),D2(6,6),D3(6,6),D4(6,6),D5(6,6),D6(6,6)
      DIMENSION D7(6,6),D8(6,6)
      DATA LA/6,3,4,5*7/,AM/6*0.,5.5,30./
C-- DATA EHLQ SET 2, 1986
      DATA C1/
     *  2.36660,  0.44530,  0.36600,  0.09467,  0.13412,  0.01661,
     * -3.16964, -1.79481,  0.03313, -0.28736, -0.09827, -0.07119,
     *  1.82343,  1.45736, -0.24652,  0.03739,  0.00609,  0.01814,
     * -1.03315, -0.98274,  0.21364,  0.11686,  0.05001,  0.01684,
     *  0.51327,  0.52594, -0.11727, -0.11388, -0.04988, -0.02021,
     * -0.28808, -0.31452,  0.05667,  0.09161,  0.04568,  0.01951/
      DATA C2/
     *  0.72374, -0.21888, -0.29951, -0.01909, -0.01477,  0.00025,
     * -0.53139, -0.24246,  0.32831,  0.11193,  0.02223,  0.00707,
     *  0.22891,  0.18904, -0.09859, -0.06900, -0.01747, -0.00508,
     * -0.10415, -0.10839,  0.02108,  0.02975,  0.00983,  0.00283,
     *  0.04394,  0.05116, -0.00141, -0.01055, -0.00423, -0.00127,
     * -0.01991, -0.02539, -0.00278,  0.00343,  0.00172,  0.00055/
      DATA C3/
     *  0.35776, -0.08622, -0.14799, -0.01840, -0.00782, -0.00045,
     * -0.29250, -0.13038,  0.16959,  0.06243,  0.01353,  0.00375,
     *  0.13182,  0.10408, -0.05486, -0.03872, -0.01038, -0.00285,
     * -0.06162, -0.06143,  0.01303,  0.01740,  0.00594,  0.00167,
     *  0.02643,  0.02957, -0.00149, -0.00645, -0.00263, -0.00077,
     * -0.01218, -0.01497, -0.00126,  0.00224,  0.00112,  0.00035/
      DATA C4/
     *  0.10077, -0.07100,  0.01973, -0.00571,  0.00293, -0.00099,
     * -0.05271, -0.01823,  0.01792, -0.00658,  0.00175, -0.00155,
     *  0.01220,  0.01763, -0.00869, -0.00088, -0.00116, -0.00021,
     * -0.00119, -0.00718,  0.00236,  0.00189,  0.00077,  0.00041,
     * -0.00091,  0.00204, -0.00031, -0.00105, -0.00040, -0.00024,
     *  0.00119, -0.00017, -0.00020,  0.00042,  0.00017,  0.00010/
      DATA C5/
     *  0.06478, -0.04537,  0.01643, -0.00349,  0.00271, -0.00067,
     * -0.02223, -0.02126,  0.01247, -0.00629,  0.00112, -0.00144,
     * -0.00134,  0.01362, -0.00613, -0.00079, -0.00090, -0.00020,
     *  0.00508, -0.00361,  0.00170,  0.00183,  0.00068,  0.00040,
     * -0.00358,  0.00006, -0.00026, -0.00105, -0.00038, -0.00023,
     *  0.00242,  0.00093, -0.00010,  0.00045,  0.00017,  0.00011/
      DATA C6/
     *  0.00998, -0.01945,  0.01055, -0.00687,  0.00186, -0.00156,
     *  0.00570, -0.01203,  0.00625, -0.00486,  0.00131, -0.00137,
     * -0.00449,  0.00799, -0.00417,  0.00205, -0.00044,  0.00033,
     *  0.00147, -0.00248,  0.00146, -0.00057,  0.00012, -0.00001,
     * -0.00009,  0.00015, -0.00032,  0.00012, -0.00006, -0.00004,
     * -0.00042,  0.00076, -0.00014,  0.00004,  0.00007,  0.00005/
      DATA C7/
     *  0.00898, -0.01459,  0.00751, -0.00441,  0.00131, -0.00107,
     *  0.00597, -0.00944,  0.00480, -0.00302,  0.00091, -0.00085,
     * -0.00305,  0.00444, -0.00210,  0.00085, -0.00024,  0.00014,
     *  0.00053, -0.00130,  0.00056, -0.00027,  0.00003, -0.00002,
     *  0.00020,  0.00014, -0.00011,  0.00010,  0.00000,  0.00000,
     * -0.00026,  0.00032,  0.00000, -0.00003,  0.00001, -0.00001/
      DATA C8/
     *  0.00426, -0.00753,  0.00383, -0.00268,  0.00076, -0.00073,
     *  0.00364, -0.00605,  0.00303, -0.00209,  0.00059, -0.00060,
     * -0.00092,  0.00171, -0.00082,  0.00050, -0.00012,  0.00010,
     * -0.00005, -0.00016,  0.00013, -0.00009,  0.00003,  0.00000,
     *  0.00013, -0.00021, -0.00001, -0.00002, -0.00002, -0.00001,
     * -0.00008,  0.00018, -0.00005,  0.00002,  0.00000,  0.00000/
      DATA D1/
     * 30.35544,-40.62373, 15.77920, -3.69929,  0.60204, -0.07031,
     * 26.99749,-41.67159, 17.69848, -4.80436,  0.78620, -0.10596,
     * -1.90878,  1.35687,  1.12665, -0.71813,  0.22324, -0.02481,
     * -0.24877,  0.97811, -0.81272,  0.20935, -0.02997, -0.00471,
     *  0.25061, -0.54273,  0.26717, -0.03103, -0.00180,  0.00287,
     * -0.11277,  0.20870, -0.06972, -0.00248,  0.00263, -0.00084/
      DATA D2/
     *  0.24099,  0.28839,  0.09369,  0.01900,  0.00253,  0.00024,
     *  0.01765, -0.00922, -0.03037, -0.02085, -0.00844, -0.00281,
     * -0.00645, -0.00526,  0.00172,  0.00311,  0.00183,  0.00087,
     *  0.00212,  0.00232,  0.00026, -0.00049, -0.00039, -0.00023,
     * -0.00069, -0.00082, -0.00020,  0.00007,  0.00009,  0.00006,
     *  0.00024,  0.00031,  0.00011,  0.00000, -0.00002, -0.00002/
      DATA D3/
     *  0.12633,  0.13341,  0.03732,  0.00707,  0.00126,  0.00034,
     *  0.00366, -0.01357, -0.01795, -0.01031, -0.00388, -0.00128,
     * -0.00210, -0.00036,  0.00205,  0.00192,  0.00098,  0.00044,
     *  0.00077,  0.00054, -0.00024, -0.00039, -0.00024, -0.00013,
     * -0.00026, -0.00023,  0.00002,  0.00009,  0.00006,  0.00004,
     *  0.00009,  0.00010,  0.00002, -0.00002, -0.00002, -0.00001/
      DATA D4/
     *  1.08105, -1.18897,  0.38685, -0.08617,  0.01115, -0.00118,
     *  0.99169, -1.39649,  0.49978, -0.11585,  0.01674, -0.00172,
     *  0.05099, -0.13384,  0.09173, -0.02885,  0.00589, -0.00065,
     * -0.03178,  0.05703, -0.02070,  0.00244,  0.00011, -0.00009,
     *  0.00897, -0.01392,  0.00205,  0.00065, -0.00023,  0.00002,
     * -0.00234,  0.00301,  0.00050, -0.00039,  0.00006,  0.00001/
      DATA D5/
     *  0.98680, -1.17126,  0.39398, -0.08459,  0.01124, -0.00125,
     *  1.00058, -1.38342,  0.50438, -0.11521,  0.01658, -0.00183,
     *  0.04928, -0.13678,  0.09021, -0.02935,  0.00580, -0.00066,
     * -0.03133,  0.05785, -0.02023,  0.00263,  0.00016, -0.00008,
     *  0.00884, -0.01416,  0.00190,  0.00058, -0.00025,  0.00001,
     * -0.00230,  0.00308,  0.00055, -0.00037,  0.00007,  0.00001/
      DATA D6/
     *  0.86983, -1.13053,  0.38364, -0.08111,  0.01048, -0.00130,
     *  0.96262, -1.32081,  0.48537, -0.10910,  0.01583, -0.00170,
     *  0.03057, -0.10878,  0.08022, -0.02676,  0.00559, -0.00056,
     * -0.02845,  0.05164, -0.01918,  0.00221, -0.00004, -0.00015,
     *  0.01311, -0.01751,  0.00331,  0.00051, -0.00012,  0.00005,
     * -0.00859,  0.00838, -0.00092, -0.00026,  0.00001, -0.00001/
      DATA D7/
     *  0.86718, -1.17370,  0.42652, -0.09252,  0.01244, -0.00146,
     *  0.85004, -1.19366,  0.46304, -0.10831,  0.01614, -0.00183,
     * -0.02241, -0.00563,  0.02815, -0.01425,  0.00352, -0.00043,
     * -0.00073,  0.00803, -0.00578,  0.00138, -0.00013, -0.00004,
     *  0.00346, -0.00538,  0.00196, -0.00021,  0.00001,  0.00001,
     * -0.00485,  0.00595, -0.00189,  0.00026, -0.00003,  0.00000/
      DATA D8/
     *  0.71455, -1.00730,  0.39320, -0.09246,  0.01366, -0.00154,
     *  0.68561, -0.98276,  0.39768, -0.09795,  0.01540, -0.00179,
     * -0.03053,  0.02758,  0.00215, -0.00488,  0.00164, -0.00025,
     *  0.00092,  0.00042, -0.00134,  0.00046, -0.00008, -0.00001,
     *  0.00423, -0.00566,  0.00214, -0.00043,  0.00006,  0.00000,
     * -0.00389,  0.00500, -0.00174,  0.00033, -0.00004,  0.00000/
      DATA ICALL/0/
      IF(ICALL.GT.0) GO TO 10
      ICALL=1
      ALAMBE=.290
      ALAMB2=ALAMBE*ALAMBE
      TX=LOG(1.E8/ALAMB2)
      TMM=LOG(5./ALAMB2)
      DO 1 M1=1,6
      DO 1 M2=1,2
1     TM(M1,M2)=TMM
      TM(7,1)=7.4474
      TM(7,2)=TM(7,1)
      TM(8,1)=10.8097
      TM(8,2)=TM(8,1)
      DO 2 M1=1,6
      DO 2 M2=1,6
      C(M1,M2,1)=C1(M1,M2)
      C(M1,M2,2)=C2(M1,M2)
      C(M1,M2,3)=C3(M1,M2)
      C(M1,M2,4)=C4(M1,M2)
      C(M1,M2,5)=C5(M1,M2)
      C(M1,M2,6)=C6(M1,M2)
      C(M1,M2,7)=C7(M1,M2)
      C(M1,M2,8)=C8(M1,M2)
      D(M1,M2,1)=D1(M1,M2)
      D(M1,M2,2)=D2(M1,M2)
      D(M1,M2,3)=D3(M1,M2)
      D(M1,M2,4)=D4(M1,M2)
      D(M1,M2,5)=D5(M1,M2)
      D(M1,M2,6)=D6(M1,M2)
      D(M1,M2,7)=D7(M1,M2)
      D(M1,M2,8)=D8(M1,M2)
2     CONTINUE
10    CONTINUE
      IF(IP.LT.7) GO TO 20
      EHL2CJ=0.
      B2=1.-4.*AM(IP)**2/(Q2*(1.-X))
      IF(B2.LT.0.) RETURN
20    CONTINUE
      T=LOG(Q2/ALAMB2)
      IF(X.LE..1) GO TO 200
      X1=(2.*X-1.1)/0.9
      T1=(2.*T-(TX+TM(IP,1)))/(TX-TM(IP,1))
      CALL CJEB(X1,TCX)
      CALL CJEB(T1,TCQ)
      EHL2CJ=0.
      DO 101 MX=1,6
      DO 101 MQ=1,6
101   EHL2CJ=EHL2CJ+C(MX,MQ,IP)*TCX(MX)*TCQ(MQ)
      EHL2CJ=EHL2CJ*(1.-X)**LA(IP)
      IF(EHL2CJ.LT.0.) EHL2CJ=0.
      RETURN
200   Y=(2.*LOG(X)+11.51293)/6.90776
      T1=(2.*T-(TX+TM(IP,2)))/(TX-TM(IP,2))
      CALL CJEB(Y,TCX)
      CALL CJEB(T1,TCQ)
      EHL2CJ=0.
      DO 201 MX=1,6
      DO 201 MQ=1,6
201   EHL2CJ=EHL2CJ+D(MX,MQ,IP)*TCX(MX)*TCQ(MQ)
      EHL2CJ=EHL2CJ*(1.-X)**LA(IP)
      IF(EHL2CJ.LT.0.) EHL2CJ=0.
      RETURN
      END
CDECK  ID>, F2INCJ.
      FUNCTION F2INCJ(X,IT)
C     *********************
C-- INITIAL PARTON DENSITIES TIMES X
C-- IFUNCX=0  -- FROM NA3 DRELL-YAN PAIR PRODUCTION EXPERIMENT
C-- IFUNCX=1,2 -- FROM EHLQ, SET 1 AND 2, RESPECTIVELY
C-- IFUNCX=3,4,5,6 -- from Morfin & Tung (March 1990) set 1,2,3,4 resp.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
C-- NXBIN = 2**NXHALF-1, NXBIN1 = 2**NXHALF
      PARAMETER (NXBIN=511,NXBIN1=512,NXHALF=8)
      COMMON/CJTABX/TABQRK(NXBIN,7),XV(NXBIN1),WGQV(7),WGQ,WGG,AGLU
     &,TQLIAS(NXBIN),TGLIAS(NXBIN)
     &,LQLIAS(NXBIN),LGLIAS(NXBIN),LWORKX(NXBIN),KODTBX(7)
      DIMENSION TBXAL(NXBIN),LBXAL(NXBIN)
      EQUIVALENCE (TBXAL,TQLIAS),(LBXAL,LQLIAS)
      DATA ICALL/0/
      IF(ICALL.GT.0) GO TO 5
      ICALL=1
      IF(IFUNCX.EQ.0) THEN
        EGLU=5.
        BBBB1=0.5
        BBBB2=4.3
        BBBB3=5.3
        AU=2./BETACJ(BBBB1,BBBB2)
        AD=1./BETACJ(BBBB1,BBBB3)
        AS=.25
      ELSEIF(IFUNCX.LE.2) THEN
        QE2=QZEVOL**2
      ELSEIF(IFUNCX.LE.6) THEN
        QE=QZEVOL
        ISET=IFUNCX-2
      ENDIF
5     CONTINUE
C
      GO TO(10,20,30,40,50,60,70),IT
C-- U
10    IF(IFUNCX.EQ.0) THEN
        F2INCJ=AU*SQRT(X)*(1.-X)**3.3+AS*(1.-X)**7.7
      ELSEIF(IFUNCX.EQ.1) THEN
        F2INCJ=EHL1CJ(X,QE2,2)+EHL1CJ(X,QE2,4)
      ELSEIF(IFUNCX.EQ.2) THEN
        F2INCJ=EHL2CJ(X,QE2,2)+EHL2CJ(X,QE2,4)
      ELSEIF(IFUNCX.LE.6) THEN
        F2INCJ=PDXCJ(ISET,1,X,QE,IDUMMY)
      ENDIF
      RETURN
C-- UB
20    IF(IFUNCX.EQ.0) THEN
        F2INCJ=AS*(1.-X)**7.7
      ELSEIF(IFUNCX.EQ.1) THEN
        F2INCJ=EHL1CJ(X,QE2,4)
      ELSEIF(IFUNCX.EQ.2) THEN
        F2INCJ=EHL2CJ(X,QE2,4)
      ELSEIF(IFUNCX.LE.6) THEN
        F2INCJ=PDXCJ(ISET,-1,X,QE,IDUMMY)
      ENDIF
      RETURN
C-- D
30    IF(IFUNCX.EQ.0) THEN
        F2INCJ=AD*SQRT(X)*(1.-X)**4.3+AS*(1.-X)**7.7
      ELSEIF(IFUNCX.EQ.1) THEN
        F2INCJ=EHL1CJ(X,QE2,3)+EHL1CJ(X,QE2,4)
      ELSEIF(IFUNCX.EQ.2) THEN
        F2INCJ=EHL2CJ(X,QE2,3)+EHL2CJ(X,QE2,4)
      ELSEIF(IFUNCX.LE.6) THEN
        F2INCJ=PDXCJ(ISET,2,X,QE,IDUMMY)
      ENDIF
      RETURN
C-- DB
40    IF(IFUNCX.EQ.0) THEN
        F2INCJ=AS*(1.-X)**7.7
      ELSEIF(IFUNCX.EQ.1) THEN
        F2INCJ=EHL1CJ(X,QE2,4)
      ELSEIF(IFUNCX.EQ.2) THEN
        F2INCJ=EHL2CJ(X,QE2,4)
      ELSEIF(IFUNCX.LE.6) THEN
        F2INCJ=PDXCJ(ISET,-2,X,QE,IDUMMY)
      ENDIF
      RETURN
C-- S
50    IF(IFUNCX.EQ.0) THEN
        F2INCJ=.5*AS*(1.-X)**7.7
      ELSEIF(IFUNCX.EQ.1) THEN
        F2INCJ=EHL1CJ(X,QE2,5)
      ELSEIF(IFUNCX.EQ.2) THEN
        F2INCJ=EHL2CJ(X,QE2,5)
      ELSEIF(IFUNCX.LE.6) THEN
        F2INCJ=PDXCJ(ISET,3,X,QE,IDUMMY)
      ENDIF
      RETURN
C-- SB
60    IF(IFUNCX.EQ.0) THEN
        F2INCJ=.5*AS*(1.-X)**7.7
      ELSEIF(IFUNCX.EQ.1) THEN
        F2INCJ=EHL1CJ(X,QE2,5)
      ELSEIF(IFUNCX.EQ.2) THEN
        F2INCJ=EHL2CJ(X,QE2,5)
      ELSEIF(IFUNCX.LE.6) THEN
        F2INCJ=PDXCJ(ISET,-3,X,QE,IDUMMY)
      ENDIF
      RETURN
C-- GLUON
70    IF(IFUNCX.EQ.0) THEN
        F2INCJ=AGLU*(1.+EGLU)*(1.-X)**EGLU
      ELSEIF(IFUNCX.EQ.1) THEN
        F2INCJ=EHL1CJ(X,QE2,1)
      ELSEIF(IFUNCX.EQ.2) THEN
        F2INCJ=EHL2CJ(X,QE2,1)
      ELSEIF(IFUNCX.LE.6) THEN
        F2INCJ=PDXCJ(ISET,0,X,QE,IDUMMY)
      ENDIF
      RETURN
      END
CDECK  ID>, F2LXCJ.
      FUNCTION F2LXCJ(ALX)
C     ********************
C-- USED BY CJQCDS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCFUN/LFLAFX,LFLAFQ
      X=EXP(ALX)
      F2LXCJ=F2INCJ(X,LFLAFX)
      RETURN
      END
CDECK  ID>, F2XXCJ.
      FUNCTION F2XXCJ(X)
C     ******************
C-- USED BY CJIALL FOR INTEGRATION TO GET THE COEFFICIENT OF THE NA3
C-- GLUON DISTRIBUTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      F2XXCJ=0.
      DO 1 L=1,6
      LIN=L
1     F2XXCJ=F2XXCJ+F2INCJ(X,LIN)
      RETURN
      END
CDECK  ID>, FGLUCJ.
      FUNCTION FGLUCJ(ALPSQ)
C     **********************
C-- GLUON INTEGRATION FUNCTION USED BY CJQCDT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C
      A=ALPSQ
      PSQ=EXP(A)
      CALL CJZLMS(PSQ,QZFLSQ(LGLU),ZLW,ZUP,FLAG)
      FGLUCJ=PAPICJ(2,ZUP)-PAPICJ(2,ZLW)
      DO 1 L=1,NFLAVT
      CALL CJZLMS(PSQ,QZFLSQ(L),ZLW,ZUP,FLAG)
      IF(FLAG.GT.0) GO TO 2
1     FGLUCJ=FGLUCJ+PAPICJ(3,ZUP)-PAPICJ(3,ZLW)
2     FGLUCJ=FGLUCJ/(A-ALLAM2)
      RETURN
      END
CDECK  ID>, FQRKCJ.
      FUNCTION FQRKCJ(ALPSQ)
C     **********************
C-- QUARK INTEGRATION FUNCTION USED BY CJQCDT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCFUN/LFLAFX,LFLAFQ
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C
      A=ALPSQ
      CALL CJZLIM(EXP(A),QZFLSQ(LFLAFQ),QZFLSQ(LGLU),ZLW,ZUP,FLAG)
      IF(FLAG.GT.0.) GO TO 100
      FQRKCJ=(PAPICJ(1,ZUP)-PAPICJ(1,ZLW))/(A-ALLAM2)
      RETURN
100   FQRKCJ=0.
      RETURN
      END
CDECK  ID>, FMULCJ.
      FUNCTION FMULCJ(Z)
C     ******************
C--  KNO (DE GROOT) MULTIPLICITY FUNCTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      FMULCJ=1.333*Z/(GAMMCJ(Z+1))**2*EXP(-.892*Z)*2.5
      RETURN
      END
CDECK  ID>, FRAMCJ.
      FUNCTION FRAMCJ(D)
C     ******************
C-- GENERATES MULTIPLICITY ACCORDING TO KNO
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NB=250)
      DIMENSION VKNO(NB)
      INTEGER LKNO(NB),LWORKN(NB)
      DATA ICALL/0/
C
      IF(ICALL.GT.0) GO TO 10
      ICALL=1
      TVKNO=0.
      DB=10./FLOAT(NB)
      HDB=DB*.5
      DO 1 M=1,NB
      VKNO(M)=FMULCJ(FLOAT(M)*DB)
1     TVKNO=TVKNO+VKNO(M)
      DO 2 M=1,NB
2     VKNO(M)=VKNO(M)/TVKNO
      CALL CJALIA(LKNO,VKNO,LWORKN,NB)
10    CONTINUE
C
      MX=INT(RNCJ(D)*NB)+1
      IF(RNCJ(D).GT.VKNO(MX)) MX=LKNO(MX)
      FRAMCJ=DB*FLOAT(MX-1)+HDB
      RETURN
      END
CDECK  ID>, IDEXCJ.
      FUNCTION IDEXCJ(IDIN)
C     *********************
C-- GIVES ISAJET ID OF INTERNAL ID
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      IDINA=ABS(IDIN)
      IF(IDINA.GT.0.AND.IDINA.LE.352) THEN
        IDEXCJ=IDHEPF(IDINA)
      ELSE
        IDEXCJ=0
      ENDIF
      RETURN
      END
CDECK  ID>, INIDCJ.
      FUNCTION INIDCJ(ID)
C     *******************
C-- GIVES INTERNAL CODE OF PARTICLE WITH ISAJET CODE ID
C-- RETURN 0 IF NOT A PARTICLE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION LEPT(12),MES0(36),MES1(36)
      DATA LEPT/ 9,10, 7, 8,13,14,11,12,17,18,15,16/
      DATA MES0/51,21,22,52,23,24,25,26,53,28,27,30
     1         ,29,32,31,54,34,33,36,35,38,37,40,39
     2         ,55,42,41,44,43,46,45,48,47,50,49,56/
      DATA MES1/91,61,62,92,63,64,65,66,93,68,67,70
     1         ,69,72,71,94,74,73,76,75,78,77,80,79
     2         ,95,82,81,84,83,86,85,88,87,90,89,96/
C
      INIDCJ=0
      IDA=ABS(ID)
      IF(IDA.LT.10) THEN
        IF(ID.EQ.6)  INIDCJ=19
        IF(ID.EQ.-6) INIDCJ=20
        RETURN
      ENDIF
      IF(MOD(IDA,100)/10.EQ.0) RETURN
      IF(IDA.GT.100) GO TO 10
      IF(IDA.GE.11.AND.IDA.LE.16) GO TO 10
      IF(MOD(IDA,10).NE.0) RETURN
      IF(IDA.GT.20.AND.IDA.LT.80) RETURN
      IF(ID.EQ. 10) INIDCJ= 1
      IF(ID.EQ. 20) INIDCJ=57
      IF(ID.EQ.-20) INIDCJ=58
      IF(ID.EQ. 80) INIDCJ= 3
      IF(ID.EQ.-80) INIDCJ= 4
      IF(ID.EQ. 90) INIDCJ= 2
      RETURN
C-- BREAK DOWN OF ID
10    CONTINUE
      ISGN=1
      IF(ID.LT.0) ISGN=2
      I=IDA/1000
      J=MOD(IDA/100,10)
      K=MOD(IDA/10,10)
      JSPIN=MOD(IDA,10)
      IF(IDA.GT.100) GO TO 50
C-- LEPTONS
      INIDCJ=LEPT(2*(JSPIN-1)+ISGN)
      RETURN
50    IF(IDA.GT.1000) GO TO 100
C-- MESONS
      IF(J.GT.K) RETURN
      IF(J.EQ.K.AND.ISGN.EQ.2) RETURN
      L=(K-1)**2+2*(J-1)+ISGN
      IF(JSPIN.EQ.0) INIDCJ=MES0(L)
      IF(JSPIN.EQ.1) INIDCJ=MES1(L)
      RETURN
100   IF(JSPIN.EQ.1) GO TO 150
C-- J=1/2 BARYONS
      IF(MAX(I,J).GT.K) RETURN
      IF(I.EQ.J.AND.J.EQ.K) RETURN
      INIDCJ=100+(2*(K-2)*(K-1)*K)/3
      IF(J.NE.K) THEN
        IJX=MAX(I,J)
        IJM=MIN(I,J)
        INV=0
        IF(I.GT.J) INV=1
        INIDCJ=INIDCJ+2*(IJX-1)**2+4*(IJM-1)+2*INV+ISGN
      ELSE
        INIDCJ=INIDCJ+2*(K-1)**2+2*(I-1)+ISGN
      ENDIF
      RETURN
150   CONTINUE
C-- J=3/2 BARYONS
      IF(I.GT.J.OR.J.GT.K) RETURN
      INIDCJ=240+((K-1)*K*(K+1))/3+(J-1)*J+2*(I-1)+ISGN
      RETURN
      END
CDECK  ID>, IPDGCJ.
      FUNCTION IPDGCJ(ISA)
C     ********************
C... Converts ISAJET code to PDG code
C...
      DIMENSION K100(100)
      DIMENSION ISPDG(6),I(4),IEX(4),J(4),L(3)
      DATA ISPDG/2,1,3,4,5,6/
      DATA K100/
     & 2,1,3,4,5,6,2*0,21,22
     &,12,11,14,13,16,15,3*0,310
     &,59*0,24,9*0,23,2*0,93,7*0
     &/
C...
      IF(ISA.EQ.93) THEN
        IPDGCJ=ISA
        RETURN
      ENDIF
      IF(ISA.GT.0) THEN
        MISA=1
      ELSE IF(ISA.LT.0) THEN
        MISA=-1
      ELSE
        IPDGCJ=0
        RETURN
      ENDIF
      ISAABS=ABS(ISA)
      I(1)=MOD(ISAABS/1000,10)
      I(2)=MOD(ISAABS/100,10)
      I(3)=MOD(ISAABS/10,10)
      I(4)=MOD(ISAABS,10)
C...
      IF(ISAABS.LE.100) THEN
        IPDGCJ=MISA*K100(ISAABS)
        IF(ISA.EQ.-20) IPDGCJ=130
      ELSEIF(I(1).EQ.0) THEN
C...
C...  MESONS
          J(2)=ISPDG(I(3))
          J(3)=ISPDG(I(2))
        IF(J(2).EQ.J(3)) THEN
          J(2)=ISPDG(J(2))
          J(3)=ISPDG(J(3))
          ISGN=1
        ELSEIF(J(2).GT.J(3)) THEN
          ISGN=1
          IF((-1)**J(2).GT.0) ISGN=-ISGN
        ELSE
          JM=J(2)
          J(2)=J(3)
          J(3)=JM
          ISGN=-1
          IF((-1)**J(2).GT.0) ISGN=-ISGN
        ENDIF
        J(4)=2*I(4)+1
        IPDGCJ=MISA*ISGN*(100*J(2)+10*J(3)+J(4))
      ELSEIF(I(3).NE.0) THEN
C...
C...  BARYONS
C...  IDENTIFY INVERTED ORDER
        IF(I(1).LE.I(2).AND.I(2).LE.I(3)) THEN
          INV=0
        ELSE
          INV=1
        ENDIF
C...
C...    SORTING
        DO 14 K3=1,3
        IF(I(K3).NE.0) THEN
          IEX(K3)=ISPDG(I(K3))
        ELSE
          IEX(K3)=0
        ENDIF
14      CONTINUE
        L(1)=MAX(IEX(1),IEX(2),IEX(3))
        L(3)=MIN(IEX(1),IEX(2),IEX(3))
        L(2)=IEX(1)+IEX(2)+IEX(3)-L(1)-L(3)
C...
        J(1)=L(1)
        IF(INV.EQ.0) THEN
          J(2)=L(2)
          J(3)=L(3)
        ELSE
          J(2)=L(3)
          J(3)=L(2)
        ENDIF
        J(4)=2*I(4)+2
        IPDGCJ=MISA*(1000*J(1)+100*J(2)+10*J(3)+J(4))
      ELSEIF(I(3).EQ.0) THEN
C...
C...  DIQUARKS
        DO 24 K3=1,3
        IF(I(K3).NE.0) THEN
          IEX(K3)=ISPDG(I(K3))
        ELSE
          IEX(K3)=0
        ENDIF
24      CONTINUE
C...
        J(1)=MAX(IEX(1),IEX(2))
        J(2)=MIN(IEX(1),IEX(2))
        J(3)=0
        J(4)=2*I(4)+1
        IPDGCJ=MISA*(1000*J(1)+100*J(2)+10*J(3)+J(4))
      ENDIF
      RETURN
      END
CDECK  ID>, ISACJ.
      FUNCTION ISACJ(PDG)
C     *******************
C... Converts PDG code to ISAJET code
C...
      INTEGER PDG,PDGABS
      DIMENSION K100(100)
      DIMENSION ISPDG(6),I(4),IEX(4),J(4),L(3)
      DATA ISPDG/2,1,3,4,5,6/
      DATA K100/
     & 2,1,3,4,5,6,2*0,21,22
     &,12,11,14,13,16,15,4*0
     &,9,10,90,80,6*0
     &,70*0
     &/
C...
      IF(PDG.EQ.93) THEN
        ISACJ=PDG
        RETURN
      ENDIF
      IF(PDG.GT.0) THEN
        MPDG=1
      ELSEIF(PDG.LT.0) THEN
        MPDG=-1
      ELSE
        ISACJ=0
        RETURN
      ENDIF
      PDGABS=ABS(PDG)
      I(1)=MOD(PDGABS/1000,10)
      I(2)=MOD(PDGABS/100,10)
      I(3)=MOD(PDGABS/10,10)
      I(4)=MOD(PDGABS,10)
C...
      IF(PDGABS.LE.100) THEN
        ISACJ=MPDG*K100(PDGABS)
      ELSEIF(I(4).EQ.0) THEN
        IF(PDG.EQ.310) THEN
          ISACJ=20
        ELSEIF(PDG.EQ.130) THEN
          ISACJ=-20
        ENDIF
      ELSEIF(I(1).EQ.0) THEN
C...
C...  MESONS
          J(2)=ISPDG(I(3))
          J(3)=ISPDG(I(2))
        IF(J(2).EQ.J(3)) THEN
          J(2)=ISPDG(J(2))
          J(3)=ISPDG(J(3))
          ISGN=1
        ELSEIF(J(2).LT.J(3)) THEN
          ISGN=1
          IF((-1)**I(2).GT.0) ISGN=-ISGN
        ELSE
          JM=J(2)
          J(2)=J(3)
          J(3)=JM
          ISGN=-1
          IF((-1)**I(2).GT.0) ISGN=-ISGN
        ENDIF
        J(4)=I(4)/2
        ISACJ=MPDG*ISGN*(100*J(2)+10*J(3)+J(4))
      ELSEIF(I(3).NE.0) THEN
C...
C...  BARYONS
C...  IDENTIFY INVERTED ORDER
        IF(I(1).GE.I(2).AND.I(2).GE.I(3)) THEN
          INV=0
        ELSE
          INV=1
        ENDIF
C...
C...    SORTING
        DO 14 K3=1,3
        IF(I(K3).NE.0) THEN
          IEX(K3)=ISPDG(I(K3))
        ELSE
          IEX(K3)=0
        ENDIF
14      CONTINUE
        L(1)=MIN(IEX(1),IEX(2),IEX(3))
        L(3)=MAX(IEX(1),IEX(2),IEX(3))
        L(2)=IEX(1)+IEX(2)+IEX(3)-L(1)-L(3)
C...
        J(3)=L(3)
        IF(INV.EQ.0) THEN
          J(1)=L(1)
          J(2)=L(2)
        ELSE
          J(2)=L(1)
          J(1)=L(2)
        ENDIF
        J(4)=I(4)/2-1
        ISACJ=MPDG*(1000*J(1)+100*J(2)+10*J(3)+J(4))
      ELSEIF(I(3).EQ.0) THEN
C...
C...  DIQUARKS
        DO 24 K3=1,3
        IF(I(K3).NE.0) THEN
          IEX(K3)=ISPDG(I(K3))
        ELSE
          IEX(K3)=0
        ENDIF
24      CONTINUE
C...
        J(1)=MIN(IEX(1),IEX(2))
        J(2)=MAX(IEX(1),IEX(2))
        J(3)=0
        J(4)=I(4)/2
        ISACJ=MPDG*(1000*J(1)+100*J(2)+10*J(3)+J(4))
      ENDIF
      RETURN
      END
CDECK  ID>, JDENCJ.
      FUNCTION JDENCJ(IDINT)
C     **********************
C-- GIVES ISAJET ID CORRESPONDING TO INTERNAL ID OF QUARK/GLUON
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
      IDINTA=ABS(IDINT)
      IF(IDINTA.LE.6.AND.IDINTA.GT.0) THEN
        JDENCJ=IDINT
      ELSE
        JDENCJ=IDGL
      ENDIF
      RETURN
      END
CDECK  ID>, LABLCJ.
      FUNCTION LABLCJ(IDEN)
C     *********************
C-- GIVES LABEL OF PARTICLE WITH CODE IDEN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJDAT3/CHAP(352),CHAQ(6,2),CHAGL,CHADQ(6,6,2,2)
      CHARACTER*8 CHAP,CHAQ,CHAGL,CHADQ
      CHARACTER*8 LABLCJ
      CHARACTER*8 BLANK
      DATA BLANK/'        '/
      IDENA=ABS(IDEN)
      LABLCJ=BLANK
      IF(IDEN.EQ.0) RETURN
      IF(IDENA.GT.0.AND.IDENA.LE.6) THEN
        IF(IDEN.GT.0) LABLCJ=CHAQ(IDENA,1)
        IF(IDEN.LT.0) LABLCJ=CHAQ(IDENA,2)
      ELSEIF(IDEN.EQ.IDGL) THEN
        LABLCJ=CHAGL
      ELSEIF(MOD(IDENA,100)/10.EQ.0) THEN
        K1=IDENA/1000
        K2=MOD(IDENA/100,10)
        K4=MOD(IDENA,10)
        IF(IDEN.GT.0) THEN
          LABLCJ=CHADQ(K1,K2,K4+1,1)
        ELSE
          LABLCJ=CHADQ(K1,K2,K4+1,2)
        ENDIF
      ELSE
        IN=INIDCJ(IDEN)
        IF(IN.NE.0) LABLCJ=CHAP(IN)
      ENDIF
      RETURN
      END
CDECK  ID>, PAPICJ.
      FUNCTION PAPICJ(IFUN,Z)
C     ***********************
C-- INDEFINITE INTEGRALS OF SPLITTING PROBABILITY FUNCTIONS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXTAB=7,NTAB=129,LGLU=7)
      COMMON/CJQCDC/PI,PI2,ALLAM2,CF,CA,BALPHT
     &,TABPSQ(MAXTAB,NTAB),QSQMXT,ALMIN(MAXTAB),DSTEP(MAXTAB)
     &,QZFLHM(LGLU),QZFL(LGLU),QZFLSQ(LGLU),QTHRSQ(LGLU)
     &,NFLAVT,KODTAB(MAXTAB)
C
      IF(IFUN.EQ.1) GO TO 1
      IF(IFUN.EQ.2) GO TO 2
      IF(IFUN.EQ.3) GO TO 3
C
C-- Q --> Q + G
1     CONTINUE
      Z1=1.-Z
      PAPICJ=-(LOG(Z1)+Z1*(-1.+0.25*Z1))
      PAPICJ=2.*CF*PAPICJ
      RETURN
C
C-- G --> G + G
2     CONTINUE
      PAPICJ=-LOG(1.-Z)+LOG(Z)+Z*(-2.+Z*(0.5-Z/3.))
      PAPICJ=CA*PAPICJ
      RETURN
C
C-- G --> Q + QB
3     CONTINUE
      PAPICJ=(Z**3-(1.-Z)**3)/6.
      RETURN
C
      END
CDECK  ID>, PDXCJ.
      FUNCTION PDXCJ(ISET, IPARTON, X, Q, IRT)
C     ****************************************
C     FUNCTION PDXMT (ISET, IPARTON, X, Q, IRT)
C
C...Private communication from Wu-Ki Tung, 28 March 1990
C...Modified so as to give momentum distribution
C
C   For ISET = 1, 2, 3, 4, returns four sets of Parton Distributions
C   (in the proton) with parton label Iparton (6, 5, ...,0, ...-6)
C   for (t, b, c, s, d, u, g, u-bar, ... t-bar), and kinematic
C   variables (X, Q).   IRT is a return error code.
C
C   Details on the distinquishing features of these distributions are
C   given in a forthcoming preprint by Morfin and Tung.
C
C     IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IFL = IPARTON
C                                                             Valence
      IF (IFL .LE. 0) THEN
        VL = 0
      ELSEIF (IFL .LE. 2) THEN
C       VL = PDZXMT(ISET, IFL, X, Q, IRT)
        VL = PDZXCJ(ISET, IFL, X, Q, IRT)
      ELSE
        VL = 0
      ENDIF
C                                                               Sea
      KP = -ABS (IFL)
C     SEA = PDZXMT (ISET, KP, X, Q, IRT)
      SEA = PDZXCJ (ISET, KP, X, Q, IRT)
 
C     PDXMT = VL + SEA
      PDXCJ = VL + SEA
C
      RETURN
      END
CDECK  ID>, PDZXCJ.
      FUNCTION PDZXCJ(IST, LP, XX, QQ, IRT)
C     *************************************
C     FUNCTION PDZXMT (IST, LP, XX, QQ, IRT)
C
C...Called by PDXCJ
C...Modified so as to give momentum distribution
C
C     IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     PARAMETER (D0=0D0, D1=1D0, D2=2D0, D3=3D0, D4=4D0, D10=1D1)
      PARAMETER (D0=0., D1=1., D2=2., D3=3., D4=4., D10=10.)
      PARAMETER (NEX = 3, MXFL = 6, NPN = 2, NST = 10)
C
      DIMENSION
     1 AC(0:NEX, 0:NPN, -MXFL:2, NST), A(0:NEX), T(0:NPN), FX(0:NEX),
     1 ALM(NST), Q02(NST), MEX(NST), MPN(NST), MQRK(NST)
C
      DATA MEX, MPN, MQRK / NST*3, NST*2, NST*6 /
C                                                     /S1  -  L312
      DATA ALM(1), Q02(1) / 0.187, 4.00 /,
     > (((AC(IEX,IPN,IFL,1), IEX=0,3), IPN=0,2), IFL=2,-6,-1)
     > /1.30, 0.18, 5.27,-1.85,-0.57, 0.16, 0.43, 1.08,-0.08,
     > -0.02, 0.06,-0.03, 1.64, 0.08, 3.74,-2.04,-0.33, 0.14,
     >  0.54, 0.88,-0.10,-0.01, 0.03, 0.02, 1.86,-0.17, 7.33,
     > -0.88,-2.76,-0.07,-0.88, 2.47, 0.10, 0.02,-0.08,-0.32,
     > -0.60,-0.19, 9.31,-1.45,-1.68,-0.16,-1.17, 1.65, 0.08,
     >  0.04, 0.29,-0.20,-0.45,-0.18, 9.36,-1.48,-1.64,-0.19,
     > -1.01, 1.49, 0.05, 0.06, 0.20,-0.12,-1.10,-0.19, 9.07,
     > -1.26,-1.66,-0.09,-1.39, 1.96, 0.13, 0.01, 0.47,-0.36,
     > -3.87,-0.03, 7.96, 0.60, 0.79,-0.17, 0.95, 0.60,-0.70,
     >  0.03,-0.38, 0.08,-6.14,-0.10, 6.90, 0.80, 2.65,-0.03,
     >  1.52, 1.05,-1.24,-0.02,-0.50,-0.14,-12.5,-0.38,16.30,
     > -0.57, 8.13, 0.34,-13.2, 3.58,-2.64,-0.14, 4.77,-0.99/
C                                                     /B1  -  L352
      DATA ALM(2), Q02(2) / 0.212, 4.00 /,
     > (((AC(IEX,IPN,IFL,2), IEX=0,3), IPN=0,2), IFL=2,-6,-1)
     > /1.34, 0.15, 5.30,-1.96,-0.57, 0.16, 0.43, 1.08,-0.08,
     > -0.02, 0.06,-0.03, 1.62, 0.11, 3.68,-1.94,-0.33, 0.14,
     >  0.53, 0.87,-0.10,-0.01, 0.03, 0.02, 1.88,-0.33, 7.52,
     > -1.34,-2.78, 0.10,-1.13, 2.92, 0.13,-0.04, 0.04,-0.49,
     > -0.99,-0.33, 8.53,-1.55,-1.54, 0.03,-1.08, 2.02, 0.10,
     > -0.03, 0.39,-0.39,-0.99,-0.33, 8.53,-1.55,-1.54, 0.03,
     > -1.08, 2.02, 0.10,-0.03, 0.39,-0.39,-0.99,-0.33, 8.53,
     > -1.55,-1.54, 0.03,-1.08, 2.02, 0.10,-0.03, 0.39,-0.39,
     > -3.98,-0.15, 7.46, 0.35, 0.72,-0.06, 0.96, 0.89,-0.63,
     >  0.00,-0.30,-0.04,-6.28,-0.18, 6.56, 0.65, 2.62, 0.02,
     >  1.40, 1.13,-1.18,-0.03,-0.38,-0.16,-13.1,-0.40,15.35,
     > -0.43, 8.54, 0.31,-11.8, 3.18,-2.70,-0.12, 4.16,-0.82/
C                                                     /B2  -  L261
      DATA ALM(3), Q02(3) / 0.191, 4.00 /,
     > (((AC(IEX,IPN,IFL,3), IEX=0,3), IPN=0,2), IFL=2,-6,-1)
     > /1.38, 0.18, 5.40,-1.91,-0.59, 0.16, 0.42, 1.11,-0.08,
     > -0.02, 0.06,-0.03, 1.64, 0.09, 3.74,-2.02,-0.33, 0.14,
     >  0.54, 0.88,-0.10,-0.01, 0.03, 0.02, 1.52,-0.72, 7.75,
     > -2.18,-2.71, 0.45,-1.56, 3.75, 0.15,-0.15, 0.16,-0.76,
     > -0.85,-0.82, 9.19,-2.76,-1.43, 0.35,-0.92, 2.56,-0.03,
     > -0.09, 0.12,-0.40,-0.85,-0.82, 9.19,-2.76,-1.43, 0.35,
     > -0.92, 2.56,-0.03,-0.10, 0.12,-0.40,-0.85,-0.82, 9.19,
     > -2.76,-1.43, 0.35,-0.92, 2.56,-0.03,-0.10, 0.12,-0.40,
     > -3.74,-0.58, 9.63,-1.09, 0.21, 0.24,-1.13, 2.10,-0.50,
     > -0.07, 0.25,-0.33,-6.07,-0.52, 8.33,-0.52, 2.33, 0.22,
     >  0.28, 1.91,-1.15,-0.07,-0.28,-0.31,-12.1,-0.73,21.14,
     > -1.92, 7.31, 0.54,-19.2, 4.59,-2.35,-0.18, 6.64,-1.25/
C                                                     /E1  -  L152
      DATA ALM(4), Q02(4) / 0.155, 4.00 /,
     > (((AC(IEX,IPN,IFL,4), IEX=0,3), IPN=0,2), IFL=2,-6,-1)
     > /1.43, 0.16, 6.17,-1.94,-0.65, 0.16, 0.43, 1.12,-0.08,
     > -0.02, 0.06,-0.02, 1.69, 0.11, 3.69,-1.99,-0.33, 0.14,
     >  0.54, 0.90,-0.11,-0.01, 0.03, 0.02, 2.11,-0.33, 7.93,
     > -1.51,-3.01, 0.10,-1.40, 3.14, 0.18,-0.04, 0.09,-0.55,
     > -0.84,-0.32, 8.96,-1.70,-1.65, 0.02,-1.24, 2.15, 0.12,
     > -0.03, 0.45,-0.43,-0.84,-0.32, 8.96,-1.70,-1.65, 0.02,
     > -1.24, 2.15, 0.12,-0.03, 0.45,-0.43,-0.84,-0.32, 8.96,
     > -1.70,-1.65, 0.02,-1.24, 2.15, 0.12,-0.03, 0.45,-0.43,
     > -3.87,-0.15, 7.83, 0.21, 0.85,-0.07, 1.00, 0.93,-0.73,
     >  0.00,-0.36,-0.03,-6.09,-0.17, 6.75, 0.54, 2.81, 0.01,
     >  1.74, 1.15,-1.34,-0.03,-0.56,-0.16,-12.6,-0.38,14.62,
     > -0.41, 8.69, 0.30,-11.3, 3.19,-2.93,-0.12, 4.29,-0.87/
C
      IRT = 0
      IFL = LP
C
      X  = XX
      Q0 = SQRT (Q02(IST))
      ALAM = ALM(IST)
      SQ = LOG ( LOG(QQ/ALAM) / LOG(Q0/ALAM) )
C
      FX(0) = EXP(D1)
      FX(1) = X
      FX(2) = 1.- X
      FX(3) = LOG (1.+ 1./X)
C
      PDF = 1.
      DO 20 IEX = 0, MEX(IST)
        A(IEX) = AC(IEX, 0, IFL, IST)
        DO 21 IPN = 1, MPN(IST)
          A(IEX) = A(IEX) + AC(IEX, IPN, IFL, IST) * SQ **IPN
21      CONTINUE
        PDF = PDF * FX(IEX) **(A(IEX))
   20 CONTINUE
C
C     PDZXMT = PDF / X
C     PDZXCJ = PDF / X
C...Modified so as to give momentum distribution
      PDZXCJ = PDF
C
      RETURN
      END
CDECK  ID>, PTWGCJ.
      FUNCTION PTWGCJ(QSQ)
C     ********************
C-- ORIGINAL QSQ (APPROX. EQ. TO PT**2 OF HARD PARTONS) PRETABULATION
C-- IS MULTIPLIED BY PTWGCJ(QSQ) IF KPTWGT=1
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NALQ=127,NALQ1=128)
      COMMON/CJALQG/WGALQT(NALQ),WGALQ(NALQ,5,3),Q2VECT(NALQ1)
     &,DALQ,ALQZM,ALQI,ALQF,YF,FRHARD,SIGHRD,FRAGEH
     &,XMIN,PROPTW,PTWGTM
     &,BALPHS,PROGLS,PROFLA(2),ZSLW,ZSUP
     &,THRFLA(6),AM2HEV(6),AMHEV(6)
     &,NFLAVS,NCASC,IVAL
      PTWGCJ=QSQ**2+1.
      RETURN
      END
CDECK  ID>, RNCJ.
      FUNCTION RNCJ(DUMMY)
C     ********************
C...Generates uniformly random number 0 < RNCJ < 1 .
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      REAL RANF
**JWG >>>
      REAL RLU
**JWG <<<
      SAVE ZERO,ONE
      DATA ZERO/0./,ONE/1./
 
**JWG >>>
**JWG2     RNCJ=RANF(DUMMY)
2     RNCJ=RLU (0)
**JWG <<<
      IF(RNCJ.LE.ZERO.OR.RNCJ.GE.ONE) GO TO 2
 
      RETURN
 
      END
CDECK  ID>, XEXPCJ.
      FUNCTION XEXPCJ(A)
C     ******************
C--RETURNS X WHERE DISTRIB. IN X IS GIVEN BY
C--         F(X) = X*EXP(-X)
C--WHERE A IS MIN. VALUE OF X, MAX. ASSUMED INFINITY.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION F(100),X(100)
      DATA AP/0./
      IF(A.EQ.AP) GO TO 150
C--ON FIRST CALL SET UP TABLE
      DO 100 I=1,100
      X(I)=0.2*(FLOAT(I)-1.)+A
      F(I)=EXP(A-X(I))*(1.+X(I))/(1.+A)
100   CONTINUE
C--
150   CONTINUE
      R=RNCJ(XXX)
      DO 300 I=1,100
      IF(R.GT.F(I)) GO TO 400
300   CONTINUE
400   CONTINUE
      IF(I.GT.1) GO TO 450
      XEXPCJ=0.
      AP=A
      RETURN
450   CONTINUE
      XEXPCJ=X(I-1)+0.2*(R-F(I-1))/(F(I)-F(I-1))
      RETURN
      END
CDECK  ID>, ZXSECJ.
      FUNCTION ZXSECJ(DUMMY)
C     **********************
C-- CALCULATES X-SECTION VIA DIRECT CHANNEL Z EXCHANGE
C-- ARGUMENTS FROM /CJWEAK/:
C-- LXI = INITIAL CHANNEL CODE (1,2)
C-- LXF = FINAL CHANNEL CODE   (1,12)
C-- SX  = MANDELSTAM S
C-- RHO4= 4*(FINAL PARTICLE MASS)**2/SX
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
C
      DATA SXL/0./
      IF(ABS(SX-SXL).LT.1.E-5) GO TO 10
      SXL=SX
      DS=SX-SZ(1)
      DEN=1./(DS**2+SZ(2))
      DSDEN=DS*DEN
      SXDEN=SX*DEN
10    CONTINUE
C
      ZERO=0.
      IF(RHO4.EQ.ZERO) THEN
        ZXSECJ=FACTSZ(LXF)*
     *         (2.*(SZF(1,LXI,LXF)/SX
     *             +SZF(2,LXI,LXF)*DSDEN)
     *         +SZF(3,LXI,LXF)*SXDEN)
c        print *,'zx1',SZF(1,LXI,LXF),sx,dsden,sxden,FACTSZ(LXF)
      ELSE
        ZXSECJ=FACTSZ(LXF)*SQRT(ABS(1.-RHO4))*
     *         ((2.+RHO4)*(SZF(1,LXI,LXF)/SX
     *                    +SZF(2,LXI,LXF)*DSDEN)
     *         +(SZF(3,LXI,LXF)+RHO4*SZF(4,LXI,LXF))*SXDEN)
c        print *,'zx2',SZF(1,LXI,LXF),sx,dsden,sxden,FACTSZ(LXF)
      ENDIF
      RETURN
      END
CDECK  ID>, TITLE.
C  INTERFACED TO COJETS
C  ACEJMUSTRAAL.  MONTE CARLO SIMULATION OF RADIATIVE CORRECTIONS TO THE
C  1   PROCESSES E+E- -> MU+MU- AND E+E- -> Q(BAR)Q IN THE Z0 REGION.
C  2   F.A. BERENDS, R. KLEISS, S. JADACH.
C  REF. IN COMP. PHYS. COMMUN. 29 (1983) 185
CDECK  ID>, BKJSTA.
      SUBROUTINE BKJSTA
C     *****************
C-- SETS UP PARAMETERS AND CALCULATES X-SECTION FROM BKJ PACKAGE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      COMMON/CJITAP/ITDKY,ITEVT,ITCOM,ITLIS
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
C-- MXDCZ1 = max number of decay channels + 1 for Z
      PARAMETER (MXDCZ1=13)
      COMMON/CJWEAK/BIM2,BIML2,BIMX2,TG2CAB,FXSCT
     &,AQ(2),BQ(2),AL(2),BL(2)
     &,SW(3),FACTSW
     &,SZ(3),FACTSZ(MXDCZ1),SZF(8,2,MXDCZ1),BTTHR2,TPTHR2
     &,SIGX,SX,DS,DEN,SXX,RHO4
     &,LXI,LXF,NDECZ1
     &,NGEX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      COMMON/BKJSTO/STOIN(8,MXDCZ),STOWE(21,MXDCZ),STOCO(6,MXDCZ)
     $,STOUT(7,MXDCZ),STOSI(10,MXDCZ)
      COMMON / BKINIF/ ENE,SVAR,AEL2,AMU2,ALGEL,ALGMU,BETI,BETF
      COMMON / BKWEAK  / ZZ,GAMM,GM,GG,C0,C1,C2,D1,D2,
     $     C3,C4,D3,D4,QEF,QE2,QF2,BW,ABW,ABW1,FI,DLR
      COMMON / BKCONT/ SWT(6)
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      COMMON / BKSIGM / SIG0,SIGL,ASSL,SOFTOT,ASSNUM,SIGT,SIGTOT,
     $                  SIGN,SIG1,SIGB
      DIMENSION IDFV(MXDCZ),AMFINV(MXDCZ),XSECTV(MXDCZ)
      PARAMETER(MXIBKJ=16)
      DIMENSION IDBKJ(MXIBKJ)
      DATA IDBKJ/-3,-4,-4,-3,-4,-3,4*0,-1,-2,-1,-2,-1,-2/
      DATA XSECTV/MXDCZ*0./
C
      IDBI=IDB(INIDCJ(IDZ))
      DO 1 L=1,NDECZ
      ICH=IDBI-1+L
      IDA=ABS(KDP(1,ICH))
      IF(IDA.LT.1.OR.IDA.GT.16) THEN
        WRITE(ITLIS,11) (KDP(L1,ICH),L1=1,5)
11    FORMAT(5(/),' *** THE FOLLOWING Z DECAY:'
     &/' *** ',5I10
     &/' *** IS NOT ALLOWED IN THE BKJ PACKAGE'
     &/' *** CHANGE THE DECAY TABLE'
     &/' *** JOB ABORT'
     &)
        STOP
      ENDIF
      IF(IDBKJ(IDA).EQ.0) THEN
        WRITE(ITLIS,12) (KDP(L1,ICH),L1=1,5)
12    FORMAT(5(/),' *** THE FOLLOWING Z DECAY:'
     &/' *** ',5I10
     &/' *** IS NOT ALLOWED IN THE BKJ PACKAGE'
     &/' *** CHANGE THE DECAY TABLE'
     &/' *** JOB ABORT'
     &)
        STOP
      ENDIF
      IDFV(L)=IDBKJ(IDA)
1     AMFINV(L)=AMASCJ(IDA)
C
      NL=NFLAV
C
      NEVIN=NLEAVE
      FXSCT=0.
      EB=.5*ECM
      DO 100 L=1,NDECZ
      ICH=IDBI-1+L
      IF(KACTZ(L).EQ.0) GO TO 100
      ZERO=0.
      ONE=1.
      CALL BKSTAR(EB,ZERO,ONE,1,IDFV(L),AMFINV(L))
      CALL CJMOVL(ENE,STOIN(1,L),8)
      CALL CJMOVL(ZZ,STOWE(1,L),21)
      CALL CJMOVL(SWT(1),STOCO(1,L),6)
      CALL CJMOVL(XKMIN,STOUT(1,L),7)
      CALL CJMOVL(SIG0,STOSI(1,L),10)
      DO 101 NDUM=1,NEVIN
      CALL BKEVEN
101   CONTINUE
      CALL BKFINI(CSTOT)
      XSECTV(L)=SIG0*CSTOT*UNITS
      FXSCT=FXSCT+XSECTV(L)
100   CONTINUE
C
C-- FINAL CHANNEL BR'S
      ZERO=0.
      DO 102 L=1,NDECZ
      ICH=IDBI-1+L
      CBR(ICH)=0.
      IF(XSECTV(L).NE.ZERO) CBR(ICH)=XSECTV(L)/FXSCT
102   IF(L.NE.1) CBR(ICH)=CBR(ICH)+CBR(ICH-1)
C
      RETURN
      END
CDECK  ID>, BKJEVE.
      SUBROUTINE BKJEVE(LXF,ACT1,ACT2)
C     ********************************
C-- GENERATES GAMMA-FERMION-ANTIFERMION FINAL STATE FROM BKJ PACKAGE
C-- FINAL CHANNEL DETERMINED BY LXF
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJCONT/
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
     &,IEVTYP
     &,KPBAR ,IFUNCX,NFLAV ,KPRHEV,KFRFLA
     &,KPTWGT
     &,KYEVOL,KYTQCD,KYWQED,KYTQED,KEEQED
     &,KREPET,NREPET
     &,NOFRGM,NODECY,NOUNST,NOBROA,NOPDG
     &,NLEAVE,NSIGMA,NPRESH,NDUMP,NJUMP
     &,NEVGEN,NHARD
      REAL
     & ECM   ,PTMIN ,PTMAX ,BOMSMN,BOMSMX
     &,ALAMBD,CUTJET,PTCUT ,PT2INT,QZEVOL
     &,SIGINL,FACTK ,TOPMAS,ZWTHRS,GMCZW
     &,EMCUT ,BRATIO,TLEAVE
     &,UNITS
      REAL QZ
      EQUIVALENCE (CUTJET,QZ)
C-- NPDECX = max number of secondary particles/partons in decay
C--          (it must be set NDFORC = NPDECX+1 in +KEEP,CJFORC)
C-- MAXDEC = max global number of decay channels
C-- MXDCZ  = max number of decay channels for Z
C--          (it must be set MXDCZ1 = MXDCZ+1 in +KEEP,CJWEAK)
C-- MXDCW  = max number of decay channels for W
C-- MXDCZW = max number of decay channels for W + Z
      PARAMETER (NPDECX=5)
      PARAMETER (MAXDEC=1300,MXDCZ=12,MXDCW=10)
      COMMON/CJDAT2/CBR(MAXDEC),BRW(MXDCW)
     &,DECCTX,DECRX,DECRTX,DECZX
     &,MATRX(MAXDEC),MOTHER(MAXDEC),KDP(NPDECX,MAXDEC)
     &,NDECT,KACTZ(MXDCZ),KACTW(MXDCW),NDECZ,NDECW
      REAL DECCTX,DECRX,DECRTX,DECZX
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      COMMON/BKJSTO/STOIN(8,MXDCZ),STOWE(21,MXDCZ),STOCO(6,MXDCZ)
     $,STOUT(7,MXDCZ),STOSI(10,MXDCZ)
      COMMON / BKINIF/ ENE,SVAR,AEL2,AMU2,ALGEL,ALGMU,BETI,BETF
      COMMON / BKWEAK  / ZZ,GAMM,GM,GG,C0,C1,C2,D1,D2,
     $     C3,C4,D3,D4,QEF,QE2,QF2,BW,ABW,ABW1,FI,DLR
      COMMON / BKCONT/ SWT(6)
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      COMMON / BKSIGM / SIG0,SIGL,ASSL,SOFTOT,ASSNUM,SIGT,SIGTOT,
     $                  SIGN,SIG1,SIGB
      COMMON / BKUTI  / QP(4),QM(4),PH(4)
C
      DIMENSION ACT1(4),ACT2(4)
C
C-- RESTORE COMMON BLOCKS FOR CHANNEL LXF
      L=LXF
      CALL CJMOVL(STOIN(1,L),ENE,8)
      CALL CJMOVL(STOWE(1,L),ZZ,21)
      CALL CJMOVL(STOCO(1,L),SWT(1),6)
      CALL CJMOVL(STOUT(1,L),XKMIN,7)
      CALL CJMOVL(STOSI(1,L),SIG0,10)
C
C-- GENERATE EVENT
      CALL BKEVEN
      EB=.5*ECM
C
C-- RECORD PHOTON IF ANY
      ZERO=0.
      IF(PH(4).NE.ZERO) THEN
        NHEP=NHEP+1
        DO 10 J=1,4
10      PHEP(J,NHEP)=PH(J)*EB
        PHEP(5,NHEP)=0.
        IDHEP(NHEP)=10
        JMOHEP(1,NHEP)=0
        JMOHEP(2,NHEP)=0
        JDAHEP(1,NHEP)=0
        JDAHEP(2,NHEP)=0
        ISTHEP(NHEP)=1
      ENDIF
C
      DO 11 J=1,4
      ACT1(J)=QM(J)*EB
      ACT2(J)=QP(J)*EB
11    CONTINUE
C
      RETURN
      END
CDECK  ID>, BKSTAR.
      SUBROUTINE BKSTAR(ENN,XKMI,XKMA,INRAN,IDF,AMFIN)
CCOJ      SUBROUTINE START(ENN,XKMI,XKMA,INRAN)
C
C     ****************************************************************
C     *                                                              *
C     *                    -MUSTRAAL-                                *
C     *                                                              *
C     *   GENERAL MONTE CARLO PROGRAM FOR SIMULATION OF THE  PROCESS *
C     *                                                              *
C     *               E+  E-   INTO   MU+  MU-   ( PHOTON )          *
C     *               E+  E-   INTO   Q   Q(BAR) ( PHOTON )          *
C     *                                                              *
C     *   INCLUDING PHOTON AND Z0 EXCHANGE                           *
C     *   WITH RADIATIVE CORRECTIONS UP TO ORDER ALPHA**3            *
C     *   AND WITH HARD PHOTON BREMSSTRAHLUNG                        *
C     *                                                              *
C     *                    -AUTHORS-                                 *
C     *                                                              *
C     *        F. A. BERENDS  AND  R.  KLEISS                        *
C     *          INSTITUUT-LORENTZ ,  LEIDEN                         *
C     *                                                              *
C     *                  S. JADACH                                   *
C     *         JAGELLONIAN  UNIVERSITY ,  CRACOW                    *
C     *                                                              *
C     ****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      COMMON / BKCONS / PI,ALFA,ALF1,CMTR
      COMMON / BKINIF/ ENE,SVAR,AEL2,AMU2,ALGEL,ALGMU,BETI,BETF
      COMMON / BKWEAK  / ZZ,GAMM,GM,GG,C0,C1,C2,D1,D2,
     $     C3,C4,D3,D4,QEF,QE2,QF2,BW,ABW,ABW1,FI,DLR
      COMMON / BKCONT/ SWT(6)
      COMMON / BKINOU  / NINP,NOUT
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      COMMON / BKUTI2 / XK,C,S,CG,SG
      COMMON / BKSIGM / SIG0,SIGL,ASSL,SOFTOT,ASSNUM,SIGT,SIGTOT,
     $                  SIGN,SIG1,SIGB
      COMMON / BKRNF   / INIRAN,NGEN
      DATA INIT,ENIT/0,0./
      BWG(X)=(X-ZZ)**2+GG
      FUN1(X)=BETI*(LOG(X)-.5*LOG(1.-X)-.5*X)
      FUN2(X)=BETF*(LOG(X)-X+X*X/4.)
     $+ALF1*(-2.*DLOGBK(X)+.5*(1.-X)*(3.-X)*LOG(1.-X)+1.5*X-X*X/4.)*QF2
      FUNG(X,C1,C2)=((1.-ZZ/BW)*C1+(1.-1./BW)*C2)*.5*LOG(BWG(X)/BW)
     $ +(-GM/BW*C1+(ZZ-2.+ZZ/BW)/GM*C2)*(ATAN((X-ZZ)/GM)+ATAN(ZZ/GM))
      FUNZ(X,C1,C2,ZR)=(C1*ZZ+C2)*LOG(X)/BWG(ZR)-.5*(C1+C2)*X+.25*((2.
     $-ZZ-2.*ZZ/BWG(ZR))*C1+(3.-2.*ZZ-2./BWG(ZR))*C2)*LOG(BWG(X))
     $+(.5*GM*(1.-2./BWG(ZR))*C1+.5/GM*(-4.+3.*ZZ-ZZ**2+GG+2.*ZZ/
     $      BWG(ZR))*C2)*ATAN((X-ZZ)/GM)
      ENE=ENN
      XKMIN=XKMI
      XKMAX=XKMA
CCOJ      IF(ENIT.EQ.ENE) RETURN
      ENIT=ENE
CCOJ      IF(INIT.NE.0) GO TO 10
      IF(INIT.EQ.0) THEN
        INIT=1
        NINP=1
C       NOUT=2
        NOUT=6
        PI=4.*ATAN(1.)
        ALFA=1./137.03604
        ALF1=ALFA/PI
        CMTR=389.385E-30
CC    RANDOM NUMBER FUNCTION INITIALISATION
        INIRAN=INRAN
        NGEN=9
        DUMMY=RNF1BK(-2)
      ENDIF
C***
C***  WEAK COUPLING CONSTANTS AND Z0 WIDTH INITIALISATION
CCOJ      SINW2=.23
      SINW2=SIN2W
      IDE=-2
CCOJ      IDF=-2
C     IDE IS THE INCOMING FERMION IDENTIFIER
C     IDF IS THE OUTGOING FERMION IDENTIFIER
C     IDF=2   MUON,TAU...
C     IDF=3   UP QUARK   ( U,C,T...)
C     IDF=4   DOWN QUARK  ( D,S,B...)
C     IDF NEGATIVE DENOTES ANTIPARTICLE
C     IDE=-2   INCOMING POSITRON
      CALL BKSETW(IDE,SINW2,QCE,CVE,CAE,AMZ,GAMM)
      CALL BKSETW(IDF,SINW2,QCF,CVF,CAF,AMZ,GAMM)
C     COLOUR FACTOR
      COLR=1.
      IF(ABS(IDF).GT.2) COLR=3.
      QEF=QCE*QCF
      QE2=QCE**2
      QF2=QCF**2
      C0=QEF**2*COLR
      C1=2.*QEF*CVE*CVF*COLR
      C2=(CVE*CVE+CAE*CAE)*(CVF*CVF+CAF*CAF)*COLR
      D1=4.*QEF*CAE*CAF*COLR
      D2=8.*CVE*CAE*CVF*CAF*COLR
      C3=QEF*(CVE*CAF-CAE*CVF)*COLR
      D3=QEF*(CVE*CAF+CAE*CVF)*COLR
      C4=((CVE**2+CAE**2)*CVF*CAF-(CVF**2+CAF**2)*CAE*CVE)*COLR
      D4=((CVE**2+CAE**2)*CVF*CAF+(CVF**2+CAF**2)*CAE*CVE)*COLR
      XK0=.01
C
C
CCOJ   10 WRITE(NOUT,1000) ENE,XKMIN,XKMAX,INIRAN,AMZ,GAMM
      DO 15 I=1,6
   15 SWT(I)=0.
      SVAR=4.*ENE*ENE
      GM=GAMM*AMZ/SVAR
      GG=GM*GM
      ZZ=1.-AMZ**2/SVAR
      BW=ZZ*ZZ+GG
      AEL=.5111E-3/ENE
      AMU=AMFIN/ENE
      AEL2=AEL**2
      AMU2=AMU**2
      ALGEL=LOG(4./AEL2)
      ALGMU=LOG(4./AMU2)
      XKH=1.-AMU/2.
      IF(XKMIN.LT.XK0) XKMIN=0.
      XKMAX=MIN(XKMAX,1.-AMU2)
      XK1=MAX(XK0,XKMIN)
      XK2=MAX(XK0,XKMAX)
      XK2=MIN(XK2,XKH)
      SIG0=4.*PI*ALFA**2/3./SVAR
C
C     SOFT PHOTON PARAMETERS
      ALK0=LOG(XK0)
      BETI=2.*QE2*ALF1*(ALGEL-1.)
      BETF=2.*QF2*ALF1*(ALGMU-1.)
      CALL BKPIHI(SVAR,PIRE,PIIM)
C
      DELI=ALF1*QE2*(9.*ALGEL+2.*PI**2-12.)/6.+    BETI*ALK0
      DELF=ALF1*QF2*(9.*ALGMU+2.*PI**2-12.)/6.+    BETF*ALK0
      CZC=(ZZ*C1+C2)/BW
      CZD=(ZZ*D1+D2)/BW
      SIGL=C0+CZC
      ASSL=3./8.*CZD/SIGL
      ASYM=CZD*(1.+DELI+DELF)+D1/BW*(-ZZ*PIRE+GM*PIIM)
     $    +BETI*FUNG(XK0,D1,D2)
      ABW=LOG(BWG(XK0)/BW)
      ABW1=LOG((1.-ZZ)/BWG(XK0))
      FI=ATAN(ZZ/GM)
      DLR=.5*PI+FI
      FI=ATAN((XK0-ZZ)/GM)+FI
      SOF1=C0+CZC
      SOF2=-2.*C0*PIRE+C1/BW*(-ZZ*PIRE+GM*PIIM)
      SOF3=(C0+CZC)*DELI+BETI*FUNG(XK0,C1,C2)
      SOF4=(C0+CZC)*DELF
      SOFT=SOF1+SOF2+SOF3+SOF4
      IF(XKMIN.GE.XK0) SOFT=0.
      SOFTOT=0.
      FOR=0.
      BAC=0.
      DO 200 J=1,39
      C=-1.+.05*FLOAT(J)
      WT=WTHBK(3)
      IF(C.GT.0.) FOR=FOR+SIG1
      IF(C.LT.0.) BAC=BAC+SIG1
  200 SOFTOT=SOFTOT+SIG1/39.
      SOFTOT=.75*SOFTOT
      ASSNUM=(FOR-BAC)/(FOR+BAC)
      ZR=0.
      SIGHI=C0*(FUN1(XK2)-FUN1(XK1))
     $     +BETI*(FUNZ(XK2,C1,C2,ZR)-FUNZ(XK1,C1,C2,ZR))
      IF(XK2.EQ.XKH)
     $ SIGHI=SIGHI+C0*BETI*(.5*LOG(1.-XK2)+.5*ALGMU-5./6.)
      SIGHF=(C0+CZC)*(FUN2(XK2)-FUN2(XK1))
      SIGT=SOFT+SIGHI+SIGHF
C
      SIGTOT=XKDEBK(1.)
C
CCOJ      WRITE(NOUT,1005)
CCOJ      WRITE(NOUT,1006)  SOF1,SOF2,SOF3,SOF4,SOFT
CCOJ      WRITE(NOUT,1007) SIGHI,SIGHF
CCOJ      WRITE(NOUT,1008) SIGT
CCOJ      SIG0CM=SIG0*CMTR
CCOJ      WRITE(NOUT,1010)    SIG0CM
C
C-------
C
      RETURN
 1000 FORMAT(1H1,///,1X,10(10H**********),//
     -  /20X,    40HSTART PARAMETERS ARE ...                ,
     -  /50X,    10HENERGY    ,F10.6,10H  GEV     ,
     -  /50X,    10HXKMIN     ,F10.6,
     -  /50X,    10HXKMAX     ,F10.6,
     -  /50X,    10HINRAN     ,I10,
     -  /10X,    10HZ0 MASS   ,F6.3,4H GEV,
     -  /10X,    10HZ0 WIDTH  ,F6.3,4H GEV)
 1005 FORMAT(1H0,
     -  /20X,    40HCONTRIBUTIONS TO CROSS SECTION ARE ...  )
 1006 FORMAT(1H0,
     -  /20X,    40HLOWEST ORDER                            ,F10.4,
     -  /20X,    40HALL VACUUM POLARISATION CONTRIBUTIONS   ,F10.4,
     -  /20X,    40HINIT. STATE SOFT BREMTR. + VERTEX       ,F10.4,
     -  /20X,    40HFINAL STATE SOFT BREMST. + VERTEX       ,F10.4,
     -  /20X,    40HTOTAL SOFT CROSS SECTION                ,F10.4)
 1007 FORMAT(1H0,
     -  /20X,    40HHARD PHOTON EMISSION FROM INIT. STATE   ,F10.4,
     -  /20X,    40HHARD PHOTON EMISSION FROM FINAL STATE   ,F10.4)
 1008 FORMAT(1H0,
     -  /20X,    40HTOTAL CROSS SECTION , APPROXIMATE       ,F10.4)
 1010 FORMAT(1H ,
     -  /20X,    40HALL ABOVE CROSS SECTIONS ARE GIVEN IN   ,
     -  /20X,    40HUNITS OF THE LOWEST ORDER ( POINTLIKE ) ,
     -  /20X,    40HONE PHOTON CROSS-SECTION  SIG0 WHICH IS ,
     -  /20X,    10HEQUAL TO  ,E20.5,6H CM**2)
      END
CDECK  ID>, BKFINI.
      SUBROUTINE BKFINI(CSTOT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKCONT/ SWT(6)
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      COMMON / BKSIGM / SIG0,SIGL,ASSL,SOFTOT,ASSNUM,SIGT,SIGTOT,
     $                 SIGN,SIG1,SIGB
      COMMON / BKINOU / NINP,NOUT
C
      DO 1 L=1,6
1     SWT(L)=SWT(L)+1.E-7
      AWTS=SWT(2)/SWT(1)
      DWTS=SQRT(SWT(3)/SWT(2)**2-1./SWT(1))
C
      SWT(4)=SWT(4)+.0001
      AWTH=SWT(5)/SWT(4)
      DWTH=SQRT(SWT(6)/SWT(5)**2-1./SWT(4))
C
      AWT =(SWT(2)+SWT(5))/(SWT(1)+SWT(4))
      DWT =SQRT((SWT(3)+SWT(6))/(SWT(2)+SWT(5))**2-1./(SWT(1)+SWT(4)))
C
      CSOFT=SOFT*AWTS
      CSHAR=(SIGT-SOFT)*AWTH
      CSTOT=SIGT*AWT
      NSOF=INT(SWT(1))
      NHAR=INT(SWT(4))
      NTOT=NSOF+NHAR
      DWTS=DWTS*100.
      DWTH=DWTH*100.
      DWT=DWT*100.
C
CCOJ      WRITE(NOUT,1000)       NSOF,AWTS,CSOFT,DWTS,
CCOJ     $                       NHAR,AWTH,CSHAR,DWTH,
CCOJ     $                       NTOT,AWT ,CSTOT,DWT
C
 1000 FORMAT(1H1,///,1X,10(10H**********),/,7H FINISH,//
     -  /21X ,20H NO. OF CRUDE EVENTS,20H      AVERAGE WEIGHT
     -       ,20H    EXACT  X SECTION,20H       PERCENT ERROR,
     -  /11X ,10HSOFT PART ,I20,2F20.6,F20.2,
     -  /11X ,10HHARD PART ,I20,2F20.6,F20.2,
     -  /11X ,10HTOTAL     ,I20,2F20.6,F20.2,/
     -  /11X ,28HCROSS SECTIONS IN SIG0 UNITS,///)
      RETURN
      END
CDECK  ID>, BKSETW.
      SUBROUTINE BKSETW(IDF,SIN2,QC,CV,CA,AMZ,GAMM)
C SETWS CALCULATES CV,CA AND MZ THSAT CORRESPOND TO A GIVEN VALUE
C GLAHOW-WEINBERG-SALAM MODEL ARE USED.
C SINCE THE ENTRIES MZ,GZ,CV,CA IN *START* ARE ALL INDEPENDENT,
C THE USE OF THE G-W-S MODEL IS IN NO WAY MANDATORY.
C IDF IS QUARK OR LEPTON IDENTIFIER, QC ITS CHARGE  (S.J.)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/CJDAT1/PMAS(352),WIDTHP(352),WCUTP(352),CTAU(352)
     &,QMAS(6),CHARGQ(6),CMIX(6,2),CND1,CND2,BZDMIX,BZSMIX
     &,IDB(352),LCHARG(352),IDHEPF(352),KDECAY(352),KANTIP(352),IDGL
      REAL PMAS,WIDTHP,WCUTP,CTAU
     &,QMAS,CHARGQ,CMIX,CND1,CND2,BZDMIX,BZSMIX
      COMMON/CJPZW/ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
     &,IDZ,IDWP,IDWM,KINTZ,KINTWP,KINTWM,IZTOP
      REAL ALFQED,SIN2W,COSCAB,ZMASS,WMASS,ZGAMMA,WGAMMA
      B=1./SQRT(16.*SIN2*(1.-SIN2))
CCOJ      AMZ=2.*B*74.584
CCOJ      GAMM=2.5
      AMZ=ZMASS
      GAMM=ZGAMMA
      IDFERM=ABS(IDF)
      GO TO (1,2,3,4), IDFERM
C     NOT USED  ( NEUTRINO )
    1 QC=0.
      CV=B
      CA=B
      GO TO 500
C     ELECTRON, MUON ...
    2 QC=-1.
      CV=(-1.+4.*SIN2)*B
      CA=-B
      GO TO 500
C     UP QUARKS
    3 QC=2./3.
      CV=(1.-8./3.*SIN2)*B
      CA=B
      GO TO 500
C     DOWN QUARKS
    4 QC=-1./3.
      CV=(-1.+4./3.*SIN2)*B
      CA=-B
  500 IF(IDF.GT.0) RETURN
C     ANTIPARTICLES
      QC=-QC
      CV=-CV
      CA=-CA
      RETURN
      END
CDECK  ID>, BKPIHI.
      SUBROUTINE BKPIHI(S,PIRE,PIIM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKINOU  / NINP,NOUT
C...HADRONIC VACUUM POLARIZATION BY LOGARITHMIC INTERPOLATION
C...THIS IS A GOOD APPROXIMATION FAR FROM RESONANCES
C...THE VALUES OF SS ARE CHOSEN TO BE LOGARITHMICALLY
C...DISTRIBUTED ; THE VALUES OF REPIH ARE CALCULATED
C...USING PIH (GAUSSIAN INTEGRATION + ANALYTIC CONTRIBUTIONS OF RES.)
      DIMENSION SS(20),REPIH(20)
      DATA (SS(I),I=1,20)
     Z   / 0.100E-01,0.196E-01,0.384E-01,0.753E-01,
     Z   0.148E+00,0.289E+00,0.567E+00,0.111E+01,
     Z   0.218E+01,0.427E+01,0.837E+01,0.164E+02,
     Z   0.321E+02,0.630E+02,0.123E+03,0.242E+03,
     Z   0.474E+03,0.930E+03,0.182E+04,0.357E+04/
      DATA (REPIH(I),I=1,20)
     Z   / -0.101E-03,-0.194E-03,-0.367E-03,-0.673E-03,
     Z   -0.118E-02,-0.195E-02,-0.299E-02,-0.425E-02,
     Z   -0.569E-02,-0.728E-02,-0.905E-02,-0.110E-01,
     Z   -0.131E-01,-0.153E-01,-0.175E-01,-0.198E-01,
     Z   -0.221E-01,-0.245E-01,-0.268E-01,-0.292E-01/
      DATA DELTA/0.672944/
CCOJ      IF((S.GT.(0.04)).AND.(S.LT.(120.))) WRITE(NOUT,5) S
    5 FORMAT(//,10X,3HS =,F7.3,8H GEV*2;*,/,
     Z 10X,48HFOR THIS VALUE PIH MAY BE BADLY APPROXIMATED DUE,/,
     Z 10X,49HTO THE PRESENCE OF MANY RESONANCES UNDER W=10 GEV)
    6 S=ABS(S)
      IF(S.LE.SS(1)) GO TO 3
      DO 1 J=2,20
      J2=J
      IF(S.LE.SS(J)) GO TO 2
    1 CONTINUE
    2 PIRE=REPIH(J2-1)
     Z     +(REPIH(J2)-REPIH(J2-1))*LOG(S/SS(J2-1))/DELTA
      PIREL=1./430./9.*(5.-3.*LOG(S/.5111E-3**2))
      PIRMU=1./430./9.*(5.-3.*LOG(S/.10566**2))
      A=SQRT(1.-4.*1.782**2/S)
      PIRTA=1./430.*(8./9.-A*A/3.+A*(3.-A*A)*LOG((1.-A)/(1.+A))/6.)
      PIRE=PIRE+PIREL+PIRMU+PIRTA
      PIIM=20./9./137.03604
      RETURN
    3 PIRE=0.
      PIIM=0.
      RETURN
      END
CDECK  ID>, BKEVEN.
      SUBROUTINE BKEVEN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKINIF/ ENE,SVAR,AEL2,AMU2,ALGEL,ALGMU,BETI,BETF
      COMMON / BKCONT/ SWT(6)
      COMMON / BKWEAK  / ZZ,GAMM,GM,GG,C0,C1,C2,D1,D2,
     $     C3,C4,D3,D4,QEF,QE2,QF2,BW,ABW,ABW1,FI,DLR
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      COMMON / BKUTI2 / XK,C,S,CG,SG
CC
CC    GENERATION OF THE PHOTON MOMENTUM XK AND DECISION ABOUT THE
CC    TYPE OF THE RADIATION  IT=1,2,3 CORRESPONDS TO INITIAL STATE
CC    RADIATION, FINAL STATE RADIATION AND SOFT PHOTON (XK.LT.XK0)
CC    RADIATION
C
    1 CALL BKXKGE(IT)
      IF(IT-2) 10,20,30
C
C
C     HARD PHOTON CASE - INITIAL STATE
   10 CONTINUE
      XKM=1.-XK
      BWK=(XK-ZZ)*(XK-ZZ)+GG
C     GENERATION OF THE PHOTON ANGULAR ANGULAR DISTRIBUTION
      CALL BKRRR6(XK,.5*AEL2,CG,SG,IBREM)
C     GENERATION OF THE FINAL FERMION DISTRIBUTION
      AS=(D1*(ZZ-XK)+D2*XKM)/BWK
      SY=C0/XKM+(C1*(ZZ-XK)+C2*XKM)/BWK
      R=.5-.25*AS/SY
      CALL BKRRR7(R,C,S)
C     CONSTRUCTION OF THE FINAL MOMENTA FROM ANGULAR VARIABLES
      CALL BKKINO(IT,IBREM)
      WT=WTHBK(IT)
      SWT(4)=SWT(4)+1.
      SWT(5)=SWT(5)+WT
      SWT(6)=SWT(6)+WT*WT
C     IMPOSING INTERFERENCE THERM BY THE SUPLEMENTARY FINAL WEIGHT
      IF(2.*RNCJ(1).GT.WT) GO TO 1
      RETURN
C
C
C     HARD PHOTON CASE - FINAL STATE
   20 CONTINUE
C     PHOTON ANGULAR COORDINATES GENERATION
      CALL BKRRR6(XK,.5*AMU2/(1.-XK),CG,SG,IBREM)
      AS=(D1*ZZ+D2)/BW
      SY=C0+(C1*ZZ+C2)/BW
      R=.5-.25*AS/SY
C     FERMION ANGULAR COORDINATES
      CALL BKRRR7(R,C,S)
C     FINAL MOMENTA CONSTRUCTION OUT OF ANGLES
      CALL BKKINO(IT,IBREM)
      WT=WTHBK(IT)
      SWT(4)=SWT(4)+1.
      SWT(5)=SWT(5)+WT
      SWT(6)=SWT(6)+WT*WT
C     IMPOSING INTERFERENCE THERM ON THE GENERATED DISTRIBUTION
      IF(2.*RNCJ(2).GT.WT) GO TO 1
      RETURN
C
C
C     SOFT PHOTON CASE  XK.LT.XK0
   30 CONTINUE
      R=.5-.25*ASYM/SOFT
C     ANGULAR DISTRIBUTION GENERATION
      CALL BKRRR7(R,C,S)
      WT=WTHBK(IT)
      SWT(1)=SWT(1)+1.
      SWT(2)=SWT(2)+WT
      SWT(3)=SWT(3)+WT*WT
C     IMPOSING INTERFERENCE THERMS AND BOX DIAGRAM CONTRIBUTION
C     ON THE PREVIOUSLY GENERATED ANGULAR DISTRIBUTION
      IF(2.*RNCJ(8).GT.WT) GO TO 1
C     MOMENTA CONSTRUCTION
      CALL BKKINO(IT,DUM)
      RETURN
      END
CDECK  ID>, BKXKGE.
      SUBROUTINE BKXKGE(IT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKINIF/ ENE,SVAR,AEL2,AMU2,ALGEL,ALGMU,BETI,BETF
      COMMON / BKWEAK  / ZZ,GAMM,GM,GG,C0,C1,C2,D1,D2,
     $     C3,C4,D3,D4,QEF,QE2,QF2,BW,ABW,ABW1,FI,DLR
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      COMMON / BKUTI2 / XK,C,S,CG,SG
      BWG(X)=(X-ZZ)**2+GG
C
      R=RNF1BK(8)
      XK=RRGEBK(R)
      XK=MIN(XK,1.-AMU2)
      IF(XK.GT.XK0) GO TO 10
      IT=3
      RETURN
   10 XKM=1.-XK
      XKM=MAX(XKM,AMU2)
      BONMAR=(1.+XKM*XKM)*.5/XK
      RINI=BONMAR*BETI*(C0/XKM+(C1*(ZZ-XK)+C2*XKM)/BWG(XK))
      RFIN=BONMAR*BETF*(1.+LOG(XKM)/(ALGMU-1.))*(C0+(C1*ZZ+C2)/BW)
      IT=2
      R=RNF1BK(9)
      IF(R.LT.RINI/(RINI+RFIN)) IT=1
      RETURN
      END
CDECK  ID>, XKDEBK.
      FUNCTION XKDEBK(XK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKINIF/ ENE,SVAR,AEL2,AMU2,ALGEL,ALGMU,BETI,BETF
      COMMON / BKWEAK  / ZZ,GAMM,GM,GG,C0,C1,C2,D1,D2,
     $     C3,C4,D3,D4,QEF,QE2,QF2,BW,ABW,ABW1,FI,DLR
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      DATA ENIT /.0/
      BWG(X)=(X-ZZ)**2+GG
      FUNH(X)=BETI*( H0*LOG(1.-X)+H1*LOG(X)+H2*X +H3*LOG(BWG(X))
     $         +H4*ATAN((X-ZZ)/GM))
      FUNF(X)=BETF*H1*(LOG(X)-X+.25*X*X+.5/(ALGMU-1.)*
     $      (-2.*DLOGBK(X)+.5*(1.-X)*(3.-X)*LOG(1.-X)+1.5*X-X*X/4.))
      FUNB(Y)=BETI*C0*(-LOG(SQRT(Y)+SQRT(Y-AMU2))
     %       +5./6.*SQRT((Y-AMU2)/Y)*(1.-2.*AMU2/Y))
C
      IF(ENIT.EQ.ENE) GO TO 10
      ENIT=ENE
      XKMX=1.-AMU2
      H0=-.5*C0
      H1=C0+(C1*ZZ+C2)/BW
      H2=-.5*(C0+C1+C2)
      H3=.5*(1.-.5*ZZ-ZZ/BW)*C1+.5*(1.5-ZZ-1./BW)*C2
      H4=GM*(.5-1./BW)*C1+.5/GM*(-4.+3.*ZZ-ZZ*ZZ+GG+2.*ZZ/BW)*C2
      SUDIS0=SOFT-FUNH(XK0)-FUNF(XK0)
      SUDISH=SUDIS0+FUNH(XKH)+FUNF(XKH)-FUNB(1.-XKH)
      SUDIST=SUDISH+FUNB(AMU2)
   10 XKM=1.-XK
7771  XKM=MAX(XKM,AMU2)
      IF(XK.GT.0.) GO TO 110
      XKDEBK=0.
      RETURN
  110 IF(XK.GT.XK0) GO TO 120
      XKDEBK=SOFT*XK/XK0
      RETURN
  120 IF(XK.GT.XKH) GO TO 130
      XKDEBK=SUDIS0+FUNH(XK)+FUNF(XK)
      RETURN
  130 IF(XK.GT.XKMX)   GO TO 140
      XKDEBK=SUDISH+FUNB(XKM)
      RETURN
  140 XKDEBK=SUDIST
      RETURN
      END
CDECK  ID>, RRGEBK.
      FUNCTION RRGEBK(R)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      DIMENSION  XX(1025),LIST(11)
      DATA LIST
     $/1,2,3,4,64,256,1024,4096,16384,65536,-1/
      DATA IEV,LEN /0,1024/
C
      IEV=IEV+1
      IF(R.LT.0.) IEV=1
      IF(IEV.NE.1) GO TO 10
      IP=1
      EPS =.05/FLOAT(LEN)
      EPS1=.00025
      ID=LEN
      IW=1
      XW=1.
      XX(1)=XKMIN
      XX(LEN+1)=XKMAX
      F0=XKDEBK(XKMIN)
      DF=XKDEBK(XKMAX)-F0
   10 CONTINUE
      IF(IEV.NE.LIST(IP))GO TO 300
      IP=IP+1
      DO 100 I=1,IW
      IA1=ID*(I-1)+1
      IA2=IA1+ID
      IA=(IA1+IA2)/2
C     ITERATION COME ON
      X1=XX(IA1)
      X2=XX(IA2)
      IF((X2-X1).LT.EPS1) GO TO 31
      Y1=XKDEBK(X1)
      Y2=XKDEBK(X2)
      Y=FLOAT(IA-1)/FLOAT(LEN)
      DO 30  ITER=1,30
      X=.5*(X1+X2)
      F=(XKDEBK(X)-F0)/DF
      IF(Y-F) 20,31,21
   20 X2=X
      Y2=Y
      GO TO 23
   21 X1=X
      Y1=Y
   23 IF((Y2-Y1) .LT.EPS.AND.(X2-X1).LT.EPS1) GO TO 31
   30 CONTINUE
   31 XX(IA)=.5*(X1+X2)
C     END OF ITERATION
  100 CONTINUE
      ID=ID/2
      IW=IW*2
      XW=XW*2.
C
  300 CONTINUE
      I=INT(.5*XW*R)
      IA1=2*I*ID+1
      IA2=IA1+ID
      IA3=IA2+ID
      X1=XX(IA1)
      X2=XX(IA2)
      X3=XX(IA3)
      Y=R*XW-FLOAT(2*I)
      X=.5*(Y-1.)*(Y-2.)*X1-Y*(Y-2.)*X2+.5*Y*(Y-1.)*X3
      X=MAX(X,X1)
      X=MIN(X,X3)
      RRGEBK=X
      RETURN
      END
CDECK  ID>, WTHBK.
      FUNCTION WTHBK(IT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKCONS / PI,ALFA,ALF1,CMTR
      COMMON / BKINIF/ ENE,SVAR,AEL2,AMU2,ALGEL,ALGMU,BETI,BETF
      COMMON / BKWEAK  / ZZ,GAMM,GM,GG,C0,C1,C2,D1,D2,
     $     C3,C4,D3,D4,QEF,QE2,QF2,BW,ABW,ABW1,FI,DLR
      COMMON / BKUTI  / QP(4),QM(4),PH(4)
      COMMON / BKUTI1 / XKMIN,XKMAX,XKH,XK0,ALK0,SOFT,ASYM
      COMMON / BKUTI2 / XK,C,S,CG,SG
      COMMON / BKSIGM / SIG0,SIGL,ASSL,SOFTOT,ASSNUM,SIGT,SIGTOT,
     $                  SIGN,SIG1,SIGB
C
      IF(IT-2) 10,10,20
C
   10 CONTINUE
      T=2.*(QP(4)-QP(3))
      U=2.*(QM(4)-QM(3))
      T1=2.*(QM(4)+QM(3))
      U1=2.*(QP(4)+QP(3))
      Y1=PH(4)-PH(3)
      Y2=PH(4)+PH(3)
      Y3=2.*(1.-QM(4))
      Y4=2.*(1.-QP(4))
CC    INTERFERENCE CONTRIBUTION
      W=T*Y2*Y4+T1*Y1*Y3-U*Y2*Y3-U1*Y1*Y4
      W=W/(Y1*Y2*Y3*Y4)
      BWK=(ZZ-XK)*(ZZ-XK)+GG
      XKM=1.-XK
      TT=T*T+T1*T1+U*U+U1*U1
      VV=.5*(U*U+U1*U1-T*T-T1*T1)
      TT0=C0*TT
      TT1=C1*TT+D1*VV
      TT2=C2*TT+D2*VV
      D12=1.-.5*AEL2/(XKM+1./XKM)*(Y1/Y2+Y2/Y1)
      D34=1.-.5*AMU2/XKM/(XKM+1./XKM)*(Y3/Y4+Y4/Y3)
      ASQI=D12/Y1/Y2*(TT0/XKM+TT1*(ZZ-XK)/BWK+TT2*XKM/BWK)
      ASQF=D34/Y3/Y4*(TT0+TT1*ZZ/BW+TT2/BW)
      AIN=.25*W*(TT0/XKM
     $  +.5*TT1*(ZZ/XKM/BW+(ZZ-XK)/BWK)+TT2*(ZZ*(ZZ-XK)+GG)/BWK/BW)
      XIN=(T*T-T1*T1)*(C3*(1./BWK-1./XKM/BW)+2.*C4*XK/BW/BWK)
     $   -(U*U-U1*U1)*(D3*(1./BWK-1./XKM/BW)+2.*D4*XK/BW/BWK)
      XIN=XIN*2.*GM*XK/(Y1*Y2*Y3*Y4)*(QP(1)*QM(2)-QP(2)*QM(1))
      WTHBK=1.+QEF*(AIN-XIN)/(QE2*ASQI+QF2*ASQF)
      RETURN
C
   20 CONTINUE
      ZERO=0.
      IF(SOFT.EQ.ZERO) GO TO 900
      CS=1.+C*C
      UP=.5*(1.+C)
      UM=.5*(1.-C)
      AP=LOG(UP)
      AM=LOG(UM)
C
      SIGQ=C0*CS
      SIGI=ZZ*(C1*CS+D1*C)/BW
      SIGR=(C2*CS+D2*C)/BW
      SIGN=SIGQ+SIGI+SIGR
C
      DILDO=  AM**2-AP**2-2.*DLOGBK(UM)+2.*DLOGBK(UP)
      BINT=   4.*(AM-AP)*ALK0
C
      SIGQ1=SIGQ* ALF1*(BINT+DILDO
     $   -1./CS*(C*(AM**2+AP**2)+2.*UM*AP-2.*UP*AM))
C
      R1=BINT+.5*DILDO+(AM-AP)*ABW1
      R2=2.*(AM-AP)*(.5*(BW-ZZ)*ABW+GM*(DLR-FI))
      B1=ZZ*(-C*(AP*AP+AM*AM)+2.*UP*AM-2.*UM*AP)
     $   +2.*PI*GM*(CS*(AP-AM)+C*(AP+AM-1.))
      B2=ZZ*( C*(AP*AP-AM*AM)+2.*UP*AM+2.*UM*AP)
     $   +2.*PI*GM*(C*(AP-AM)-1.)
      SIGI1=ALF1/BW*((C1*CS+D1*C)*(ZZ*R1+R2)+.5*C1*B1+.25*D1*B2)
C
      SIGR1=SIGR*ALF1*(BINT+2.*(AM-AP)*ABW1
     $      +4.*(AM-AP)*(.5*(ZZ-1.)*ABW-GM*FI))
C
      SIGB=CS*SOFT+C*ASYM
C
      SIGD=QEF*(SIGQ1+SIGI1+SIGR1)
      SIG1=SIGB+SIGD
      IF(SIGB.LE.0..OR.SIG1.LE.0.) GO TO 900
      WTHBK=1.+SIGD/SIGB
      RETURN
  900 SIG1=0.
      WTHBK=0.
      RETURN
      END
CDECK  ID>, BKKINO.
      SUBROUTINE BKKINO(IT,IBREM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / BKCONS / PI,ALFA,ALF1,CMTR
      COMMON  / BKUTI / QP(4),QM(4),PH(4)
      COMMON  / BKUTI2/  XK,C,S,CG,SG
      DIMENSION P(12)
      EQUIVALENCE (P(1),QP(1))
C
C     ROTATIONS BOOST AND REST OF KINEMATICS
C
      IF(IT-2) 10,50,100
C
   10 CONTINUE
      FIG=-PI+2.*PI*RNF1BK(2)
      PH(4)=XK
      PH(3)=XK*CG
      PH(2)=0.
      PH(1)=XK*SG
      IF(IBREM.NE.1) CG=-CG
      XQ= SQRT(1.-XK)
      XQ1=XQ*S*COS(FIG)
      XQ3=(2.*(1.-XK)*C-XK*SG*XQ1)/(2.-XK+XK*CG)
      QP(4)=XQ3+(1.-.5*XK)*(1.-C)
      QP(3)=XQ3-.5*XK*CG*(1.-C)
      IF(IBREM.NE.1) QP(3)=-QP(3)
      QP(2)=XQ*S*SIN(FIG)
      QP(1)=XQ1-.5*XK*SG*(1.-C)
      GO TO 80
C
   50 CONTINUE
      FIG=-PI+2.*PI*RNF1BK(2)
      IF(IBREM.NE.1) CG=-CG
      IF(IBREM.NE.1) S=-S
      IF(IBREM.NE.1) C=-C
      XKT=2.*SQRT(1.-XK)*SG
      XK1=XKT*COS(FIG)
      XK3=2.*CG-XK-XK*CG
      GAM=XK/(2.-XK-XK*CG)
      PH(4)=XK
       PH(3)=GAM*(C*XK3-S*XK1)
      PH(2)=GAM*XKT*SIN(FIG)
      PH(1)=GAM*(S*XK3+C*XK1)
      QP(4)=.5*(2.-XK-XK*CG)
      QP(3)=C*QP(4)
      QP(2)=0.
      QP(1)=S*QP(4)
C
   80 CONTINUE
      QM(4)=2.-XK-QP(4)
      QM(3)=-PH(3)-QP(3)
      QM(2)=-PH(2)-QP(2)
      QM(1)=-PH(1)-QP(1)
C
C     CP - REFLEXION
      IF(IBREM.GT.0) GO TO 87
      DO 85 I=1,4
      QPI=QP(I)
      QP(I)=QM(I)
   85 QM(I)=QPI
   87 CONTINUE
C
      FI=-PI+2.*PI*RNF1BK(1)
      CFI=COS(FI)
      SFI=SIN(FI)
      DO 90 I=1,3
      N=4*(I-1)
      P1    =CFI*P(N+1)-SFI*P(N+2)
      P(N+2)=SFI*P(N+1)+CFI*P(N+2)
   90 P(N+1)=P1
      RETURN
C
  100 CONTINUE
      FI=-PI+2.*PI*RNF1BK(1)
      QP(4)=1.
      QP(3)=C
      QP(2)=S*COS(FI)
      QP(1)=S*SIN(FI)
      PH(4)=.0
      QM(4)=1.0
      DO 101 I=1,3
      PH(I)=.0
  101 QM(I)=-QP(I)
      RETURN
      END
CDECK  ID>, BKRRR6.
      SUBROUTINE BKRRR6(XK,EPS,CG,SG,IBREM)
C...  GENERATION OF THE PHOTON ANGULAR DISTRIBUTION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
   10 R=RNF1BK(4)
      DEL1=(2.-EPS)*(EPS/(2.-EPS))**R
      DEL2=2.-DEL1
      DEL12=EPS/(1.-XK+1./(1.-XK))*(DEL2/DEL1+DEL1/DEL2)
      IF(RNF1BK(5).GT.(1.-DEL12)) GO TO 10
      IF(RNF1BK(6).GT.0.5) GO TO 20
      A=DEL1
      DEL1=DEL2
      DEL2=A
   20 CHI1=(1.-.5*XK*DEL1)**2
      CHI2=(1.-.5*XK*DEL2)**2
      R=RNF1BK(7)
      IF(2.*R.GT.(CHI1+CHI2)) GO TO 10
      IBREM=-1
      IF(2.*R.GT.CHI1) IBREM=1
      CG=1.-DEL1
      SG=SQRT((DEL1-EPS)*(DEL2-EPS))
      RETURN
      END
CDECK  ID>, BKRRR7.
      SUBROUTINE BKRRR7(P,C,S)
CC    THIS SUBPROGRAM GENERATES (1-C)**2 OR (1+C)**2 DISTRIBUTION
CC    WITH PROBABILITY  P AND  1-P
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      X=RNF1BK(3)
      Z=0.
      IF(X.GT.P) Z=1.
      R=(X-Z*P)/(Z-P)
      C=(1.-2.*Z)*(1.-ABS(8.*R)**(1./3.))
      S=SQRT(1.-C*C)
      RETURN
      END
CDECK  ID>, RNF1BK.
      FUNCTION RNF1BK(IGEN)
CCC   THIS IS QUASIRANDOM SHUFFLING TYPE RANDOM NUMBER GENERATOR
CCC   EQUIVALENT TO THAT IN FOWL CERN PROGRAM LIBRARY W-505
CCC   IT CONTAINS NGEN INDEPENDENT PARALLEL SUBGENERATORS INDEXED
CCC   WITH IGEN PARAMETER ( GENERALLY NGEN.LE.100)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /BKRNF/ INIRAN,NGEN
      DIMENSION BUFOR(400)
CCC   RANDOM NUMBERS PASS THROUGH A BUFFER ( MATRIX BUFOR ) OF THE
CCC   LENGHT NGEN*LENBUF IN ORDER TO KILL CORRELATIONS BETWEEN
CCC   SUBGENERATORS. EVERY SUBGENNERATOR SHOULD SERVICE ONE INTEGRATION
CCC   VARIABLE. INIRAN IS AN INITIALIZATION POSITIVE INTEGER PARAMETER
CCC   COMMON TO ALL SUBGENERATORS.
CCC   LENBUF SHOULD NOT BE LESS THEN NGEN.
CCC                 ***  WARNING   ***
CCC   THIS PARTICULAR VERSION IS LIMITED TO 10 SUBGENERATORS, FOR MORE
CCC   ONE SHOULD EXTEND BUFOR AND LENBUF
CCC                 ******************
      DIMENSION QQCONS(100),SSER(100)
      DATA LENBUF/40/
      DATA QQCONS /
     *   2.,   3.,   5.,   7.,  11.,  13.,  17.,  19.,  23.,  29.,  31.,
     *  37.,  41.,  43.,  47.,  53.,  59.,  61.,  67.,  71.,  73.,  79.,
     *  83.,  89.,  97., 101., 103., 107., 109., 113., 127., 131., 137.,
     * 139., 149., 151., 157., 163., 167., 173., 179., 181., 191., 193.,
     * 197., 199., 211., 223., 227., 229., 233., 239., 241., 251., 257.,
     * 263., 269., 271., 277., 281., 283., 293., 307., 311., 313., 317.,
     * 331., 337., 347., 349., 353., 359., 367., 373., 379., 383., 389.,
     * 397., 401., 409., 419., 421., 431., 433., 439., 443., 449., 457.,
     * 461., 463., 467., 479., 487., 491., 499., 503., 509., 521., 523.,
     * 541.   /
C
C
      IF(IGEN.GT.0) GO TO 300
      IF(IGEN.NE.-2) STOP
      IF(NGEN.LE.0.OR.NGEN.GT.20) STOP
      IF(INIRAN.LE.0) STOP
      XLEN=FLOAT(LENBUF)
      DO 30 IGN=1,NGEN
      QQCONS(IGN)=SQRT(QQCONS(IGN))
      NDEX=LENBUF*(IGN-1)
      SER=INIRAN
      DO 29 K=1,LENBUF
      INDEX=NDEX+K
      DARG=1.
      BUFOR(INDEX)=MOD((SER*QQCONS(IGN)),DARG)
   29 SER=SER+1.
   30 SSER(IGN)=SER
      RETURN
C
C
  300 CONTINUE
      IF(IGEN.GT.NGEN) STOP
      INDEX=LENBUF*(IGEN-1)+INT(XLEN*RNCJ(DUMMY))+1
      RNF1BK=BUFOR(INDEX)
      SER=SSER(IGEN)
      DARG=1.
      BUFOR(INDEX)=MOD((SER*QQCONS(IGEN)),DARG)
      SSER(IGEN)=SER+1.
      RETURN
C
      END
CDECK  ID>, DLOGBK.
      FUNCTION DLOGBK(X)
CERN      C304      VERSION    29/07/71 DILOG        59                C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      Z=-1.64493406684822
      IF(X .LT.-1.0) GO TO 1
      IF(X .LE. 0.5) GO TO 2
      IF(X .EQ. 1.0) GO TO 3
      IF(X .LE. 2.0) GO TO 4
      Z=3.2898681336964
    1 T=1.0/X
      S=-0.5
      Z=Z-0.5*LOG(ABS(X))**2
      GO TO 5
    2 T=X
      S=0.5
      Z=0.
      GO TO 5
    3 DLOGBK=1.64493406684822
      RETURN
    4 T=1.0-X
      S=-0.5
      Z=1.64493406684822 -LOG(X)*LOG(ABS(T))
    5 Y=2.66666666666666 *T+0.66666666666666
      B=      0.00000 00000 00001
      A=Y*B  +0.00000 00000 00004
      B=Y*A-B+0.00000 00000 00011
      A=Y*B-A+0.00000 00000 00037
      B=Y*A-B+0.00000 00000 00121
      A=Y*B-A+0.00000 00000 00398
      B=Y*A-B+0.00000 00000 01312
      A=Y*B-A+0.00000 00000 04342
      B=Y*A-B+0.00000 00000 14437
      A=Y*B-A+0.00000 00000 48274
      B=Y*A-B+0.00000 00001 62421
      A=Y*B-A+0.00000 00005 50291
      B=Y*A-B+0.00000 00018 79117
      A=Y*B-A+0.00000 00064 74338
      B=Y*A-B+0.00000 00225 36705
      A=Y*B-A+0.00000 00793 87055
      B=Y*A-B+0.00000 02835 75385
      A=Y*B-A+0.00000 10299 04264
      B=Y*A-B+0.00000 38163 29463
      A=Y*B-A+0.00001 44963 00557
      B=Y*A-B+0.00005 68178 22718
      A=Y*B-A+0.00023 20021 96094
      B=Y*A-B+0.00100 16274 96164
      A=Y*B-A+0.00468 63619 59447
      B=Y*A-B+0.02487 93229 24228
      A=Y*B-A+0.16607 30329 27855
      A=Y*A-B+1.93506 43008 6996
      DLOGBK=S*T*(A-B)+Z
      RETURN
      END
CDECK  ID>, CJSPHI.
      SUBROUTINE CJSPHI(NONEUT,PMCHRG,EMNEUT,Q,EVECT,IERR)
C     ****************************************************
C-- Calculates eigenvalues and eigenvectors of sphericity tensor.
C-- Uses CERNLIB routine EISRS1. IERR as from EISRS1.
C-- Eigenvalues are normalized to Q(1)+Q(2)+Q(3)=1, Q(1)<=Q(2)<=Q(3)
C-- EVECT(1:3,I) : components of Ith eigenvector.
C-- Input parameters:
C-- NONEUT : if 1, neutral particles are neglected.
C-- PMCHRG : charged particles with momentum < PMCHRG are neglected.
C-- EMNEUT : neutral particles with energy < EMNEUT are neglected.
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION EVAL(3),EVECT(3,3),Q(3)
      DIMENSION T(3,3),WORK(3,3)
C
      DO 1 L1=1,3
      DO 1 L2=1,3
1     T(L1,L2)=0.
      DO 10 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 10
      PP=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
      IF(LCHGCJ(IDHEP(I)).NE.0) THEN
        IF(PP.LT.PMCHRG) GO TO 10
      ELSE
        IF(NONEUT.EQ.1) GO TO 10
        IF(PP.LT.EMNEUT) GO TO 10
      ENDIF
      DO 11 L1=1,3
      DO 11 L2=1,3
11    T(L1,L2)=T(L1,L2)+PHEP(L1,I)*PHEP(L2,I)
10    CONTINUE
C
      CALL EISRS1(3,3,T,EVAL,EVECT,IERR,WORK)
C
      TEVAL=EVAL(1)+EVAL(2)+EVAL(3)
      IF(TEVAL.EQ.0.) RETURN
      DO 12 L=1,3
12    Q(L)=EVAL(L)/TEVAL
C
      RETURN
      END
CDECK  ID>, CJSPHO.
      SUBROUTINE CJSPHO(NONEUT,PMCHRG,EMNEUT,Q,EVECT,IERR)
C     ****************************************************
C-- Calculates eigenvalues and eigenvectors of spherocity tensor.
C-- Uses CERNLIB routine EISRS1. IERR as from EISRS1.
C-- Eigenvalues are normalized to Q(1)+Q(2)+Q(3)=1, Q(1)<=Q(2)<=Q(3)
C-- EVECT(1:3,I) : components of Ith eigenvector.
C-- Input parameters:
C-- NONEUT : if 1, neutral particles are neglected.
C-- PMCHRG : charged particles with momentum < PMCHRG are neglected.
C-- EMNEUT : neutral particles with energy < EMNEUT are neglected.
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION EVAL(3),EVECT(3,3),Q(3)
      DIMENSION T(3,3),WORK(3,3)
C
      DO 1 L1=1,3
      DO 1 L2=1,3
1     T(L1,L2)=0.
      DO 10 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 10
      PP=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
      IF(LCHGCJ(IDHEP(I)).NE.0) THEN
        IF(PP.LT.PMCHRG) GO TO 10
      ELSE
        IF(NONEUT.EQ.1) GO TO 10
        IF(PP.LT.EMNEUT) GO TO 10
      ENDIF
      DO 11 L1=1,3
      DO 11 L2=1,3
11    T(L1,L2)=T(L1,L2)+PHEP(L1,I)*PHEP(L2,I)/PP
10    CONTINUE
C
      CALL EISRS1(3,3,T,EVAL,EVECT,IERR,WORK)
C
      TEVAL=EVAL(1)+EVAL(2)+EVAL(3)
      IF(TEVAL.EQ.0.) RETURN
      DO 12 L=1,3
12    Q(L)=EVAL(L)/TEVAL
C
      RETURN
      END
CDECK  ID>, CJTMAJ.
      SUBROUTINE CJTMAJ(NONEUT,PMCHRG,EMNEUT,NINITS,PTHRST,SUMP
     &,TMAJOR,TMINOR,PMAJOR,PMINOR)
C     *********************************************************
C-- Finds TMAJOR, TMINOR and associated axes PMAJOR(1:3) and PMINOR(1:3)
C-- (normalized to 1).
C-- Input parameters:
C-- NONEUT : if 1, neutral particles are neglected.
C-- PMCHRG : charged particles with momentum < PMCHRG are neglected.
C-- EMNEUT : neutral particles with energy < EMNEUT are neglected.
C-- NINITS : number of random starts for major axis search (by
C--          relaxation).
C-- PTHRST(1:3) : thrust axis vector (normalized to 1).
C-- SUMP = sum of momenta of accepted particles.
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION PTHRST(3),PMAJOR(3),PMINOR(3),PMAJL(3),PPERP(3,NMXHEP)
      DIMENSION PMAJX(3)
C
      DATA ERRMAX/1.E-6/,NITERX/100/
C
C-- INITIALIZE
      PIG2=4.*ATAN(1.)
      PPTHR=SQRT(PTHRST(1)**2+PTHRST(2)**2+PTHRST(3)**2)
      PTTHR=SQRT(PTHRST(1)**2+PTHRST(2)**2)
      CTH=PTHRST(3)/PPTHR
      STH=PTTHR/PPTHR
      CPH=PTHRST(1)/PTTHR
      SPH=PTHRST(2)/PTTHR
      TMAJX=0.
C
      DO 20 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 20
      PP=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
      IF(LCHGCJ(IDHEP(I)).NE.0) THEN
        IF(PP.LT.PMCHRG) GO TO 20
      ELSE
        IF(NONEUT.EQ.1) GO TO 20
        IF(PP.LT.EMNEUT) GO TO 20
      ENDIF
      PROTHR=
     &(PTHRST(1)*PHEP(1,I)+PTHRST(2)*PHEP(2,I)+PTHRST(3)*PHEP(3,I))
      DO 19 J=1,3
19    PPERP(J,I)=PHEP(J,I)-PTHRST(J)*PROTHR
20    CONTINUE
C
      INITS=0
C
C-- NEXT STARTING VALUE FOR PMAJOR(3)
50    INITS=INITS+1
      IF(INITS.GT.NINITS) GOTO 60
      PHIR=PIG2*RNCJ(0.)
      PMAJL(1)=COS(PHIR)
      PMAJL(2)=SIN(PHIR)
      PMAJL(3)=0.
      P3L=PMAJL(3)
      PMAJL(3)=CTH*PMAJL(3)-STH*PMAJL(1)
      PMAJL(1)=STH*P3L     +CTH*PMAJL(1)
      P1L=PMAJL(1)
      PMAJL(1)=CPH*PMAJL(1)-SPH*PMAJL(2)
      PMAJL(2)=SPH*P1L     +CPH*PMAJL(2)
      NITER=0
C
C-- LOOP
10    CONTINUE
      NITER=NITER+1
      DO 11 J=1,3
11    PMAJOR(J)=0.
      DO 12 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 12
      PP=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
      IF(LCHGCJ(IDHEP(I)).NE.0) THEN
        IF(PP.LT.PMCHRG) GO TO 12
      ELSE
        IF(NONEUT.EQ.1) GO TO 12
        IF(PP.LT.EMNEUT) GO TO 12
      ENDIF
      CS=PMAJL(1)*PPERP(1,I)+PMAJL(2)*PPERP(2,I)+PMAJL(3)*PPERP(3,I)
      IF(CS.GT.0.) THEN
        DO 13 J=1,3
13      PMAJOR(J)=PMAJOR(J)+PPERP(J,I)
      ELSE
        DO 23 J=1,3
23      PMAJOR(J)=PMAJOR(J)-PPERP(J,I)
      ENDIF
12    CONTINUE
C
      PPSQ=0.
      DO 17 J=1,3
17    PPSQ=PPSQ+PMAJOR(J)**2
      IF(PPSQ.EQ.0.) THEN
        TMAJOR=0.
        GO TO 15
      ELSE
        PP=SQRT(PPSQ)
        TMAJOR=PP/SUMP
        DO 18 J=1,3
18      PMAJOR(J)=PMAJOR(J)/PP
      ENDIF
C
      DIFF=0.
      DO 16 J=1,3
16    DIFF=DIFF+(PMAJL(J)-PMAJOR(J))**2
      IF(DIFF.LT.ERRMAX*SUMP**2) GO TO 15
      IF(NITER.GT.NITERX) GO TO 15
      DO 14 J=1,3
14    PMAJL(J)=PMAJOR(J)
      GO TO 10
C
C-- RECORD MAX TMAJOR
15    CONTINUE
      IF(TMAJOR.GT.TMAJX) THEN
        TMAJX=TMAJOR
        DO 51 J=1,3
51      PMAJX(J)=PMAJOR(J)
      ENDIF
      GOTO 50
C
C-- OUTPUT
60    CONTINUE
      TMAJOR=TMAJX
      IF(TMAJOR.EQ.0.) THEN
        TMINOR=0.
        RETURN
      ENDIF
      DO 61 J=1,3
61    PMAJOR(J)=PMAJX(J)
      PMINOR(1)=PTHRST(2)*PMAJOR(3)-PTHRST(3)*PMAJOR(2)
      PMINOR(2)=PTHRST(3)*PMAJOR(1)-PTHRST(1)*PMAJOR(3)
      PMINOR(3)=PTHRST(1)*PMAJOR(2)-PTHRST(2)*PMAJOR(1)
      TMINOR=0.
      DO 64 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 64
      PP=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
      IF(LCHGCJ(IDHEP(I)).NE.0) THEN
        IF(PP.LT.PMCHRG) GO TO 64
      ELSE
        IF(NONEUT.EQ.1) GO TO 64
        IF(PP.LT.EMNEUT) GO TO 64
      ENDIF
      CS=PMINOR(1)*PHEP(1,I)+PMINOR(2)*PHEP(2,I)+PMINOR(3)*PHEP(3,I)
      TMINOR=TMINOR+ABS(CS)
64    CONTINUE
      TMINOR=TMINOR/SUMP
      RETURN
      END
CDECK  ID>, CJTHRU.
      SUBROUTINE CJTHRU(NONEUT,PMCHRG,EMNEUT,NINITS,THRUST,PTHRST
     &,SUMP)
C     ***********************************************************
C-- Finds THRUST and thrust axis PTHRST(1:3) (normalized to 1).
C-- SUMP = sum of momenta of accepted particles (output).
C-- Input parameters:
C-- NONEUT : if 1, neutral particles are neglected.
C-- PMCHRG : charged particles with momentum < PMCHRG are neglected.
C-- EMNEUT : neutral particles with energy < EMNEUT are neglected.
C-- NINITS : number of random starts for thrust axis search (by
C--          relaxation).
      INTEGER NMXHEP
      PARAMETER (NMXHEP=2000)
      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
      INTEGER  NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      SAVE /HEPEVT/
      DIMENSION PTHRST(3),PTHL(3),PTHRSX(3)
C
      DATA ERRMAX/1.E-6/,NITERX/100/
C
C-- INITIALIZE
      PIG2=8.*ATAN(1.)
      THRUSX=0.
      INITS=0
      SUMP=0.
      DO 22 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 22
      PP=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
      IF(LCHGCJ(IDHEP(I)).NE.0) THEN
        IF(PP.LT.PMCHRG) GO TO 22
      ELSE
        IF(NONEUT.EQ.1) GO TO 22
        IF(PP.LT.EMNEUT) GO TO 22
      ENDIF
      SUMP=SUMP+PP
22    CONTINUE
      IF(SUMP.EQ.0.) THEN
        THRUST=0.
        RETURN
      ENDIF
C
C-- NEXT STARTING VALUE FOR THRUST AXIS
50    INITS=INITS+1
      IF(INITS.GT.NINITS) GO TO 60
      CTH=-1.+2.*RNCJ(0.)
      STH=SQRT(ABS(1.-CTH**2))
      PHIR=PIG2*RNCJ(0.)
      PTHL(1)=CTH
      PTHL(2)=STH*COS(PHIR)
      PTHL(3)=STH*SIN(PHIR)
      NITER=0
C
C-- LOOP
10    CONTINUE
      NITER=NITER+1
      DO 11 J=1,3
11    PTHRST(J)=0.
      DO 12 I=1,NHEP
      IF(ISTHEP(I).NE.1) GO TO 12
      PP=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
      IF(LCHGCJ(IDHEP(I)).NE.0) THEN
        IF(PP.LT.PMCHRG) GO TO 12
      ELSE
        IF(NONEUT.EQ.1) GO TO 12
        IF(PP.LT.EMNEUT) GO TO 12
      ENDIF
      CS=PTHL(1)*PHEP(1,I)+PTHL(2)*PHEP(2,I)
     *  +PTHL(3)*PHEP(3,I)
      IF(CS.GT.0.) THEN
        DO 13 J=1,3
13      PTHRST(J)=PTHRST(J)+PHEP(J,I)
      ELSE
        DO 19 J=1,3
19      PTHRST(J)=PTHRST(J)-PHEP(J,I)
      ENDIF
12    CONTINUE
C
      PPSQ=0.
      DO 17 J=1,3
17    PPSQ=PPSQ+PTHRST(J)**2
      IF(PPSQ.EQ.0.) THEN
        THRUST=0.
        GO TO 15
      ELSE
        PP=SQRT(PPSQ)
        THRUST=PP/SUMP
        DO 18 J=1,3
18      PTHRST(J)=PTHRST(J)/PP
      ENDIF
C
      DIFF=0.
      DO 16 J=1,3
16    DIFF=DIFF+(PTHL(J)-PTHRST(J))**2
      IF(DIFF.LT.ERRMAX*SUMP**2) GO TO 15
      IF(NITER.GT.NITERX) GO TO 15
      DO 14 J=1,3
14    PTHL(J)=PTHRST(J)
      GO TO 10
C
C-- RECORD MAX THRUST
15    CONTINUE
      IF(THRUST.GT.THRUSX) THEN
        THRUSX=THRUST
        DO 51 J=1,3
51      PTHRSX(J)=PTHRST(J)
      ENDIF
      GOTO 50
C
C-- OUTPUT
60    CONTINUE
      THRUST=THRUSX
      IF(THRUST.EQ.0.) RETURN
      DO 61 J=1,3
61    PTHRST(J)=PTHRSX(J)
      RETURN
      END
CDECK  ID>, LCHGCJ.
      FUNCTION LCHGCJ(IDPDG)
C     **********************
C-- Returns integer charge of particle with PDG code IDPDG
C-- (Quarks and diquarks returned with LCHGCJ=0)
C
      DIMENSION LCHGQ(6)
      DATA LCHGQ/-1,2,-1,2,-1,2/
C
      LCHGCJ=0
C
      IF(MOD(IDPDG,100/10).EQ.0) RETURN
C
      IDPDGA=ABS(IDPDG)
      IF(IDPDGA.LT.110) THEN
        IF(IDPDGA.EQ.11.OR.IDPDGA.EQ.13.OR.IDPDGA.EQ.15) THEN
          LCHGCJ=-1
        ELSEIF(IDPDGA.EQ.24) THEN
          LCHGCJ=1
        ENDIF
      ELSEIF(MOD(IDPDGA/1000,10).EQ.0) THEN
C-- MESONS
        IQ2=MOD(IDPDGA/100,10)
        IQ3=MOD(IDPDGA/10,10)
        IF(LCHGQ(IQ2).EQ.LCHGQ(IQ3)) THEN
            LCHGCJ=0
        ELSE
            LCHGCJ=1
        ENDIF
      ELSE
C-- BARYON
        IQ1=MOD(IDPDGA/1000,10)
        IQ2=MOD(IDPDGA/100,10)
        IQ3=MOD(IDPDGA/10,10)
        LCHGCJ=(LCHGQ(IQ1)+LCHGQ(IQ2)+LCHGQ(IQ3))/3
      ENDIF
C
      IF(IDPDG.LT.0) LCHGCJ=-LCHGCJ
C
      RETURN
      END
