C######################################################################C
C                                                                      C
C                            P Y T H I A                               C
C                                                                      C
C                      (VERSION 4.8, APRIL 1987)                       C
C                                                                      C
C             THE LUND MONTE CARLO FOR HADRONIC PROCESSES              C
C                                                                      C
C     AUTHORS: HANS-UNO BENGTSSON, DEPARTMENT OF PHYSICS,              C
C                   UCLA, 405 HILGARD AVENUE,                          C
C                   LOS ANGELES, CA 90024, USA                         C
C              TORBJORN SJOSTRAND, DEPARTMENT OF THEORETICAL PHYSICS,  C
C                   UNIVERSITY OF LUND, SOLVEGATAN 14 A,               C
C                   S-223 62 LUND, SWEDEN                              C
C                                                                      C
C######################################################################C
 
 
      SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN,QTMIN)
 
C...INITIALIZES THE GENERATION PROCEDURE; FINDS MAXIMA OF THE
C...DIFFERENTIAL CROSS-SECTIONS TO BE USED FOR WEIGHTING.
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600)
      COMMON/LUDAT4/CHAG(50),CHAF(100)
      COMMON/LUDATE/MSTE(40),PARE(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      COMMON/PYINT1/XQ(2,-6:6),DSIG(-6:6,-6:6,5),FSIG(10,10,3)
      COMMON/PYINT2/KPR(-6:6,-6:6),NMX(6),ICOL(40,4,2),ICH(30),VKM2(4,4)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
      COMMON/PYINT4/PWTOT(10),PW(10,10,10,3),EWTOT(10),EW(10,10,10,3)
      COMMON/PYCHAR/PROC(-5:40)
      CHARACTER INIT*42,PROC*26,DECAY(30)*6
      CHARACTER*(*) FRAME,BEAM,TARGET
      CHARACTER*4 STATE(-1:1),PARTIC,PARCDE(6),CHAG,CHAF
      DIMENSION KCDE(6)
      DATA DECAY/'U     ','D     ','S     ','C     ','B     ','T     ',
     &'L     ','H     ',2*' ','E-    ','NU-E  ','MU-   ','NU-MU ',
     &'TAU-  ','NU-TAU','CHI-  ','NU-CHI',2*' ','Z0    ','W+/-  ',
     &'H+/-  ','Z''0   ',6*' '/
      DATA STATE/' ---',' OFF',' ON '/
      DATA PARCDE/'PI+ ','PI- ','P   ','PBAR','N   ','NBAR'/
      DATA KCDE/17,-17,41,-41,42,-42/
 
      IF(IPY(31).GE.1) WRITE(MST(20),1000)
      CALL LULIST(-1)
 
C...SET INITIAL STATE
      N=2
      DO 110 I=1,2
      K(I,2)=0
      IF(I.EQ.1) PARTIC=BEAM//' '
      IF(I.EQ.2) PARTIC=TARGET//' '
      DO 100 J=1,6
  100 IF(PARTIC.EQ.PARCDE(J)) K(I,2)=KCDE(J)
  110 P(I,5)=ULMASS(0,K(I,2))
      IF(K(1,2).EQ.0) WRITE(MST(20),1100) BEAM
      IF(K(2,2).EQ.0) WRITE(MST(20),1200) TARGET
      IF(K(1,2).EQ.0.OR.K(2,2).EQ.0) STOP
 
      WRITE(MST(20),1300)
C...TRANSFORM TO CM-FRAME FOR DIFFERENT ALTERNATIVES,
C...FIRST PARTICLE ALONG +Z AXIS
      DO 120 J=6,10
  120 PYVAR(J)=0.
      IF(FRAME.EQ.'CMS') THEN
        INIT=BEAM//'-'//TARGET//' COLLIDER'//' '
        WRITE(MST(20),1400) INIT
        WRITE(MST(20),1500) WIN
        S=WIN**2
        P(1,1)=0.
        P(1,2)=0.
        P(2,1)=0.
        P(2,2)=0.
        P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2.*P(1,5)*P(2,5))**2)/
     &  (4.*S))
        P(2,3)=-P(1,3)
        P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
        P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
      ELSEIF(FRAME.EQ.'FIXT') THEN
        INIT=BEAM//' ON '//TARGET//' FIXED TARGET'//' '
        WRITE(MST(20),1400) INIT
        WRITE(MST(20),1600) WIN
        P(1,1)=0.
        P(1,2)=0.
        P(2,1)=0.
        P(2,2)=0.
        P(1,3)=WIN
        P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
        P(2,3)=0.
        P(2,4)=P(2,5)
        S=P(1,5)**2+P(2,5)**2+2.*P(2,4)*P(1,4)
        PYVAR(10)=P(1,3)/(P(1,4)+P(2,4))
        CALL LUROBO(0.,0.,0.,0.,-PYVAR(10))
        WRITE(MST(20),1700) SQRT(S)
      ELSEIF(FRAME.EQ.'USER') THEN
        INIT=BEAM//' ON '//TARGET//', USER-SPECIFIED CONFIGURATION'//' '
        WRITE(MST(20),1400) INIT
        WRITE(MST(20),1800)
        PARTIC=BEAM//' '
        WRITE(MST(20),1900) PARTIC,P(1,1),P(1,2),P(1,3)
        PARTIC=TARGET//' '
        WRITE(MST(20),1900) PARTIC,P(2,1),P(2,2),P(2,3)
        P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
        P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
        DO 130 J=1,3
  130   PYVAR(7+J)=(DBLE(P(1,J))+DBLE(P(2,J)))/DBLE(P(1,4)+P(2,4))
        CALL LUROBO(0.,0.,-PYVAR(8),-PYVAR(9),-PYVAR(10))
        PYVAR(7)=ULANGL(P(1,1),P(1,2))
        CALL LUROBO(0.,-PYVAR(7),0.,0.,0.)
        PYVAR(6)=ULANGL(P(1,3),P(1,1))
        CALL LUROBO(-PYVAR(6),0.,0.,0.,0.)
        S=P(1,5)**2+P(2,5)**2+2.*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
        WRITE(MST(20),1700) SQRT(S)
      ELSE
        WRITE(MST(20),2000) FRAME
        STOP
      ENDIF
 
C...SAVE INFORMATION ON INCOMING PARTICLES
      IPY(41)=K(1,2)
      IPY(42)=K(2,2)
      PYVAR(3)=P(1,5)
      PYVAR(4)=P(2,5)
      PYVAR(5)=P(1,3)
 
C...STORE CONSTANTS TO BE USED IN GENERATION
      PYVAR(1)=SQRT(S)
      PYVAR(2)=S
      PYVAR(11)=QTMIN
      PYVAR(12)=QTMIN**2
      PYVAR(13)=4.*PYPAR(32)**2/S
      WRITE(MST(20),2100) PYVAR(11),PYPAR(20)
 
C...SELECT PARTONIC SUBPROCESSES TO BE INCLUDED IN THE SIMULATION
      IF(ISELEC.EQ.1) THEN
C...HIGH-PT QCD PROCESSES:
        DO 140 I=1,6
  140   ISUBPR(I)=1
        IF(QTMIN.LT.PYPAR(32)) ISUBPR(7)=1
      ELSEIF(ISELEC.EQ.2) THEN
C...ALL QCD PROCESSES:
        DO 150 I=1,10
  150   ISUBPR(I)=1
      ELSEIF(ISELEC.EQ.3) THEN
C...PROMPT PHOTON PRODUCTION:
        ISUBPR(13)=1
        ISUBPR(16)=1
        ISUBPR(19)=1
      ELSEIF(ISELEC.EQ.4) THEN
C...Z0/GAM* PRODUCTION:
        ISUBPR(11)=1
      ELSEIF(ISELEC.EQ.5) THEN
C...W+/- PRODUCTION:
        ISUBPR(12)=1
      ELSEIF(ISELEC.EQ.6) THEN
C...Z0 + JET:
        ISUBPR(14)=1
        ISUBPR(17)=1
      ELSEIF(ISELEC.EQ.7) THEN
C...W+/- + JET:
        ISUBPR(15)=1
        ISUBPR(18)=1
      ELSEIF(ISELEC.EQ.8) THEN
C...Z0 & W+/- PAIR PRODUCTION:
        DO 160 I=20,24
  160   ISUBPR(I)=1
      ELSEIF(ISELEC.EQ.9) THEN
C...H0 PRODUCTION:
        DO 170 I=25,28
  170   ISUBPR(I)=1
      ELSEIF(ISELEC.EQ.10) THEN
C...H0 & Z0 OR W+/- PAIR PRODUCTION:
        ISUBPR(29)=1
        ISUBPR(30)=1
      ENDIF
 
C...MAXIMUM 4 GENERATIONS ALLOWED: SET MAXIMUM NUMBER OF ALLOWED
C...FLAVOURS COMPATIBLE WITH MAXIMUM NUMBER OF GENERATIONS; INHIBIT
C...NON-EXISTING DECAY MODES; OPTIONALLY PRINT SUMMARY TABLE
      IPY(9)=MIN(4,IPY(9))
      IPY(5)=MIN(IPY(5),2*IPY(9))
      IPY(8)=MIN(IPY(8),2*IPY(9))
      DO 200 I=0,10
      DO 180 J=2*IPY(9)+1,8
      IPROD(I,J)=0
  180 IPROD(I,10+J)=0
      DO 190 J=9,10
      IPROD(I,J)=-1
  190 IPROD(I,10+J)=-1
      DO 200 J=24,30
  200 IPROD(I,J)=-1
      DO 210 I=0,1
      DO 210 J=11,23
  210 IPROD(I,J)=-1
      IPROD(2,21)=-1
      IPROD(2,22)=-1
      IPROD(3,21)=-1
      IPROD(3,22)=-1
      IPROD(3,23)=-1
      IPROD(4,12)=-1
      IPROD(4,14)=-1
      IPROD(4,16)=-1
      IPROD(4,18)=-1
      IPROD(4,23)=-1
      IPROD(5,21)=-1
      IPROD(5,22)=-1
      IPROD(5,23)=-1
      IPROD(6,21)=-1
      IPROD(6,22)=-1
      IPROD(6,23)=-1
      IPROD(7,21)=-1
      IPROD(7,22)=-1
      IPROD(7,23)=-1
      IF(IPY(31).GE.1) THEN
        WRITE(MST(20),2200)
        DO 220 I=1,2*IPY(9)
  220   WRITE(MST(20),2300) DECAY(I),(STATE(IPROD(J,I)),J=0,7)
        DO 230 I=1,2*IPY(9)
  230   WRITE(MST(20),2300) DECAY(10+I),(STATE(IPROD(J,10+I)),J=0,7)
        DO 240 I=1,3
  240   WRITE(MST(20),2300) DECAY(20+I),(STATE(IPROD(J,20+I)),J=0,7)
      ENDIF
 
C...CALCULATE FULL AND EFFECTIVE WIDTHS OF GAUGE BOSONS
      AEM=PYPAR(1)
      XW=PYPAR(2)
      DO 250 I=1,10
      PWTOT(I)=0.
      EWTOT(I)=0.
      DO 250 J=1,10
      DO 250 L=1,10
      DO 250 M=1,3
      PW(I,J,L,M)=0.
  250 EW(I,J,L,M)=0.
C...W+/-:
      WMAS=PMAS(3)
      WFAC=AEM/(24.*XW)*WMAS
      RADC=1.+PYALPH(WMAS**2)/PAR(71)
      DO 260 I=1,IPY(9)
      IL=2*I-1
      IU=2*I
      IF(PMAS(6+IL)+PMAS(6+IU).LT.WMAS) THEN
        RMLL=(PMAS(6+IL)/WMAS)**2
        RMLU=(PMAS(6+IU)/WMAS)**2
        PW(3,IL,IU,2)=WFAC*(1.-RMLL-RMLU)*(2.+RMLL+RMLU)*
     &  SQRT(MAX(0.,(1.-RMLL-RMLU)**2-4.*RMLL*RMLU))
        PWTOT(3)=PWTOT(3)+PW(3,IL,IU,2)
        IF(IPROD(3,10+IL).EQ.1.AND.IPROD(3,10+IU).EQ.1) THEN
          EW(3,IL,IU,2)=PW(3,IL,IU,2)
          EWTOT(3)=EWTOT(3)+EW(3,IL,IU,2)
        ENDIF
      ENDIF
      IF(IL.EQ.1) IL=2
      DO 260 J=1,IPY(9)
      JU=2*J
      IF(JU.EQ.2) JU=1
      IF(PMAS(100+IL)+PMAS(100+JU).LT.WMAS) THEN
        RMQI=(PMAS(100+IL)/WMAS)**2
        RMQJ=(PMAS(100+JU)/WMAS)**2
        PW(3,IL,JU,1)=WFAC*3.*(1.-RMQI-RMQJ)*(2.+RMQI+RMQJ)*
     &  SQRT(MAX(0.,(1.-RMQI-RMQJ)**2-4.*RMQI*RMQJ))*VKM2(I,J)*RADC
        PWTOT(3)=PWTOT(3)+PW(3,IL,JU,1)
        IF(IPROD(3,IL).EQ.1.AND.IPROD(3,JU).EQ.1) THEN
          EW(3,IL,JU,1)=PW(3,IL,JU,1)
          EWTOT(3)=EWTOT(3)+EW(3,IL,JU,1)
        ENDIF
      ENDIF
  260 CONTINUE
      PYVAR(63)=EWTOT(3)/PWTOT(3)
C...H+/-:
      HCMAS=PMAS(92)
      HCFAC=AEM/(8.*XW)*(HCMAS/WMAS)**2*HCMAS
      RADC=1.+PYALPH(HCMAS**2)/PAR(71)
      DO 270 I=1,IPY(9)
      IL=2*I-1
      IU=2*I
      IF(PMAS(6+IL)+PMAS(6+IU).LT.HCMAS) THEN
        RMLL=(PMAS(6+IL)/HCMAS)**2
        RMLU=(PMAS(6+IU)/HCMAS)**2
        PW(6,IL,IU,2)=HCFAC*((RMLL*PYPAR(36)+RMLU/PYPAR(36))*
     &  (1.-RMLL-RMLU)-4.*RMLL*RMLU)*
     &  SQRT(MAX(0.,(1.-RMLL-RMLU)**2-4.*RMLL*RMLU))
        PWTOT(6)=PWTOT(6)+PW(6,IL,IU,2)
        IF(IPROD(6,10+IL).EQ.1.AND.IPROD(6,10+IU).EQ.1) THEN
          EW(6,IL,IU,2)=PW(6,IL,IU,2)
          EWTOT(6)=EWTOT(6)+EW(6,IL,IU,2)
        ENDIF
      ENDIF
      IF(IL.EQ.1) IL=2
      IF(IU.EQ.2) IU=1
      IF(PMAS(100+IL)+PMAS(100+IU).LT.HCMAS) THEN
        RMQL=(PMAS(100+IL)/HCMAS)**2
        RMQU=(PMAS(100+IU)/HCMAS)**2
        PW(6,IL,IU,1)=HCFAC*3.*((RMQL*PYPAR(36)+RMQU/PYPAR(36))*
     &  (1.-RMQL-RMQU)-4.*RMQL*RMQU)*
     &  SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))*RADC
        PWTOT(6)=PWTOT(6)+PW(6,IL,IU,1)
        IF(IPROD(6,IL).EQ.1.AND.IPROD(6,IU).EQ.1) THEN
          EW(6,IL,IU,1)=PW(6,IL,IU,1)
          EWTOT(6)=EWTOT(6)+EW(6,IL,IU,1)
        ENDIF
      ENDIF
  270 CONTINUE
      PYVAR(66)=EWTOT(6)/PWTOT(6)
C...Z0:
      ZMAS=PMAS(2)
      ZFAC=AEM/(48.*XW*(1.-XW))*ZMAS
      RADC=1.+PYALPH(ZMAS**2)/PAR(71)
      DO 280 I=1,2*IPY(9)
      IF(2.*PMAS(100+I).LT.ZMAS) THEN
        RMQ=(PMAS(100+I)/ZMAS)**2
        EI=ICH(I)/3.
        AI=SIGN(1.,EI+0.1)
        VI=AI-4.*EI*XW
        PW(2,I,I,1)=ZFAC*3.*(VI**2*(1.+2.*RMQ)+AI**2*(1.-4.*RMQ))*
     &  SQRT(MAX(0.,1.-4.*RMQ))*RADC
        PWTOT(2)=PWTOT(2)+PW(2,I,I,1)
        IF(IPROD(2,I).EQ.1) THEN
          EW(2,I,I,1)=PW(2,I,I,1)
          EWTOT(2)=EWTOT(2)+EW(2,I,I,1)
        ENDIF
      ENDIF
      IF(2.*PMAS(6+I).LT.ZMAS) THEN
        RML=(PMAS(6+I)/ZMAS)**2
        EI=ICH(10+I)/3.
        AI=SIGN(1.,EI+0.1)
        VI=AI-4.*EI*XW
        PW(2,I,I,2)=ZFAC*(VI**2*(1.+2.*RML)+AI**2*(1.-4.*RML))*
     &  SQRT(MAX(0.,1.-4.*RML))
        PWTOT(2)=PWTOT(2)+PW(2,I,I,2)
        IF(IPROD(2,10+I).EQ.1) THEN
          EW(2,I,I,2)=PW(2,I,I,2)
          EWTOT(2)=EWTOT(2)+EW(2,I,I,2)
        ENDIF
      ENDIF
  280 CONTINUE
      IF(2.*PMAS(92).LT.ZMAS) THEN
        RMB=(PMAS(92)/ZMAS)**2
        CI=2.*(1.-2.*XW)
        PW(2,3,3,3)=ZFAC*0.25*CI**2*(1.-4.*RMB)*SQRT(MAX(0.,1.-4.*RMB))
        PWTOT(2)=PWTOT(2)+PW(2,3,3,3)
        IF(IPROD(2,23).EQ.1) THEN
          EW(2,3,3,3)=PW(2,3,3,3)*PYVAR(66)**2
          EWTOT(2)=EWTOT(2)+EW(2,3,3,3)
        ENDIF
      ENDIF
      PYVAR(62)=EWTOT(2)/PWTOT(2)
C...H0:
      HMAS=PMAS(4)
      HFAC=AEM/(8.*XW)*(HMAS/WMAS)**2*HMAS
      RADC=1.+PYALPH(HMAS**2)/PAR(71)
      DO 290 I=1,2*IPY(9)
      IF(2.*PMAS(100+I).LT.HMAS) THEN
        RMQ=(PMAS(100+I)/HMAS)**2
        PW(4,I,I,1)=HFAC*3.*RMQ*(1.-4.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*
     &  RADC
        PWTOT(4)=PWTOT(4)+PW(4,I,I,1)
        IF(IPROD(4,I).EQ.1) THEN
          EW(4,I,I,1)=PW(4,I,I,1)
          EWTOT(4)=EWTOT(4)+EW(4,I,I,1)
        ENDIF
      ENDIF
  290 CONTINUE
      DO 300 I=1,IPY(9)
      IL=2*I-1
      IF(2.*PMAS(6+IL).LT.HMAS) THEN
        RML=(PMAS(6+IL)/HMAS)**2
        PW(4,IL,IL,2)=HFAC*RML*(1.-4.*RML)*SQRT(MAX(0.,1.-4.*RML))
        PWTOT(4)=PWTOT(4)+PW(4,IL,IL,2)
        IF(IPROD(4,10+IL).EQ.1) THEN
          EW(4,IL,IL,2)=PW(4,IL,IL,2)
          EWTOT(4)=EWTOT(4)+EW(4,IL,IL,2)
        ENDIF
      ENDIF
  300 CONTINUE
      DO 310 I=1,2
      IF(2.*PMAS(I+1).LT.HMAS) THEN
        RMB=(PMAS(I+1)/HMAS)**2
        PW(4,I,I,3)=HFAC*(1.-4.*RMB+12.*RMB**2)*SQRT(MAX(0.,1.-4.*RMB))/
     &  (2.*(3-I))
        PWTOT(4)=PWTOT(4)+PW(4,I,I,3)
        IF(IPROD(4,20+I).EQ.1) THEN
          EW(4,I,I,3)=PW(4,I,I,3)*PYVAR(61+I)**2
          EWTOT(4)=EWTOT(4)+EW(4,I,I,3)
        ENDIF
      ENDIF
  310 CONTINUE
      PYVAR(64)=EWTOT(4)/PWTOT(4)
C...R:
      RMAS=PMAS(91)
      PWTOT(5)=0.08*RMAS
      RADC=1.+PYALPH(RMAS**2)/PAR(71)
      DEN=(IPY(9)-1)*(1.+2.*3.*RADC)
      DO 320 I=1,IPY(9)-1
      IL=2*I-1
      IU=2*I+1
      PW(5,IL,IU,2)=1./DEN*PWTOT(5)
      IF(IPROD(5,10+IL).EQ.1.AND.IPROD(5,10+IU).EQ.1) THEN
        EW(5,IL,IU,2)=PW(5,IL,IU,2)
        EWTOT(5)=EWTOT(5)+EW(5,IL,IU,2)
      ENDIF
  320 CONTINUE
      DO 330 I=1,2*(IPY(9)-1)
      IL=I
      IU=I+2
      IF(IL.LE.2) IL=3-IL
      PW(5,IL,IU,1)=3.*RADC/DEN*PWTOT(5)
      IF(IPROD(5,IL).EQ.1.AND.IPROD(5,IU).EQ.1) THEN
        EW(5,IL,IU,1)=PW(5,IL,IU,1)
        EWTOT(5)=EWTOT(5)+EW(5,IL,IU,1)
      ENDIF
  330 CONTINUE
      PYVAR(65)=EWTOT(5)/PWTOT(5)
C...Z'0:
      ZPMAS=PMAS(93)
      ZPFAC=AEM/(48.*XW*(1.-XW))*ZMAS
      RADC=1.+PYALPH(ZPMAS**2)/PAR(71)
      DO 340 I=1,2*IPY(9)
      IF(2.*PMAS(100+I).LT.ZPMAS) THEN
        RMQ=(PMAS(100+I)/ZPMAS)**2
        EI=ICH(I)/3.
        API=SIGN(1.,EI+0.1)
        VPI=API-4.*EI*XW
        PW(7,I,I,1)=ZPFAC*3.*(VPI**2*(1.+2.*RMQ)+API**2*(1.-4.*RMQ))*
     &  SQRT(MAX(0.,1.-4.*RMQ))*RADC
        PWTOT(7)=PWTOT(7)+PW(7,I,I,1)
        IF(IPROD(7,I).EQ.1) THEN
          EW(7,I,I,1)=PW(7,I,I,1)
          EWTOT(7)=EWTOT(7)+EW(7,I,I,1)
        ENDIF
      ENDIF
      IF(2.*PMAS(6+I).LT.ZPMAS) THEN
        RML=(PMAS(6+I)/ZPMAS)**2
        EI=ICH(10+I)/3.
        API=SIGN(1.,EI+0.1)
        VPI=API-4.*EI*XW
        PW(7,I,I,2)=ZPFAC*(VPI**2*(1.+2.*RML)+API**2*(1.-4.*RML))*
     &  SQRT(MAX(0.,1.-4.*RML))
        PWTOT(7)=PWTOT(7)+PW(7,I,I,2)
        IF(IPROD(7,10+I).EQ.1) THEN
          EW(7,I,I,2)=PW(7,I,I,2)
          EWTOT(7)=EWTOT(7)+EW(7,I,I,2)
        ENDIF
      ENDIF
  340 CONTINUE
      PYVAR(67)=EWTOT(7)/PWTOT(7)
 
C...STORE MASSES AND WIDTHS; SWITCH OFF RESONANCE DECAYS IN LUEXEC
      DO 350 I=1,2
      WM(3*I+8,1)=ZMAS
      WM(3*I+8,3)=PWTOT(2)
      WM(3*I+9,1)=WMAS
  350 WM(3*I+9,3)=PWTOT(3)
      DO 360 I=1,2
      WM(3*I+14,2)=ZMAS
      WM(3*I+14,4)=PWTOT(2)
      WM(3*I+15,2)=WMAS
  360 WM(3*I+15,4)=PWTOT(3)
      WM(22,1)=ZMAS
      WM(22,2)=ZMAS
      WM(22,3)=PWTOT(2)
      WM(22,4)=PWTOT(2)
      WM(23,1)=ZMAS
      WM(23,2)=WMAS
      WM(23,3)=PWTOT(2)
      WM(23,4)=PWTOT(3)
      WM(24,1)=WMAS
      WM(24,2)=WMAS
      WM(24,3)=PWTOT(3)
      WM(24,4)=PWTOT(3)
      WM(29,2)=ZMAS
      WM(29,4)=PWTOT(2)
      WM(30,2)=WMAS
      WM(30,4)=PWTOT(3)
      DO 370 I=1,6
      WM(24+I,1)=HMAS
  370 WM(24+I,3)=PWTOT(4)
      WM(31,1)=RMAS
      WM(31,3)=PWTOT(5)
      WM(32,1)=HCMAS
      WM(32,3)=PWTOT(6)
      WM(33,1)=ZMAS
      WM(33,2)=ZPMAS
      WM(33,3)=PWTOT(2)
      WM(33,4)=PWTOT(7)
      IDB(2)=0
      IDB(3)=0
      IDB(4)=0
 
C...RESCALE COEFFICIENTS TO BE USED IN RESONANCE PRODUCTION GENERATION
      DO 380 I=1,40
      IF(ISET(I).EQ.2.OR.ISET(I).EQ.3) THEN
        COEF(I,1)=COEF(I,1)*(WM(I,1)**2/PYVAR(2))**COEF(I,4)
      ENDIF
  380 CONTINUE
      COEF(26,3)=COEF(26,3)*(PMAS(100+2*IPY(9))/PMAS(4))**2
      COEF(26,3)=COEF(26,3)*(MAX(2.*PYVAR(11),PYPAR(20))/PMAS(4))**2
      COEF(33,5)=COEF(33,5)*(WM(33,2)**2/PYVAR(2))**COEF(33,4)
C...SPECIAL CASES:
C...Z0/GAM*
      IF(IPY(11).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
        PROC(11)='Q + QB -> GAM*'
        COEF(11,2)=0.
        COEF(11,3)=0.
      ELSEIF(IPY(11).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED:
        PROC(11)='Q + QB -> Z0'
        COEF(11,2)=0.
      ELSEIF(IPY(11).EQ.3) THEN
C...FULL Z0/GAM* PRODUCTION INCLUDED:
        COEF(11,1)=0.
      ENDIF
C...Z'0/Z0/GAM*
      IF(IPY(39).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
        PROC(33)='Q + QB -> GAM*'
        COEF(33,2)=0.
        COEF(33,3)=0.
        COEF(33,5)=0.
        COEF(33,6)=0.
      ELSEIF(IPY(39).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED:
        PROC(33)='Q + QB -> Z0'
        COEF(33,2)=0.
        COEF(33,5)=0.
        COEF(33,6)=0.
      ELSEIF(IPY(39).EQ.3) THEN
C...ONLY Z'0 PRODUCTION INCLUDED:
        PROC(33)='Q + QB -> Z''0'
        COEF(33,1)=0.
        COEF(33,2)=0.
        COEF(33,3)=0.
      ELSEIF(IPY(39).EQ.4) THEN
C...ONLY Z0/GAM* PRODUCTION INCLUDED:
        PROC(33)='Q + QB -> Z0/GAM*'
        COEF(33,1)=0.
        COEF(33,5)=0.
        COEF(33,6)=0.
      ELSEIF(IPY(39).EQ.5) THEN
C...ONLY Z'0/GAM* PRODUCTION INCLUDED:
        PROC(33)='Q + QB -> Z''0/GAM*'
        COEF(33,1)=0.
        COEF(33,3)=0.
        COEF(33,5)=0.
      ELSEIF(IPY(39).EQ.6) THEN
C...ONLY Z'0/Z0 PRODUCTION INCLUDED:
        PROC(33)='Q + QB -> Z''0/Z0'
        COEF(33,1)=0.
        COEF(33,2)=0.
        COEF(33,5)=0.
      ELSEIF(IPY(39).EQ.7) THEN
C...FULL Z'0/Z0/GAM* PRODUCTION INCLUDED:
        COEF(33,1)=0.
        COEF(33,5)=0.
      ENDIF
 
C...SELECT TYPE OF QCD PROCESS GENERATION SCHEME
      IPY(2)=MAX(0,MIN(3,IPY(2)))
      DO 390 I=7,40
  390 IF(ISUBPR(I).EQ.1) IPY(2)=0
      IPY(50)=IPY(2)+1
      IF(ISUBPR(1)+ISUBPR(2)+ISUBPR(3)+ISUBPR(4)+ISUBPR(5)+
     &ISUBPR(6).EQ.0) IPY(50)=0
      IF(ISUBPR(7).EQ.1) IPY(50)=5
      IPY(49)=-ISUBPR(8)-ISUBPR(9)-ISUBPR(10)
      DO 400 I=1,40
  400 IPY(49)=IPY(49)+ISUBPR(I)
 
C...CHOOSE LAMBDA VALUE TO USE IN ALPHA-STRONG
      IF(MOD(IPY(3),10).EQ.2) THEN
        ILAM=MOD(IABS(IPY(7)),10)
        IF(ILAM.EQ.0) ALAM=PYPAR(4)
        IF(ILAM.EQ.1) ALAM=0.2
        IF(ILAM.EQ.2) ALAM=0.29
        IF(ILAM.EQ.3) ALAM=0.2
        IF(ILAM.EQ.4) ALAM=0.4
        IF(ILAM.EQ.5) ALAM=0.4
        PYPAR(4)=ALAM
        PYPAR(21)=ALAM
        PARE(21)=ALAM
      ENDIF
 
C...RESET VARIABLES FOR CROSS-SECTION CALCULATION
      DO 410 I=0,40
      XSEC(I)=0.
      XMAX(I)=0.
      NGEN(I,1)=0
      NGEN(I,2)=0
      NGEN(I,3)=0
  410 XPRI(I)=0.
      VMAX=0.
      PYVAR(22)=0.
 
C...FIND PARAMETRIZED TOTAL CROSS-SECTIONS
      CALL PYXTOT
 
C...MAXIMA OF DIFFERENTIAL CROSS-SECTIONS
      IF(IPY(1).EQ.0) CALL PYMAXI
      PYVAR(41)=0.
      IF(IPY(50).GE.1) PYVAR(41)=XMAX(IPY(50))
      PYVAR(42)=PYVAR(41)+XMAX(8)+XMAX(9)+XMAX(10)
      PYVAR(43)=PYVAR(42)
      DO 420 I=11,30
  420 PYVAR(43)=PYVAR(43)+XMAX(I)
 
C...INITIALIZE MULTIPLE INTERACTIONS WITH VARIABLE IMPACT PARAMETER
      IF(IPY(49).NE.0.AND.IPY(12).GE.2) CALL PYINMU
 
C...INITIALIZATION OF TIMELIKE SHOWERS (OPTIONAL)
      IF((IPY(13).GE.1.OR.(IPY(14).GT.0.AND.MOD(IPY(14),2).EQ.0)).
     &AND.IPY(49).GT.0) CALL LUSHOW(0,0,PYVAR(1))
 
C...DEFINE PARTICLE CODES FOR DIFFRACTIVE STATES, R AND H+/- IF NEEDED
      IF(ISUBPR(8)+ISUBPR(9).NE.0) THEN
        DO 430 I=1,2
        IF(IABS(K(I,2)).EQ.17) THEN
          CHAF(38+I)='PI*'
          KTYP(38+I)=3
        ELSEIF(IABS(K(I,2)).EQ.41) THEN
          CHAF(38+I)='P*'
          KTYP(38+I)=3
        ELSE
          CHAF(38+I)='N*'
          KTYP(38+I)=2
        ENDIF
  430   CONTINUE
      ENDIF
      WRITE(MST(20),2400)
 
C...FORMATS FOR INITIALIZATION AND ERROR INFORMATION
 1000 FORMAT(//20X,'THE LUND MONTE CARLO - PYTHIA VERSION 4.8'/
     &         20X,'    LAST DATE OF CHANGE: 24 JANU 1990    '/
     &         20X,'NOTE: PYPAR(6) NOW OVERALL K FACTOR IN QCD')
 1100 FORMAT(1X,'ERROR: UNRECOGNIZED BEAM PARTICLE ''',A,
     &'''. EXECUTION STOPPED.')
 1200 FORMAT(1X,'ERROR: UNRECOGNIZED TARGET PARTICLE ''',A,
     &'''. EXECUTION STOPPED.')
 1300 FORMAT('1',18('*'),1X,'PYINIT: INITIALIZATION OF PYTHIA ',
     &'ROUTINES',1X,18('*'))
 1400 FORMAT(/1X,79('=')/1X,'I',77X,'I'/1X,'I',2X,'PYTHIA WILL BE ',
     &'INITIALIZED FOR',1X,A42,2X,'I')
 1500 FORMAT(1X,'I',2X,'AT',1X,F10.3,1X,'GEV CENTER-OF-MASS ENERGY',
     &36X,'I')
 1600 FORMAT(1X,'I',2X,'AT',1X,F10.3,1X,'GEV/C LAB-MOMENTUM',43X,'I')
 1700 FORMAT(1X,'I',77X,'I'/1X,'I',2X,'CORRESPONDING TO',1X,F10.3,1X,
     &'GEV CENTER-OF-MASS ENERGY',22X,'I')
 1800 FORMAT(1X,'I',77X,'I'/1X,'I',10X,'PX(GEV/C)',4X,'PY(GEV/C)',4X,
     &'PZ(GEV/C)',32X,'I')
 1900 FORMAT(1X,'I',2X,A4,3(2X,F10.3,1X),32X,'I')
 2000 FORMAT(1X,'ERROR: UNRECOGNIZED COORDINATE FRAME ''',A,
     &'''. EXECUTION STOPPED.')
 2100 FORMAT(1X,'I',77X,'I'/1X,'I',10X,'MINIMUM REQUIRED PT OF HARD ',
     &'SCATTERING:',1X,F10.3,1X,'GEV/C',11X,'I'/1X,'I',77X,'I'/1X,'I',
     &10X,'MINIMUM REQUIRED MASS OF FINAL STATE:',3X,F10.3,1X,'GEV/C2',
     &10X,'I'/1X,'I',77X,'I'/1X,79('='))
 2200 FORMAT(//1X,15('*'),1X,'PYINIT: SUMMARY OF ALLOWED DECAY MODES',
     &1X,'(IPROD)',1X,16('*')//24X,' REC',1X,' QCD',1X,' Z0 ',1X,'W+/-',
     &1X,' H0 ',1X,' R  ',1X,'H+/-',1X,' Z''0'/)
 2300 FORMAT(17X,A6,8(1X,A4))
 2400 FORMAT(/1X,22('*'),1X,'PYINIT: INITIALIZATION COMPLETED',1X,
     &23('*'))
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYTHIA
 
C...ADMINISTERS THE GENERATION OF A HIGH-PT EVENT VIA CALLS TO A NUMBER
C...OF SUBROUTINES; ALSO COMPUTES CROSS-SECTIONS.
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
 
C...GENERATE VARIABLES OF HARD SCATTERING
  100 NGEN(0,2)=NGEN(0,2)+1
      IPY(45)=0
      IPY(48)=0
      CALL PYRAND
      IGRP=IPY(44)
      IF(ISUBPR(7).EQ.1.AND.(IGRP.LE.7.OR.IGRP.GE.11)) NGEN(7,1)=
     &NGEN(7,1)+1
      IF(IPY(20).EQ.-1) GOTO 120
 
      IF(IGRP.LE.7.OR.IGRP.GE.11) THEN
C...HARD SCATTERING (INCLUDING LOW-PT):
C...RECONSTRUCT KINEMATICS AND COLOUR FLOW OF HARD SCATTERING
        CALL PYSCAT
        NGEN(ISUB,2)=NGEN(ISUB,2)+1
        IF(IPY(48).EQ.1) GOTO 100
 
C...SHOWERING OF INITIAL STATE PARTONS (OPTIONAL)
        IPU1=21
        IPU2=23
        IF(IPY(14).GE.1.AND.(ISUB.LE.6.OR.ISUB.GE.11))
     &  CALL PYSSPA(IPU1,IPU2)
 
C...EXTRA SCATTERINGS LEADING TO CLOSED GLUON LOOPS
        IF(IPY(12).GE.1.AND.(ISUB.LE.6.OR.ISUB.GE.11)) CALL PYMULT
 
C...HADRON REMNANTS AND PRIMORDIAL KT
        CALL PYREMN(IPU1,IPU2)
        IF(IPY(48).EQ.1) GOTO 100
 
C...SHOWERING OF FINAL STATE PARTONS (OPTIONAL)
        IF(IPY(13).GE.1.AND.(ISUB.LE.6.OR.ISUB.GE.11).AND.
     &  K(25,1).LT.20000.AND.K(27,1).LT.20000) THEN
          QMAX=SQRT(PYPAR(25)*Q2)
          IF(ISET(IGRP).EQ.2.OR.ISET(IGRP).EQ.3) QMAX=SQRT(SH)
          IF(ISUB.EQ.27) QMAX=SQRT(PMAS(2)**2)
          IF(ISUB.EQ.28) QMAX=SQRT(PMAS(3)**2)
          CALL LUSHOW(25,27,QMAX)
        ENDIF
 
C...DECAY OF FINAL STATE RESONANCES (Z0/GAM*, W+/-, H0 AND H+/-)
        IF(ISUB.GE.11) CALL PYRESD
 
      ELSE
C...DIFFRACTIVE AND ELASTIC SCATTERING:
        CALL PYDIFF
        NGEN(ISUB,2)=NGEN(ISUB,2)+1
      ENDIF
 
C...REARRANGE PARTONS ALONG STRINGS, CHECK INVARIANT MASS CUTS
      MST(21)=2-IPY(34)
      IF(IPY(34).EQ.0) MST(21)=3
      MST(26)=0
      CALL LUPREP
      IF(IPY(34).EQ.0) IPY(40)=0
      IF(IPY(19).EQ.1.AND.MST(26).EQ.3) GOTO 100
 
C...RECALCULATE ENERGIES FROM MOMENTA AND MASSES (IF DESIRED)
      IF(IPY(37).GE.1) THEN
        DO 110 I=1,N
  110   IF(K(I,1).LT.20000) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+
     &  P(I,3)**2+P(I,5)**2)
      ENDIF
 
C...PERFORM HADRONIZATION (IF DESIRED)
      IF(IPY(20).EQ.1) CALL LUEXEC
 
C...TRANSFORM TO THE DESIRED COORDINATE FRAME
      CALL PYFRAM(IPY(33))
 
C...CALCULATE MONTE CARLO ESTIMATES OF CROSS-SECTIONS
      NGEN(ISUB,3)=NGEN(ISUB,3)+1
  120 NGEN(0,3)=NGEN(0,3)+1
      XSEC(0)=0.
      DO 130 I=1,40
      I1=I
      IF(I.LE.6) I1=MAX(IPY(50),1)
      IF(NGEN(I1,1).EQ.0) THEN
        XSEC(I)=0.
      ELSEIF(NGEN(I,2).EQ.0) THEN
        XSEC(I)=XPRI(I)*NGEN(0,3)/(FLOAT(NGEN(I1,1))*FLOAT(NGEN(0,2)))
      ELSE
        XSEC(I)=XPRI(I)*NGEN(I,3)/(FLOAT(NGEN(I1,1))*FLOAT(NGEN(I,2)))
      ENDIF
  130 XSEC(0)=XSEC(0)+XSEC(I)
      IF(IPY(50).EQ.5) THEN
        NGENS=NGEN(7,3)+NGEN(8,3)+NGEN(9,3)+NGEN(10,3)
        XSECS=XSEC(7)+XSEC(8)+XSEC(9)+XSEC(10)
        XMAXS=XMAX(7)+XMAX(8)+XMAX(9)+XMAX(10)
        FAC=1.
        IF(NGENS.LT.NGEN(0,3)) FAC=(XMAXS-XSECS)/(XSEC(0)-XSECS)
        DO 140 I=1,6
  140   XSEC(I)=FAC*XSEC(I)
        XSEC(0)=XMAX(7)+XSEC(8)+XSEC(9)+XSEC(10)
      ENDIF
      PYVAR(22)=PYVAR(22)+PYVAR(21)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYSTAT(ISTAT)
 
C...PRINTS OUT INFORMATION ABOUT CROSS-SECTIONS, DECAY WIDTHS, BRANCHING
C...RATIOS, STATUS CODES AND PARAMETER VALUES.
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      COMMON/PYINT4/PWTOT(10),PW(10,10,10,3),EWTOT(10),EW(10,10,10,3)
      COMMON/PYCHAR/PROC(-5:40)
      CHARACTER PROC*26,CODE(-30:30)*6,STATE(-1:1)*4,STATUS*4
      DATA CODE/4*' ','Z''0   ','H-    ','R     ','H0    ','W-    ',
     &'Z0    ',2*' ','NU-CHI','CHI+  ','NU-TAU','TAU+  ','NU-MU ',
     &'MU+   ','NU-E  ','E+    ',2*' ','HB    ','LB    ','TB    ',
     &'BB    ','CB    ','SB    ','DB    ','UB    ',' ','U     ',
     &'D     ','S     ','C     ','B     ','T     ','L     ','H     ',
     &2*' ','E-    ','NU-E  ','MU-   ','NU-MU ','TAU-  ','NU-TAU',
     &'CHI-  ','NU-CHI',2*' ','Z0    ','W+    ','H0    ','R     ',
     &'H+    ','Z''0   ',4*' '/
      DATA STATE/' ---',' OFF',' ON '/
 
      IF(ISTAT.LT.0.OR.ISTAT.GT.2) RETURN
      IF(ISTAT.EQ.1) GOTO 120
      IF(ISTAT.EQ.2) GOTO 260
 
C...CROSS-SECTIONS
      WRITE(MST(20),1000)
      WRITE(MST(20),1100)
      WRITE(MST(20),1200) 0,PROC(0),' ---',NGEN(0,3),NGEN(0,1),XSEC(0)
      DO 100 I=1,IPY(35)
      I1=I
      IF(I.LE.6) I1=MAX(IPY(50),1)
  100 WRITE(MST(20),1200) I,PROC(I),STATE(ISUBPR(I)),NGEN(I,3),
     &NGEN(I1,1),XSEC(I)
      DO 110 I=31,IPY(36)
  110 WRITE(MST(20),1200) I,PROC(I),STATE(ISUBPR(I)),NGEN(I,3),
     &NGEN(I,1),XSEC(I)
      WRITE(MST(20),1300) 1.-FLOAT(NGEN(0,3))/FLOAT(NGEN(0,2))
      RETURN
 
C...DECAY WIDTHS AND BRANCHING RATIOS
  120 WRITE(MST(20),1400)
      WRITE(MST(20),1500)
C...Z0:
      IF(EWTOT(2).GT.0.) THEN
        WRITE(MST(20),1600) CODE(21),PWTOT(2),1.,STATE(IPY(22)),1.
        DO 130 I=1,2*IPY(9)
        IQ=I
        IF(IQ.LE.2) IQ=3-IQ
        STATUS=STATE(IPROD(2,IQ))
  130   WRITE(MST(20),1700) CODE(IQ),CODE(-IQ),PW(2,IQ,IQ,1),
     &  PW(2,IQ,IQ,1)/PWTOT(2),STATUS,EW(2,IQ,IQ,1)/EWTOT(2)
        DO 140 I=1,2*IPY(9)
        STATUS=STATE(IPROD(2,10+I))
  140   WRITE(MST(20),1700) CODE(10+I),CODE(-(10+I)),PW(2,I,I,2),
     &  PW(2,I,I,2)/PWTOT(2),STATUS,EW(2,I,I,2)/EWTOT(2)
        STATUS=STATE(IPROD(2,23))
        WRITE(MST(20),1700) CODE(25),CODE(-25),PW(2,3,3,3),
     &  PW(2,3,3,3)/PWTOT(2),STATUS,EW(2,3,3,3)/EWTOT(2)
      ELSE
        WRITE(MST(20),1600) CODE(21),PWTOT(2),1.,STATE(IPY(22)),0.
      ENDIF
C...W+/-:
      IF(EWTOT(3).GT.0.) THEN
        WRITE(MST(20),1600) CODE(-22),PWTOT(3),1.,STATE(IPY(23)),1.
        DO 150 I=1,IPY(9)
        IL=2*I-1
        IF(IL.EQ.1) IL=2
        DO 150 J=1,IPY(9)
        JU=2*J
        IF(JU.EQ.2) JU=1
        STATUS=STATE(MIN(IPROD(3,IL),IPROD(3,JU)))
  150   WRITE(MST(20),1700) CODE(IL),CODE(-JU),PW(3,IL,JU,1),
     &  PW(3,IL,JU,1)/PWTOT(3),STATUS,EW(3,IL,JU,1)/EWTOT(3)
        DO 160 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        STATUS=STATE(MIN(IPROD(3,10+IL),IPROD(3,10+IU)))
  160   WRITE(MST(20),1700) CODE(10+IL),CODE(-(10+IU)),PW(3,IL,IU,2),
     &  PW(3,IL,IU,2)/PWTOT(3),STATUS,EW(3,IL,IU,2)/EWTOT(3)
      ELSE
        WRITE(MST(20),1600) CODE(-22),PWTOT(3),1.,STATE(IPY(23)),0.
      ENDIF
C...H0:
      IF(EWTOT(4).GT.0.) THEN
        WRITE(MST(20),1600) CODE(23),PWTOT(4),1.,STATE(IPY(24)),1.
        DO 170 I=1,2*IPY(9)
        IQ=I
        IF(IQ.LE.2) IQ=3-IQ
        STATUS=STATE(IPROD(4,IQ))
  170   WRITE(MST(20),1700) CODE(IQ),CODE(-IQ),PW(4,IQ,IQ,1),
     &  PW(4,IQ,IQ,1)/PWTOT(4),STATUS,EW(4,IQ,IQ,1)/EWTOT(4)
        DO 180 I=1,IPY(9)
        IL=2*I-1
        STATUS=STATE(IPROD(4,10+IL))
  180   WRITE(MST(20),1700) CODE(10+IL),CODE(-(10+IL)),PW(4,IL,IL,2),
     &  PW(4,IL,IL,2)/PWTOT(4),STATUS,EW(4,IL,IL,2)/EWTOT(4)
        DO 190 I=1,2
        STATUS=STATE(IPROD(4,20+I))
  190   WRITE(MST(20),1700) CODE(20+I),CODE(-(20+I)),PW(4,I,I,3),
     &  PW(4,I,I,3)/PWTOT(4),STATUS,EW(4,I,I,3)/EWTOT(4)
      ELSE
        WRITE(MST(20),1600) CODE(23),PWTOT(4),1.,STATE(IPY(24)),0.
      ENDIF
C...R:
      IF(EWTOT(5).GT.0.) THEN
        WRITE(MST(20),1600) CODE(24),PWTOT(5),1.,STATE(IPY(25)),1.
        DO 200 I=1,2*(IPY(9)-1)
        IL=I
        IF(IL.LE.2) IL=3-IL
        IU=I+2
        STATUS=STATE(MIN(IPROD(5,IL),IPROD(5,IU)))
  200   WRITE(MST(20),1700) CODE(IL),CODE(-IU),PW(5,IL,IU,1),
     &  PW(5,IL,IU,1)/PWTOT(5),STATUS,EW(5,IL,IU,1)/EWTOT(5)
        DO 210 I=1,IPY(9)-1
        IL=2*I-1
        IU=2*I+1
        STATUS=STATE(MIN(IPROD(5,10+IL),IPROD(5,10+IU)))
  210   WRITE(MST(20),1700) CODE(10+IL),CODE(-(10+IU)),PW(5,IL,IU,2),
     &  PW(5,IL,IU,2)/PWTOT(5),STATUS,EW(5,IL,IU,2)/EWTOT(5)
      ELSE
        WRITE(MST(20),1600) CODE(24),PWTOT(5),1.,STATE(IPY(25)),0.
      ENDIF
C...H+/-:
      IF(EWTOT(6).GT.0.) THEN
        WRITE(MST(20),1600) CODE(-25),PWTOT(6),1.,STATE(IPY(26)),1.
        DO 220 I=1,IPY(9)
        IL=2*I-1
        IF(IL.EQ.1) IL=2
        IU=2*I
        IF(IU.EQ.2) IU=1
        STATUS=STATE(MIN(IPROD(6,IL),IPROD(6,IU)))
  220   WRITE(MST(20),1700) CODE(IL),CODE(-IU),PW(6,IL,IU,1),
     &  PW(6,IL,IU,1)/PWTOT(6),STATUS,EW(6,IL,IU,1)/EWTOT(6)
        DO 230 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        STATUS=STATE(MIN(IPROD(6,10+IL),IPROD(6,10+IU)))
  230   WRITE(MST(20),1700) CODE(10+IL),CODE(-(10+IU)),PW(6,IL,IU,2),
     &  PW(6,IL,IU,2)/PWTOT(6),STATUS,EW(6,IL,IU,2)/EWTOT(6)
      ELSE
        WRITE(MST(20),1600) CODE(-25),PWTOT(6),1.,STATE(IPY(26)),0.
      ENDIF
C...Z'0:
      IF(EWTOT(7).GT.0.) THEN
        WRITE(MST(20),1600) CODE(26),PWTOT(7),1.,STATE(IPY(27)),1.
        DO 240 I=1,2*IPY(9)
        IQ=I
        IF(IQ.LE.2) IQ=3-IQ
        STATUS=STATE(IPROD(7,IQ))
  240   WRITE(MST(20),1700) CODE(IQ),CODE(-IQ),PW(7,IQ,IQ,1),
     &  PW(7,IQ,IQ,1)/PWTOT(7),STATUS,EW(7,IQ,IQ,1)/EWTOT(7)
        DO 250 I=1,2*IPY(9)
        STATUS=STATE(IPROD(7,10+I))
  250   WRITE(MST(20),1700) CODE(10+I),CODE(-(10+I)),PW(7,I,I,2),
     &  PW(7,I,I,2)/PWTOT(7),STATUS,EW(7,I,I,2)/EWTOT(7)
      ELSE
        WRITE(MST(20),1600) CODE(26),PWTOT(7),1.,STATE(IPY(27)),0.
      ENDIF
      WRITE(MST(20),1800)
      RETURN
 
C...STATUS CODES AND PARAMETER VALUES
  260 WRITE(MST(20),1900)
      WRITE(MST(20),2000)
      DO 270 I=1,40
  270 WRITE(MST(20),2100) I,IPY(I),PYPAR(I),40+I,IPY(40+I),PYPAR(40+I)
 
C...FORMATS FOR PRINTOUTS
 1000 FORMAT('1',10('*'),1X,'PYSTAT: STATISTICS ON NUMBER OF ',
     &'EVENTS AND CROSS-SECTIONS',1X,10('*'))
 1100 FORMAT(/1X,79('=')/1X,'I',38X,'I',22X,'I',15X,'I'/1X,'I',14X,
     &'SUBPROCESS',14X,'I',3X,'NUMBER OF POINTS',3X,'I',1X,
     &'CROSS-SECTION',1X,'I'/1X,'I',38X,'I',22X,'I',15X,'I'/1X,'I',
     &38('-'),'I',22('-'),'I',4X,'(IN MB)',4X,'I'/1X,'I',38X,'I',22X,
     &'I',15X,'I'/1X,'I',1X,'ISUB',1X,'TYPE',22X,'STATE',1X,'I',1X,
     &'GENERATED',6X,'TRIED',1X,'I',15X,'I'/1X,'I',38X,'I',22X,'I',
     &15X,'I'/1X,79('=')/1X,'I',38X,'I',22X,'I',15X,'I')
 1200 FORMAT(1X,'I',2X,I2,2X,A26,1X,A4,1X,'I',I10,I11,1X,'I',2X,
     &1P,E12.3,1X,'I')
 1300 FORMAT(1X,'I',38X,'I',22X,'I',15X,'I'/1X,79('=')//
     &1X,'********** FRACTION OF EVENTS THAT FAIL FRAGMENTATION ',
     &'CUTS =',F8.5,' **********'/)
 1400 FORMAT('1',11('*'),1X,'PYSTAT: STATISTICS ON DECAY WIDTHS ',
     &'AND BRANCHING RATIOS',1X,11('*'))
 1500 FORMAT(/1X,79('=')/1X,'I',24X,'I',14X,'I',14X,'I',7X,'I',14X,'I'/
     &1X,'I',1X,'DECAY CHANNEL',10X,'I',2X,'WIDTH (GEV)',1X,'I',9X,
     &'B.R.',1X,'I',1X,'STATE',1X,'I',4X,'EFF. B.R.',1X,'I'/1X,'I',24X,
     &'I',14X,'I',14X,'I',7X,'I',14X,'I'/1X,79('='))
 1600 FORMAT(1X,'I',24X,'I',14X,'I',14X,'I',7X,'I',14X,'I'/1X,'I',1X,A6,
     &17X,'I',1X,1P,E12.3,0P,1X,'I',1X,1P,E12.3,0P,1X,'I',2X,A4,1X,'I',
     &1X,1P,E12.3,0P,1X,'I')
 1700 FORMAT(1X,'I',4X,'->',1X,A6,1X,'+',1X,A6,2X,'I',1X,1P,E12.3,0P,1X,
     &'I',1X,1P,E12.3,0P,1X,'I',2X,A4,1X,'I',1X,1P,E12.3,0P,1X,'I')
 1800 FORMAT(1X,'I',24X,'I',14X,'I',14X,'I',7X,'I',14X,'I'/1X,79('='))
 1900 FORMAT('1',12('*'),1X,'PYSTAT: SUMMARY OF STATUS CODES AND ',
     &'PARAMETER VALUES',1X,13('*'))
 2000 FORMAT(/2X,'I',5X,'IPY(I)',8X,'PYPAR(I)',22X,'I',5X,'IPY(I)',8X,
     &'PYPAR(I)'/)
 2100 FORMAT(1X,I2,5X,I6,4X,1P,E12.3,0P,21X,I2,5X,I6,4X,1P,E12.3)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYXTOT
 
C...PARAMETRIZES TOTAL, DOUBLE DIFFRACTIVE, SINGLE DIFFRACTIVE AND
C...ELASTIC CROSS-SECTIONS FOR DIFFERENT ENERGIES AND BEAMS.
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      DIMENSION BCS(5,8),BCB(2,5),BCC(3)
 
C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
C...BLOCK, CAHN PARAMETRIZATION OF TOTAL CROSS-SECTION AND NUCLEAR
C...SLOPE PARAMETER; SEE BELOW
      DATA ((BCS(I,J),J=1,8),I=1,5)/
     1 41.74, 0.66, 0.0000, 337.,  0.0, 0.0, -39.3, 0.48,
     2 41.66, 0.60, 0.0000, 306.,  0.0, 0.0, -34.6, 0.51,
     3 41.36, 0.63, 0.0000, 299.,  7.3, 0.5, -40.4, 0.47,
     4 41.68, 0.63, 0.0083, 330.,  0.0, 0.0, -39.0, 0.48,
     5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/
      DATA ((BCB(I,J),J=1,5),I=1,2)/
     1 10.79, -0.049, 0.040, 21.5, 1.23,
     2  9.92, -0.027, 0.013, 18.9, 1.07/
      DATA BCC/2.0164346,-0.5590311,0.0376279/
 
C...TOTAL CROSS-SECTION AND NUCLEAR SLOPE PARAMETER FOR PP AND P-PBAR
C...FROM BLOCK, CAHN: REV. MOD. PHYS. 57 (1985) 563; AS REVISED IN
C...M. BLOCK: TALK AT XXI:ST RENCONTRE DE MORIOND, MARCH 16-22, 1986.
      NFIT=IPY(6)
      SIGP=BCS(NFIT,1)+BCS(NFIT,2)*(-0.25*PAR(71)**2*
     &(1.-0.25*BCS(NFIT,3)*PAR(71)**2)+(1.+0.5*BCS(NFIT,3)*PAR(71)**2)*
     &(ALOG(PYVAR(2)/BCS(NFIT,4)))**2+BCS(NFIT,3)*
     &(ALOG(PYVAR(2)/BCS(NFIT,4)))**4)/
     &((1.-0.25*BCS(NFIT,3)*PAR(71)**2)**2+2.*BCS(NFIT,3)*
     &(1.+0.25*BCS(NFIT,3)*PAR(71)**2)*(ALOG(PYVAR(2)/BCS(NFIT,4)))**2+
     &BCS(NFIT,3)**2*(ALOG(PYVAR(2)/BCS(NFIT,4)))**4)+BCS(NFIT,5)*
     &PYVAR(2)**(BCS(NFIT,6)-1.)*SIN(0.5*PAR(71)*BCS(NFIT,6))
      SIGM=-BCS(NFIT,7)*PYVAR(2)**(BCS(NFIT,8)-1.)*
     &COS(0.5*PAR(71)*BCS(NFIT,8))
      REFP=BCS(NFIT,2)*PAR(71)*ALOG(PYVAR(2)/BCS(NFIT,4))/
     &((1.-0.25*BCS(NFIT,3)*PAR(71)**2)**2+2.*BCS(NFIT,3)*
     &(1.+0.25*BCS(NFIT,3)*PAR(71)**2)+(ALOG(PYVAR(2)/BCS(NFIT,4)))**2+
     &BCS(NFIT,3)**2*(ALOG(PYVAR(2)/BCS(NFIT,4)))**4)-BCS(NFIT,5)*
     &PYVAR(2)**(BCS(NFIT,6)-1.)*COS(0.5*PAR(71)*BCS(NFIT,6))
      REFM=-BCS(NFIT,7)*PYVAR(2)**(BCS(NFIT,8)-1.)*
     &SIN(0.5*PAR(71)*BCS(NFIT,8))
      SIGMA=SIGP-ISIGN(1,IPY(41)*IPY(42))*SIGM
      RHO=(REFP-ISIGN(1,IPY(41)*IPY(42))*REFM)/SIGMA
 
C...NUCLEAR SLOPE PARAMETER B, CURVATURE C:
      NFIT=1
      IF(IPY(6).GE.4) NFIT=2
      BP=BCB(NFIT,1)+BCB(NFIT,2)*ALOG(PYVAR(2))+
     &BCB(NFIT,3)*(ALOG(PYVAR(2)))**2
      BM=BCB(NFIT,4)+BCB(NFIT,5)*ALOG(PYVAR(2))
      B=BP-ISIGN(1,IPY(41)*IPY(42))*SIGM/SIGP*(BM-BP)
      PYVAR(37)=B
      C=-0.5*BCC(2)/BCC(3)*(1.-SQRT(MAX(0.,1.+4.*BCC(3)/BCC(2)**2*
     &(1.E-03*PYVAR(1)-BCC(1)))))
      PYVAR(38)=C
 
C...ELASTIC SCATTERING CROSS-SECTION (FIXED BY SIGMA-TOT, RHO AND B)
      SIGEL=SIGMA**2*(1.+RHO**2)/(16.*PAR(71)*PYPAR(35)*B)
 
C...SINGLE DIFFRACTIVE SCATTERING CROSS-SECTION FROM K. GOULIANOS:
C...PHYS. REP. 101 (1983) 169.
      SIGSD=2.*0.68*(1.+36./PYVAR(2))*ALOG(0.6+0.1*PYVAR(2))
 
C...DOUBLE DIFFRACTIVE SCATTERING CROSS-SECTION (ESSENTIALLY FIXED BY
C...SIGMA-SD AND SIGMA-EL)
      SIGDD=SIGSD**2/(3.*SIGEL)
 
C...TOTAL NON-ELASTIC, NON-DIFFRACTIVE CROSS-SECTION
      XMAX(7)=SIGMA-SIGDD-SIGSD-SIGEL
 
C...RESCALE FOR PIONS
      IF(IABS(IPY(41)).EQ.17.AND.IABS(IPY(42)).EQ.17) THEN
        SIGMA=4./9.*SIGMA
        SIGDD=4./9.*SIGDD
        SIGSD=4./9.*SIGSD
        SIGEL=4./9.*SIGEL
        XMAX(7)=4./9.*XMAX(7)
      ELSEIF(IABS(IPY(41)).EQ.17.OR.IABS(IPY(42)).EQ.17) THEN
        SIGMA=2./3.*SIGMA
        SIGDD=2./3.*SIGDD
        SIGSD=2./3.*SIGSD
        SIGEL=2./3.*SIGEL
        XMAX(7)=2./3.*XMAX(7)
      ENDIF
 
C...SAVE CROSS-SECTIONS IN COMMON BLOCK PYPARA
      PYVAR(50)=SIGMA
      PYVAR(51)=SIGDD
      PYVAR(52)=SIGSD
      PYVAR(53)=SIGEL
      PYVAR(54)=XMAX(7)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYMAXI
 
C...FINDS MAXIMUM OF THE PART OF THE DIFFERENTIAL CROSS-SECTION USED IN
C...THE EVENT WEIGHTING.
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
      COMMON/PYCHAR/PROC(-5:40)
      CHARACTER PROC*26,MARK*1
      DIMENSION SMAX(40,3),DSTEP(18),DSIGP(4)
      DATA SMAX/120*0./,DSTEP/0.1,2*0.05,0.07,0.02,0.03,0.2,0.09,0.04,
     &0.05,2*0.02,0.15,0.05,0.02,0.05,0.05,0.05/
 
C...RESET POSITION OF MAXIMUM, SELECT WHICH SUBPROCESS GROUPS TO STUDY
      IF(IPY(31).GE.1) WRITE(MST(20),1000)
      IF(IPY(31).GE.2) WRITE(MST(20),1100)
      DO 120 IGRP=1,40
      IPY(44)=IGRP
      IF(ISET(IGRP).EQ.8) HM=0.
      TAUM=0.
      XFM=0.
      THM=0.
C...SKIP CASES NOT APPLICABLE: QCD (WITH QT2-WEIGHT), MULTIPLE SCATTERING,
C...TOTAL CROSS-SECTION PROCESSES AND EMPTY POSITIONS
      IF(IGRP.LE.4.AND.IGRP.NE.IPY(50)) GOTO 120
      IF(IGRP.EQ.5.AND.IPY(12).LE.0.AND.IGRP.NE.IPY(50)) GOTO 120
      IF(IGRP.EQ.5.AND.IPY(49).EQ.0) GOTO 120
      IF(IGRP.GE.6.AND.IGRP.LE.10) GOTO 120
      IF(IGRP.GE.11.AND.ISUBPR(IGRP).EQ.0) GOTO 120
 
      IF(ISET(IGRP).EQ.1) THEN
C...2 -> 2 PROCESSES:
        IF(IPY(31).GE.2) WRITE(MST(20),1200)
        ITHU=2
        ILOW=1
        IUPP=12
        SQM1=WM(IGRP,1)**2
        SQM2=WM(IGRP,2)**2
        TAUMIN=MIN(1.,MAX(SQRT(SQM1+PYVAR(12))+SQRT(SQM2+PYVAR(12)),
     &  PYPAR(20))**2/PYVAR(2))
        PYVAR(16)=TAUMIN
      ELSEIF(ISET(IGRP).EQ.2.OR.ISET(IGRP).EQ.3) THEN
C...RESONANCE PRODUCTION:
        IF(IPY(31).GE.2) WRITE(MST(20),1200)
        ITHU=1
        ILOW=13
        IUPP=17
        IF(WM(IGRP,1)**2.GE.PYVAR(2)) IUPP=16
        IF(IGRP.EQ.33) THEN
          IUPP=18
          IF(WM(IGRP,1)**2.GE.PYVAR(2)) IUPP=IUPP-1
          IF(WM(IGRP,2)**2.GE.PYVAR(2)) IUPP=IUPP-1
        ENDIF
        SQM1=0.
        SQM2=0.
        TAUMIN=MIN(1.,MAX(4.*PYVAR(12),PYPAR(20)**2)/PYVAR(2))
        PYVAR(16)=TAUMIN
      ELSEIF(ISET(IGRP).EQ.4) THEN
C...MULTIPLE SCATTERING:
        IF(IPY(31).GE.2) WRITE(MST(20),1200)
        ITHU=2
        ILOW=1
        IUPP=12
        SQM1=0.
        SQM2=0.
        PYVAR(35)=1.
        PYVAR(36)=1.
      ELSEIF(ISET(IGRP).EQ.8) THEN
C...HIGGS PRODUCTION VIA INTERMEDIATE VECTOR BOSON FUSION:
        IF(IPY(31).GE.2) WRITE(MST(20),1300)
        ITHU=1
        ILOW=13
        IUPP=17
        IF(WM(IGRP,1)**2.GE.PYVAR(2)) IUPP=16
        SQM1=0.
        SQM2=0.
        HMIN=MIN(1.,MAX(4.*PYVAR(12),PYPAR(20)**2)/PYVAR(2))
        PYVAR(26)=HMIN
      ENDIF
      PYVAR(14)=SQM1
      PYVAR(15)=SQM2
 
C...START LOOP OVER SEARCH VARIABLE, SKIP SOME CASES FOR SYMMETRIC XF
      DSIGMX=0.
      DO 110 ITHT=1,ITHU
      DSIGML=0.
      IF(ISET(IGRP).EQ.8) VHM=0.2
      VTAUM=0.2
      VXFM=0.5
      VTHM=0.5
      IF(ITHU.EQ.2) VTHM=FLOAT(ITHT)-1.
      DO 110 IVAR=ILOW,IUPP
      IF(ITHU.EQ.2.AND.ABS(VTHM-0.5).GT.0.499.AND.((IVAR.GE.8.AND.
     &PYVAR(12).GE.100.).OR.IVAR.GE.10)) GOTO 110
 
C...DEFINE GRID OF 3 POINTS ALTERNATIVELY IN TAU, XF AND TH
      IF(ISET(IGRP).EQ.8) VH=VHM
      VTAU=VTAUM
      VXF=VXFM
      VTH=VTHM
      DSTP=DSTEP(IVAR)
      IF(IVAR.EQ.1.OR.IVAR.EQ.4.OR.IVAR.EQ.6.OR.IVAR.EQ.10.OR.
     &IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.15) THEN
        IF(ISET(IGRP).EQ.8) THEN
          VVAR=VH
        ELSE
          VVAR=VTAU
        ENDIF
      ELSEIF(IVAR.LE.3.OR.IVAR.EQ.5.OR.IVAR.EQ.11.OR.IVAR.GE.16) THEN
        IF(ISET(IGRP).EQ.8) THEN
          VVAR=VTAU
        ELSE
          VVAR=VXF
          IF(IVAR.LE.3) VVAR=1.-0.2*IVAR
        ENDIF
      ELSE
        VVAR=VTH
      ENDIF
      VVAR=MIN(MAX(VVAR,DSTP),1.-DSTP)
 
C...DEFINE GRID POINT, CONVERT TO CORRECT VARIABLES TAU, XF AND TH
      ISTP=0
  100 ISTP=ISTP+1
      IF(ISTP.LE.3) VSTP=VVAR+(ISTP-2)*DSTP
      IF(IVAR.EQ.1.OR.IVAR.EQ.4.OR.IVAR.EQ.6.OR.IVAR.EQ.10.OR.
     &IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.15) THEN
        IF(ISET(IGRP).EQ.8) THEN
          VH=VSTP
        ELSE
          VTAU=VSTP
        ENDIF
      ELSEIF(IVAR.LE.3.OR.IVAR.EQ.5.OR.IVAR.EQ.11.OR.IVAR.GE.16) THEN
        IF(ISET(IGRP).EQ.8) THEN
          VTAU=VSTP
        ELSE
          VXF=VSTP
        ENDIF
      ELSE
        VTH=VSTP
      ENDIF
 
      IF(ISET(IGRP).EQ.1) THEN
C...2 -> 2 PROCESSES:
        TAU=TAUMIN**(1.-VTAU)
        XF=(1.-TAU)*(2.*VXF-1.)
        SH=TAU*PYVAR(2)
        CALL PYTHAT(THL,THU)
        TH=(SQM1+SQM2-SH)/(1.+(THL/THU)**(2.*VTH-1.))
        UH=MAX(THL,MIN(THU,SQM1+SQM2-SH-TH))
        QT2=MAX(PYVAR(12),(TH*UH-SQM1*SQM2)/SH)
        IF(IPY(4).EQ.1) THEN
          Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
        ELSEIF(IPY(4).EQ.2) THEN
          Q2=QT2+0.5*(SQM1+SQM2)
        ELSEIF(IPY(4).EQ.3) THEN
          Q2=MIN(-TH,-UH)
        ENDIF
 
      ELSEIF(ISET(IGRP).EQ.2.OR.ISET(IGRP).EQ.3) THEN
C...RESONANCE PRODUCTION:
        IF(IVAR.LE.16) TAU=TAUMIN**(1.-VTAU)
        IF(IVAR.EQ.17) TAU=MIN(1.,MAX(TAUMIN,WM(IGRP,1)**2/PYVAR(2)))
        IF(IVAR.GE.17.AND.IGRP.EQ.33) THEN
          SQML=MIN(WM(IGRP,1),WM(IGRP,2))**2
          SQMU=MAX(WM(IGRP,1),WM(IGRP,2))**2
          IF(IVAR.EQ.17) TAU=MIN(1.,MAX(TAUMIN,SQML/PYVAR(2)))
          IF(IVAR.EQ.18) TAU=MIN(1.,MAX(TAUMIN,SQMU/PYVAR(2)))
        ENDIF
        IF(IVAR.GE.17) VTAU=1.-ALOG(TAU)/ALOG(TAUMIN)
        XF=(1.-TAU)*(2.*VXF-1.)
        SH=TAU*PYVAR(2)
        TH=-0.5*SH
        UH=-0.5*SH
        QT2=MAX(PYVAR(12),TH*UH/SH)
        Q2=SH
 
      ELSEIF(ISET(IGRP).EQ.4) THEN
C...MULTIPLE SCATTERING:
        IF(IPY(12).LE.1) TAU=PYVAR(13)**(1.-VTAU)
        IF(IPY(12).GE.2) TAU=MAX(0.01*PYVAR(13),(PYVAR(13)**(1.-VTAU)-
     &  PYVAR(13))/(1.-PYVAR(13)))
        XF=(1.-TAU)*(2.*VXF-1.)
        SH=TAU*PYVAR(2)
        CALL PYTHAT(THL,THU)
        TH=-SH/(1.+(THL/THU)**(2.*VTH-1.))
        UH=MAX(THL,MIN(THU,-SH-TH))
        QT2=MAX(PYPAR(18)**2,TH*UH/SH)
        IF(IPY(4).EQ.1) THEN
          Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
        ELSEIF(IPY(4).EQ.2) THEN
          Q2=QT2
        ELSEIF(IPY(4).EQ.3) THEN
          Q2=MIN(-TH,-UH)
        ENDIF
 
      ELSEIF(ISET(IGRP).EQ.8) THEN
C...HIGGS PRODUCTION FROM INTERMEDIATE VECTOR BOSON FUSION:
        IF(IVAR.LE.16) H=HMIN**(1.-VH)
        IF(IVAR.EQ.17) H=MIN(1.,MAX(HMIN,WM(IGRP,1)**2/PYVAR(2)))
        IF(IVAR.EQ.17) VH=1.-ALOG(H)/ALOG(HMIN)
        PYVAR(25)=H
        TAUMIN=MIN(1.,1.001*H)
        PYVAR(16)=TAUMIN
        TAU=TAUMIN**(1.-VTAU)
        XF=(1.-TAU)*(2.*VXF-1.)
        SH=TAU*PYVAR(2)
        TH=-0.5*SH
        UH=-0.5*SH
        QT2=MAX(PYVAR(12),TH*UH/SH)
C...Q2 SCALE GIVEN BY INTERMEDIATE VECTOR BOSON MASS
        Q2=PMAS(2)**2
        IF(IGRP.EQ.28) Q2=PMAS(3)**2
      ENDIF
 
C...CALCULATE DIFFERENTIAL CROSS-SECTION IN POINT CHOSEN
      IF(XF.GE.0.) THEN
        X(1)=MIN(0.5*(SQRT(XF**2+4.*TAU)+XF),1.)
        X(2)=MIN(TAU/X(1),1.)
      ELSE
        X(2)=MIN(0.5*(SQRT(XF**2+4.*TAU)-XF),1.)
        X(1)=MIN(TAU/X(2),1.)
      ENDIF
      XT2=4.*QT2/PYVAR(2)
      PYVAR(21)=1.
      IF(IGRP.GE.2.AND.IGRP.LE.4) PYVAR(21)=(PYVAR(12)/QT2)**IPY(2)
      CALL PYDSIG(TAU,XF,XT2,DSIGS)
      IF(ISET(IGRP).EQ.8) Q2=PYVAR(25)*PYVAR(2)
      DSIGS=DSIGS/PYVAR(21)
 
C...CHECK IF BETTER VALUE HAS BEEN OBTAINED
      MARK=' '
      IF(DSIGS.GT.DSIGML) THEN
        DSIGML=DSIGS
        IF(ISET(IGRP).EQ.8) VHM=VH
        VTAUM=VTAU
        VXFM=VXF
        VTHM=VTH
        MARK='*'
      ENDIF
      IF(DSIGS.GT.DSIGMX) THEN
        DSIGMX=DSIGS
        IF(ISET(IGRP).EQ.8) HM=H
        TAUM=TAU
        XFM=XF
        THM=TH
      ENDIF
      IF(IPY(31).GE.2) THEN
        IF(ISET(IGRP).EQ.8) WRITE(MST(20),1400) IGRP,IVAR,ISTP,VH,VTAU,
     &  VTH,H,TAU,TH,DSIGS,MARK
        IF(ISET(IGRP).NE.8) WRITE(MST(20),1400) IGRP,IVAR,ISTP,VTAU,VXF,
     &  VTH,TAU,XF,TH,DSIGS,MARK
      ENDIF
 
C...DO PARABOLA FIT TO FIND MAXIMUM (+VARIOUS SPECIAL CASES)
      DSIGP(ISTP)=ALOG(MAX(1E-30,DSIGS))
      IF(ISTP.EQ.3) THEN
        IF(DSIGP(3)+DSIGP(1).LT.2.*DSIGP(2)) THEN
          DNEW=0.5*(DSIGP(3)-DSIGP(1))/(2.*DSIGP(2)-DSIGP(1)-
     &    DSIGP(3))
        ELSE
          DNEW=SIGN(2.,1.00001*DSIGP(3)-DSIGP(1))
        ENDIF
        VSTP=MIN(MAX(VVAR+DNEW*DSTP,0.2*DSTP,VVAR-2.*DSTP),
     &  1.-0.2*DSTP,VVAR+2.*DSTP)
      ENDIF
      IF(ISTP.LE.3) GOTO 100
  110 CONTINUE
      SMAX(IGRP,1)=TAUM
      SMAX(IGRP,2)=XFM
      IF(ISET(IGRP).EQ.8) THEN
        SMAX(IGRP,1)=HM
        SMAX(IGRP,2)=TAUM
      ENDIF
      SMAX(IGRP,3)=THM
      XMAX(IGRP)=1.05*DSIGMX
  120 CONTINUE
 
C...RESULTS FOR DIFFRACTIVE AND ELASTIC EVENTS
      DO 130 IGRP=8,10
      IF(ISUBPR(IGRP).EQ.1) THEN
        IPY(44)=IGRP
        B=PYVAR(37)
        C=PYVAR(38)
        IF(ISET(IGRP).LE.6) THEN
          B=0.5*B
          C=0.5*C
        ENDIF
        PYVAR(14)=PYVAR(3)**2
        PYVAR(15)=PYVAR(4)**2
        IS=1
        IF(PYVAR(14).LT.PYVAR(15)) IS=2
        IF(ISET(IGRP).LE.6) PYVAR(13+IS)=PYPAR(12)**2
        IF(ISET(IGRP).EQ.5) PYVAR(16-IS)=PYPAR(12)**2
        SH=PYVAR(2)
        CALL PYTHAT(THL,THU)
        THM=MIN(MAX(THL,PYPAR(28)),THU)
        SMAX(IGRP,1)=1.
        SMAX(IGRP,2)=0.
        SMAX(IGRP,3)=THU
        IF((B+C*(THM+THU))*(THM-THU).GT.0.) SMAX(IGRP,3)=THM
        XMAX(IGRP)=PYVAR(43+IGRP)
      ENDIF
  130 CONTINUE
 
C...PRINT SUMMARY TABLE
      IF(IPY(31).GE.1) WRITE(MST(20),1500)
      DO 140 IGRP=1,40
      IF(IGRP.LE.4.AND.IGRP.NE.IPY(50)) GOTO 140
      IF(IGRP.EQ.5.AND.IPY(12).LE.0.AND.IGRP.NE.IPY(50)) GOTO 140
      IF(IGRP.EQ.5.AND.IPY(49).EQ.0) GOTO 140
      IF(IGRP.EQ.6) GOTO 140
      IF(IGRP.GE.7.AND.ISUBPR(IGRP).EQ.0) GOTO 140
      IPROC=IGRP
      IF(IPROC.LE.5) IPROC=-IPROC
      IF(IPY(31).GE.1) WRITE(MST(20),1600) IGRP,PROC(IPROC),
     &(SMAX(IGRP,J),J=1,3),XMAX(IGRP)
      IF(IGRP.EQ.7.OR.(IGRP.EQ.5.AND.IGRP.NE.IPY(50))) GOTO 140
      XMAX(0)=XMAX(0)+XMAX(IGRP)
  140 CONTINUE
      IF(IPY(31).GE.1) WRITE(MST(20),1700)
 
C...FORMAT STATEMENTS FOR MAXIMIZATION RESULTS
 1000 FORMAT(/1X,8('*'),1X,'PYMAXI: SUMMARY OF DIFFERENTIAL ',
     &'CROSS-SECTION MAXIMUM SEARCH',1X,9('*'))
 1100 FORMAT(/1X,'SEARCH FOR MAXIMUM OF DIFFERENTIAL CROSS-SECTION ',
     &'(INCLUDING JACOBIAN):',6X,'NEW')
 1200 FORMAT(/1X,'IGRP',1X,'STEP',4X,'VTAU',4X,'VXF',5X,'VTH',8X,'TAU',
     &8X,'XF',9X,'TH',5X,'DSIGS',2X,'MAX'/)
 1300 FORMAT(/1X,'IGRP',1X,'STEP',4X,'VH',6X,'VTAU',4X,'VTH',8X,'H',
     &10X,'TAU',8X,'TH',5X,'DSIGS',2X,'MAX'/)
 1400 FORMAT(1X,I2,3X,2I2,3F8.3,1P,4E11.3,1X,A1)
 1500 FORMAT(/1X,79('=')/1X,'I',32X,'I',44X,'I'/1X,'I',11X,
     &'SUBPROCESS',11X,'I',14X,'POINT OF MAXIMUM',14X,'I'/1X,'I',32X,
     &'I',44X,'I'/1X,'I',32('-'),'I',44('-'),'I'/1X,'I',32X,'I',44X,
     &'I'/1X,'I',1X,'IGRP',1X,'TYPE',22X,'I',3X,'TAU (H)',4X,'XF (TAU)',
     &5X,'TH',8X,'XMAX',3X,'I'/1X,'I',32X,'I',44X,'I'/1X,79('=')/1X,'I',
     &32X,'I',44X,'I')
 1600 FORMAT(1X,'I',2X,I2,2X,A26,'I',1X,1P,E10.3,2E11.3,E10.3,1X,'I')
 1700 FORMAT(1X,'I',32X,'I',44X,'I'/1X,79('='))
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYINMU
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
 
      IF(IPY(31).GE.1) WRITE(MST(20),1000) IPY(12)
C...SAVE ORIGINAL VALUES, SET COMMON AND INITIAL VALUES
      IPY44S=IPY(44)
      IPY(44)=5
      IGRP=5
      PYVAR(14)=0.
      PYVAR(15)=0.
      PYVAR(35)=1.
      PYVAR(36)=1.
 
C...LOOP OVER PHASE SPACE POINTS: XT2 CHOICE IN 20 BINS
  100 SIGSUM=0.
      DO 120 IXT2=1,20
      NMUL(IXT2)=IPY(55)
      SIGMUL(IXT2)=0.
      DO 110 ITRY=1,IPY(55)
      RSCA=0.05*((21-IXT2)-RLU(0))
      XT2=PYVAR(13)*(1.+PYVAR(13))/(PYVAR(13)+RSCA)-PYVAR(13)
      XT2=MAX(0.01*PYVAR(13),XT2)
 
C...CHOOSE TAU AND XF (CF. SUBROUTINE PYRAND)
      RTAU=(1.+COEF(IGRP,1))*RLU(0)
      IF(RTAU.LE.1.) THEN
        TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
        TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
      ELSE
        TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
      ENDIF
      SH=TAU*PYVAR(2)
      RXF=(1.+COEF(IGRP,3))*RLU(0)
      IF(RXF.LE.1.) THEN
        XFP=TAU**RLU(0)
        XF=TAU/XFP-XFP
      ELSE
        XF=2.*SQRT(TAU)*TAN((2.*RLU(0)-1.)*ATAN((1.-TAU)/
     &  (2.*SQRT(TAU))))
      ENDIF
 
C...CALCULATE DERIVED QUANTITIES: TH, Q2, X
      CALL PYTHAT(THL,THU)
      XLS=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
      TH=MAX(THL,MIN(THU,-0.5*SH*(1.-XLS)))
      UH=MAX(THL,MIN(THU,-0.5*SH*(1.+XLS)))
      IF(XLS.GT.0.9999) TH=MIN(THU,-PYVAR(2)*XT2/4.)
      IF(XLS.LT.-0.9999) UH=MIN(THU,-PYVAR(2)*XT2/4.)
      QT2=PYVAR(2)*XT2/4.
      PYVAR(19)=QT2
      PYVAR(20)=MIN(1.,MAX(-1.,(TH-UH)/SH))
      IF(IPY(4).EQ.1) THEN
        Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
      ELSEIF(IPY(4).EQ.2) THEN
        Q2=QT2
      ELSEIF(IPY(4).EQ.3) THEN
        Q2=MIN(-TH,-UH)
      ENDIF
      IF(XF.GE.0) THEN
        X(1)=MIN(0.5*(SQRT(XF**2+4.*TAU)+XF),1.)
        X(2)=MIN(TAU/X(1),1.)
      ELSE
        X(2)=MIN(0.5*(SQRT(XF**2+4.*TAU)-XF),1.)
        X(1)=MIN(TAU/X(2),1.)
      ENDIF
 
C...CALCULATE DIFFERENTIAL CROSS SECTION
      CALL PYDSIG(TAU,XF,XT2,DSIGS)
  110 SIGMUL(IXT2)=SIGMUL(IXT2)+DSIGS
  120 SIGSUM=SIGSUM+SIGMUL(IXT2)
      SIGSUM=SIGSUM/(20.*IPY(55))
 
C...REJECT RESULT IF SIGMA(PARTON-PARTON) IS SMALLER THAN HADRONIC ONE
      IF(SIGSUM.LT.1.1*PYVAR(54)) THEN
        IF(IPY(31).GE.1) WRITE(MST(20),1100) PYPAR(32),SIGSUM
        PYPAR(32)=0.9*PYPAR(32)
        PYVAR(13)=4.*PYPAR(32)**2/PYVAR(2)
        GOTO 100
      ENDIF
      IF(IPY(31).GE.1) WRITE(MST(20),1200) PYPAR(32), SIGSUM
 
C...START ITERATION TO FIND K FACTOR
      YKE=SIGSUM/PYVAR(54)
      SO=0.5
      XI=0.
      YI=0.
      XK=0.5
      IIT=0
  130 IF(IIT.EQ.0) THEN
        XK=2.*XK
      ELSEIF(IIT.EQ.1) THEN
        XK=0.5*XK
      ELSE
        XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
      ENDIF
 
C...EVALUATE OVERLAP INTEGRALS
      IF(IPY(12).EQ.2) THEN
        SP=0.5*PAR(71)*(1.-EXP(-XK))
        SOP=SP/PAR(71)
      ELSE
        IF(IPY(12).EQ.3) DELTAB=0.02
        IF(IPY(12).EQ.4) DELTAB=MIN(0.01,0.05*PYPAR(34))
        SP=0.
        SOP=0.
        B=-0.5*DELTAB
  140   B=B+DELTAB
        IF(IPY(12).EQ.3) THEN
          OV=EXP(-B**2)/PAR(72)
        ELSE
          EXP1=EXP(-MIN(100.,B**2))
          EXP2=EXP(-MIN(100.,B**2*2./(1.+PYPAR(34)**2)))
          EXP3=EXP(-MIN(100.,(B/PYPAR(34))**2))
          OV=((1.-PYPAR(33))**2*EXP1+2.*PYPAR(33)*(1.-PYPAR(33))*EXP2*
     &    2./(1.+PYPAR(34)**2)+PYPAR(33)**2*EXP3/PYPAR(34)**2)/PAR(72)
        ENDIF
        PACC=1.-EXP(-PAR(71)*XK*OV)
        SP=SP+PAR(72)*B*DELTAB*PACC
        SOP=SOP+PAR(72)*B*DELTAB*OV*PACC
        IF(B.LT.1..OR.B*PACC.GT.1E-6) GOTO 140
      ENDIF
      YK=PAR(71)*XK*SO/SP
 
C...CONTINUE ITERATION UNTIL CONVERGENCE
      IF(YK.LT.YKE) THEN
        XI=XK
        YI=YK
        IF(IIT.EQ.1) IIT=2
      ELSE
        XF=XK
        YF=YK
        IF(IIT.EQ.0) IIT=1
      ENDIF
      IF(ABS(YK-YKE).GE.1E-5*YKE) GOTO 130
 
C...STORE SOME RESULTS FOR SUBSEQUENT USE
      PYVAR(27)=SIGSUM
      PYVAR(28)=SOP/SO
      PYVAR(29)=SOP/SP
      IPY(44)=IPY44S
 
C...FORMAT STATEMENTS FOR PRINTOUT
 1000 FORMAT(/1X,'******* PYINMU: INITIALIZATION OF MULTIPLE INTER',
     &'ACTIONS FOR IPY(12) =',I2,' *******')
 1100 FORMAT(8X,'PT0 =',F5.2,' GEV GIVES SIGMA(PARTON-PARTON) =',1P,
     &E9.2,' MB: REJECTED')
 1200 FORMAT(8X,'PT0 =',F5.2,' GEV GIVES SIGMA(PARTON-PARTON) =',1P,
     &E9.2,' MB: ACCEPTED')
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYRAND
 
C...GENERATES QUANTITIES CHARACTERIZING THE HIGH-PT SCATTERING AT THE
C...PARTON LEVEL ACCORDING TO THE MATRIX ELEMENTS. CHOOSES INCOMING,
C...REACTING PARTONS, THEIR MOMENTUM FRACTIONS AND ONE OF THE POSSIBLE
C...SUBPROCESSES.
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      COMMON/PYINT1/XQ(2,-6:6),DSIG(-6:6,-6:6,5),FSIG(10,10,3)
      COMMON/PYINT2/KPR(-6:6,-6:6),NMX(6),ICOL(40,4,2),ICH(30),VKM2(4,4)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
 
C...INITIAL VALUES, SPECIFICALLY FOR (FIRST) SEMIHARD INTERACTION
      IPY(51)=0
      IPY(52)=0
      PYVAR(35)=1.
      PYVAR(36)=1.
      IF(IPY(50).EQ.5.AND.IPY(12).LE.1) THEN
        XT2=1.
        XT2FAC=XMAX(5)/PYVAR(54)*PYVAR(13)/(1.-PYVAR(13))
      ELSEIF(IPY(50).EQ.5.AND.IPY(12).EQ.2) THEN
        XT2=1.
        XT2FAC=PYVAR(28)*XMAX(5)/PYVAR(54)*PYVAR(13)*(1.+PYVAR(13))
      ELSEIF(IPY(50).EQ.5) THEN
        XC2=4.*PYVAR(12)/PYVAR(2)
      ENDIF
 
C...CHOICE OF PROCESS TYPE
  100 NGEN(0,1)=NGEN(0,1)+1
      IGRP=0
      RGRP=XMAX(0)*RLU(0)
      IF(RGRP.LE.PYVAR(41)) THEN
C...HIGH-PT QCD PROCESSES:
        IGRP=IPY(50)
      ELSEIF(RGRP.LE.PYVAR(42)) THEN
C...DIFFRACTIVE AND ELASTIC SCATTERING:
        IGRP=8
        IF(RGRP.GT.PYVAR(41)+XMAX(8)) IGRP=9
        IF(RGRP.GE.PYVAR(42)-XMAX(10)) IGRP=10
      ELSEIF(RGRP.LE.PYVAR(43)) THEN
C...Z0/GAM*, W+/- AND H0, RESONANCE AND PAIR PRODUCTION:
        IGRP=10
        RGRP=RGRP-PYVAR(42)
  110   IGRP=IGRP+1
        RGRP=RGRP-XMAX(IGRP)
        IF(RGRP.GT.0..AND.IGRP.LT.30) GOTO 110
      ELSE
C...USER DEFINED PROCESSES:
        IGRP=30
        RGRP=RGRP-PYVAR(43)
  120   IGRP=IGRP+1
        RGRP=RGRP-XMAX(IGRP)
        IF(RGRP.GT.0..AND.IGRP.LT.40) GOTO 120
      ENDIF
      IF(IGRP.GE.7.AND.ISUBPR(IGRP).EQ.0) GOTO 100
      NGEN(IGRP,1)=NGEN(IGRP,1)+1
      IPY(44)=IGRP
 
      IF(ISET(IGRP).EQ.1) THEN
C...OPTIONALLY CHOOSE FINAL STATE PARTICLE MASSES ACCORDING TO
C...(TRUNCATED) BREIT-WIGNER
        DO 130 I=1,2
        SQM=WM(IGRP,I)**2
        IF(IPY(21).EQ.1.AND.WM(IGRP,I+2).GT.1.E-20) THEN
          GM=WM(IGRP,I+2)*WM(IGRP,I)
          AUPP=ATAN((PYVAR(2)-SQM)/GM)
          ALOW=-ATAN(SQM/GM)
          PYVAR(13+I)=SQM+GM*TAN(ALOW+(AUPP-ALOW)*RLU(0))
          PYVAR(13+I)=MIN(PYVAR(2),MAX(0.,PYVAR(13+I)))
        ELSE
          PYVAR(13+I)=SQM
        ENDIF
  130   CONTINUE
      ENDIF
 
      IF(ISET(IGRP).EQ.1) THEN
C...2 -> 2 PROCESSES:
C...CHOOSE TAU ACCORDING TO H1(TAU)/TAU, WHERE
C...H1(TAU)=1+(-LN(TAUMIN))*TAUMIN/(1-TAUMIN)*(COEF(IGRP,1)/TAU+
C...2.*TAUMIN/(1.+TAUMIN)*COEF(IGRP,2)/TAU**2);
C...PRE-WEIGHT WITH LN(TAU)/LN(TAUMIN)*(THU-THL)/SH
        SQM1=PYVAR(14)
        SQM2=PYVAR(15)
        TAUMIN=MIN(1.,MAX(SQRT(SQM1+PYVAR(12))+SQRT(SQM2+PYVAR(12)),
     &  PYPAR(20))**2/PYVAR(2))
        RTAU=(1.+COEF(IGRP,1)+COEF(IGRP,2))*RLU(0)
        IF(RTAU.LE.1.) THEN
          TAU=TAUMIN**RLU(0)
        ELSEIF(RTAU.LE.1.+COEF(IGRP,1)) THEN
          TAU=TAUMIN/(TAUMIN+(1.-TAUMIN)*RLU(0))
        ELSE
          TAU=TAUMIN/SQRT(TAUMIN**2+(1.-TAUMIN**2)*RLU(0))
        ENDIF
        TAU=MIN(1.,MAX(TAUMIN,TAU))
        SH=TAU*PYVAR(2)
        CALL PYTHAT(THL,THU)
        IF(THU-THL.LT.1.E-06) GOTO 100
        IF(ALOG(TAU)/ALOG(TAUMIN)*(THU-THL)/SH.LT.RLU(0)) GOTO 100
        PYVAR(16)=TAUMIN
C...CHOOSE XF ACCORDING TO H2(TAU,XF)/SQRT(XF**2+4*TAU), WHERE
C...H2(TAU,XF)=1.+(-LN(TAU))*SQRT(TAU)/ARCTAN((1-TAU)/(2*SQRT(TAU)))*
C...COEF(IGRP,3)/SQRT(XF**2+4*TAU)
        RXF=(1.+COEF(IGRP,3))*RLU(0)
        IF(RXF.LE.1.) THEN
          XFP=TAU**RLU(0)
          XF=TAU/XFP-XFP
        ELSE
          XF=2.*SQRT(TAU)*TAN((2.*RLU(0)-1.)*ATAN((1.-TAU)/
     &    (2.*SQRT(TAU))))
        ENDIF
C...CHOOSE TH ACCORDING TO H3(TAU,XF,TH), WHERE
C...H3(TAU,XF,TH)=1+(THU-THL)/LN(THU/THL)*(COEF(IGRP,5)/TH+COEF(IGRP,6)/UH)+
C...THU*THL*(COEF(IGRP,7)/TH**2+COEF(IGRP,8)/UH**2)
        RTH=(1.+COEF(IGRP,5)+COEF(IGRP,6)+COEF(IGRP,7)+COEF(IGRP,8))*
     &  RLU(0)
        IF(RTH.LE.1.) THEN
          TH=THL+(THU-THL)*RLU(0)
        ELSEIF(RTH.LE.1.+COEF(IGRP,5)) THEN
          TH=THL*(THU/THL)**RLU(0)
        ELSEIF(RTH.LE.1.+COEF(IGRP,5)+COEF(IGRP,6)) THEN
          TH=SQM1+SQM2-SH-THL*(THU/THL)**RLU(0)
        ELSEIF(RTH.LE.1.+COEF(IGRP,5)+COEF(IGRP,6)+COEF(IGRP,7)) THEN
          TH=THU*THL/(THL+(THU-THL)*RLU(0))
        ELSE
          TH=SQM1+SQM2-SH-THU*THL/(THL+(THU-THL)*RLU(0))
        ENDIF
        TH=MAX(THL,MIN(THU,TH))
        UH=MAX(THL,MIN(THU,SQM1+SQM2-SH-TH))
        QT2=MAX(PYVAR(12),(TH*UH-SQM1*SQM2)/SH)
        SQLAM=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2
        PYVAR(20)=MIN(1.,MAX(-1.,(TH-UH)/SQRT(SQLAM)))
        IF(IPY(4).EQ.1) THEN
          Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
        ELSEIF(IPY(4).EQ.2) THEN
          Q2=QT2+0.5*(SQM1+SQM2)
        ELSEIF(IPY(4).EQ.3) THEN
          Q2=MIN(-TH,-UH)
        ENDIF
 
      ELSEIF(ISET(IGRP).EQ.2.OR.ISET(IGRP).EQ.3) THEN
C...RESONANCE PRODUCTION:
C...CHOOSE TAU ACCORDING TO H1(TAU), WHERE
C...H1(TAU)=COEF(IGRP,1)/N1*M**2/S*1/(TAU*(M**2/S+TAU))+
C...COEF(IGRP,2)/N2*1/TAU**2+COEF(IGRP,3)/N3*
C...(M*GAM)**2/((S*TAU-M**2)**2+(M*GAM)**2)+
C...COEF(IGRP,5)/N5*MP**2/S*1/(TAU*(MP**2/S+TAU))+
C...COEF(IGRP,6)/N6*(MP*GAMP)**2/((S*TAU-MP**2)**2+(MP*GAMP)**2)
C...WITH
C...N1=ALOG((M**2/S+TAUMIN)/((M**2/S+1)*TAUMIN));
C...N2=(1-TAUMIN)/TAUMIN;
C...N3=M*GAM/S*(ATAN((S-M**2)/(M*GAM))-ATAN((S*TAU-M**2)/(M*GAM)))
C...N5=ALOG((MP**2/S+TAUMIN)/((MP**2/S+1)*TAUMIN)); AND
C...N6=MP*GAMP/S*(ATAN((S-MP**2)/(MP*GAMP))-ATAN((S*TAU-MP**2)/
C...(MP*GAMP)));
C...PRE-WEIGHT WITH LN(TAU)/LN(TAUMIN)
        TAUMIN=MIN(1.,MAX(4.*PYVAR(12),PYPAR(20)**2)/PYVAR(2))
        SQM=WM(IGRP,1)**2
        GM=WM(IGRP,1)*WM(IGRP,3)
        SQMP=WM(IGRP,2)**2
        GMP=WM(IGRP,2)*WM(IGRP,4)
        RTAU=(COEF(IGRP,1)+COEF(IGRP,2)+COEF(IGRP,3)+COEF(IGRP,5)+
     &  COEF(IGRP,6))*RLU(0)
        IF(RTAU.LE.COEF(IGRP,1)) THEN
          TAUR=SQM/PYVAR(2)
          TAU=TAUR/
     &    ((TAUR+1.)*((TAUR+TAUMIN)/(TAUMIN*(TAUR+1.)))**RLU(0)-1.)
        ELSEIF(RTAU.LE.COEF(IGRP,1)+COEF(IGRP,2)) THEN
          TAU=TAUMIN/(TAUMIN+(1.-TAUMIN)*RLU(0))
        ELSEIF(RTAU.LE.COEF(IGRP,1)+COEF(IGRP,2)+COEF(IGRP,3)) THEN
          AUPP=ATAN((PYVAR(2)-SQM)/GM)
          ALOW=ATAN((PYVAR(2)*TAUMIN-SQM)/GM)
          TAU=(SQM+GM*TAN(ALOW+(AUPP-ALOW)*RLU(0)))/PYVAR(2)
        ELSEIF(RTAU.LE.COEF(IGRP,1)+COEF(IGRP,2)+COEF(IGRP,3)+
     &  COEF(IGRP,5)) THEN
          TAURP=SQMP/PYVAR(2)
          TAU=TAURP/
     &    ((TAURP+1.)*((TAURP+TAUMIN)/(TAUMIN*(TAURP+1.)))**RLU(0)-1.)
        ELSE
          AUPP=ATAN((PYVAR(2)-SQMP)/GMP)
          ALOW=ATAN((PYVAR(2)*TAUMIN-SQMP)/GMP)
          TAU=(SQMP+GMP*TAN(ALOW+(AUPP-ALOW)*RLU(0)))/PYVAR(2)
        ENDIF
        TAU=MIN(1.,MAX(TAUMIN,TAU))
        IF(ALOG(TAU)/ALOG(TAUMIN).LT.RLU(0)) GOTO 100
        SH=TAU*PYVAR(2)
        PYVAR(16)=TAUMIN
C...CHOOSE XF ACCORDING TO 1/SQRT(XF**2+4*TAU)
        XFP=TAU**RLU(0)
        XF=TAU/XFP-XFP
C...CHOOSE COS(THE) (GIVES TH) FLAT (SPIN 0 RESONANCES) OR ACCORDING
C...TO 1+COS(THE)**2 (SPIN 1 RESONANCES)
        CALL PYTHAT(THL,THU)
        CTHMIN=MAX(-1.,MIN(1.,1.+2.*THL/SH))
        CTHMAX=MIN(1.,MAX(-1.,1.+2.*THU/SH))
  140   CTHE=CTHMIN+(CTHMAX-CTHMIN)*RLU(0)
        IF(ISET(IGRP).EQ.3.AND.1.+CTHE**2.LT.2.*RLU(0)) GOTO 140
        PYVAR(20)=MIN(1.,MAX(-1.,CTHE))
        TH=MAX(THL,MIN(THU,-0.5*SH*(1.-PYVAR(20))))
        UH=MAX(THL,MIN(THU,-SH-TH))
        QT2=MAX(PYVAR(12),TH*UH/SH)
        Q2=SH
 
      ELSEIF(ISET(IGRP).EQ.4) THEN
C...LOW-PT OR MULTIPLE INTERACTIONS (FIRST SEMIHARD INTERACTION):
C...CHOOSE XT2 ACCORDING TO DPT2/PT2**2*EXP(-(SIGMA ABOVE PT2)/NORM)
C...OR (IPY(12)>=2) DPT2/(PT2+PYVAR(13))**2
        PYVAR(14)=0.
        PYVAR(15)=0.
        IF(IPY(12).LE.1) THEN
          XT2=XT2FAC*XT2/(XT2FAC-XT2*ALOG(RLU(0)))
          IF(IPY(12).LE.-1) XT2=0.
        ELSEIF(IPY(12).EQ.2) THEN
          IF(XT2.LT.1..AND.EXP(-XT2FAC*XT2/(PYVAR(13)*(XT2+
     &    PYVAR(13)))).GT.RLU(0)) XT2=1.
          IF(XT2.GE.1.) THEN
            XT2=(1.+PYVAR(13))*XT2FAC/(XT2FAC-(1.+PYVAR(13))*ALOG(1.-
     &      RLU(0)*(1.-EXP(-XT2FAC/(PYVAR(13)*(1.+PYVAR(13)))))))-
     &      PYVAR(13)
          ELSE
            XT2=-XT2FAC/ALOG(EXP(-XT2FAC/(XT2+PYVAR(13)))+RLU(0)*
     &      (EXP(-XT2FAC/PYVAR(13))-EXP(-XT2FAC/(XT2+PYVAR(13)))))-
     &      PYVAR(13)
          ENDIF
          XT2=MAX(0.01*PYVAR(13),XT2)
        ELSE
          XT2=(XC2+PYVAR(13))*(1.+PYVAR(13))/(1.+PYVAR(13)-
     &    RLU(0)*(1.-XC2))-PYVAR(13)
          XT2=MAX(0.01*PYVAR(13),XT2)
        ENDIF
 
        IF(IPY(12).LE.1.AND.XT2.LT.PYVAR(13)) THEN
C...LOW-PT:
C...CHOOSE XT2, TAU, XF AND TH FIXED
          NGEN(0,1)=NGEN(0,1)-1
          NGEN(IGRP,1)=NGEN(IGRP,1)-1
          IGRP=7
          IPY(44)=7
          XT2=PYVAR(13)
          TAU=PYVAR(13)
          SH=TAU*PYVAR(2)
          XF=0.
          TH=-0.5*SH
          UH=-0.5*SH
        ELSE
C...MULTIPLE INTERACTIONS (FIRST SEMIHARD INTERACTION):
C...CHOOSE TAU ACCORDING TO H1(XT2,TAU)/SQRT(TAU*(TAU-XT2)), WHERE
C...H1(XT2,TAU)=1+LN(2*(1+SQRT(1-XT2))/XT2-1)/(2*ATAN(1/XT2-1))*SQRT(XT2)*
C...COEF(IGRP,1)/SQRT(TAU)
          RTAU=(1.+COEF(IGRP,1))*RLU(0)
          IF(RTAU.LE.1.) THEN
            TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
            TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
          ELSE
            TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
          ENDIF
          SH=TAU*PYVAR(2)
C...CHOOSE XF ACCORDING TO H2(TAU,XF)/SQRT(XF**2+4*TAU), WHERE
C...H2(TAU,XF)=1+(-LN(TAU))*SQRT(TAU)/ARCTAN((1-TAU)/(2*SQRT(TAU)))*
C...COEF(IGRP,3)/SQRT(XF**2+4*TAU)
          RXF=(1.+COEF(IGRP,3))*RLU(0)
          IF(RXF.LE.1.) THEN
            XFP=TAU**RLU(0)
            XF=TAU/XFP-XFP
          ELSE
            XF=2.*SQRT(TAU)*TAN((2.*RLU(0)-1.)*ATAN((1.-TAU)/
     &      (2.*SQRT(TAU))))
          ENDIF
C...CALCULATE TH FROM XT2 AND TAU
          CALL PYTHAT(THL,THU)
          XLS=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
          TH=MAX(THL,MIN(THU,-0.5*SH*(1.-XLS)))
          UH=MAX(THL,MIN(THU,-0.5*SH*(1.+XLS)))
          IF(XLS.GT.0.9999) TH=MIN(THU,-PYVAR(2)*XT2/4.)
          IF(XLS.LT.-0.9999) UH=MIN(THU,-PYVAR(2)*XT2/4.)
        ENDIF
        IF(IPY(12).LE.1) QT2=MAX(PYPAR(32)**2,TH*UH/SH)
        IF(IPY(12).GE.2) QT2=MAX(0.,PYVAR(2)*XT2/4.)
        PYVAR(20)=MIN(1.,MAX(-1.,(TH-UH)/SH))
        IF(IPY(4).EQ.1) THEN
          Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
        ELSEIF(IPY(4).EQ.2) THEN
          Q2=QT2
        ELSEIF(IPY(4).EQ.3) THEN
          Q2=MIN(-TH,-UH)
        ENDIF
 
      ELSEIF(ISET(IGRP).GE.5.AND.ISET(IGRP).LE.7) THEN
C...DOUBLE OR SINGLE DIFFRACTIVE, OR ELASTIC SCATTERING:
C...CHOOSE SQM ACCORDING TO 1/SQM (DIFFRACTIVE), CONSTANT (ELASTIC)
        IS=INT(1.5+RLU(0))
        PYVAR(14)=PYVAR(3)**2
        PYVAR(15)=PYVAR(4)**2
        IF(ISET(IGRP).LE.6) PYVAR(13+IS)=PYPAR(12)**2
        IF(ISET(IGRP).EQ.5) PYVAR(16-IS)=PYPAR(12)**2
        SH=PYVAR(2)
        CALL PYTHAT(THL,THU)
        THM=MIN(MAX(THL,PYPAR(28)),THU)
        IF(ISET(IGRP).LE.6) THEN
          IPY(50+IS)=1
          SQMMIN=PYVAR(13+IS)
          SQMI=PYVAR(5-IS)**2
          SQMJ=PYVAR(2+IS)**2
          SQMF=PYVAR(16-IS)
          SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-
     &    SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)
          QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+
     &    SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))
          SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))
          IF(ABS(QUAR/SQUA**2).LT.1.E-05) SQMMAX=0.5*QUAR/SQUA
          SQMMAX=MIN(SQMMAX,(PYVAR(1)-SQRT(SQMF))**2)
          PYVAR(13+IS)=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)
        ENDIF
        IF(ISET(IGRP).EQ.5) THEN
          IPY(53-IS)=1
          SQMMIN=PYVAR(16-IS)
          SQMI=PYVAR(2+IS)**2
          SQMJ=PYVAR(5-IS)**2
          SQMF=PYVAR(13+IS)
          SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-
     &    SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)
          QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+
     &    SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))
          SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))
          IF(ABS(QUAR/SQUA**2).LT.1.E-05) SQMMAX=0.5*QUAR/SQUA
          SQMMAX=MIN(SQMMAX,(PYVAR(1)-SQRT(SQMF))**2)
          PYVAR(16-IS)=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)
        ENDIF
C...CHOOSE TH ACCORDING TO EXP(B*TH+C*TH**2)
        CALL PYTHAT(THL,THU)
        B=PYVAR(37)
        C=PYVAR(38)
        IF(ISET(IGRP).LE.6) THEN
          B=0.5*B
          C=0.5*C
        ENDIF
        THM=MIN(MAX(THL,PYPAR(28)),THU)
        EXPTH=0.
        THARG=B*(THM-THU)
        IF(THARG.GT.-20.) EXPTH=EXP(THARG)
  150   TH=THU+ALOG(EXPTH+(1.-EXPTH)*RLU(0))/B
        TH=MAX(THM,MIN(THU,TH))
        RATLOG=MIN((B+C*(TH+THM))*(TH-THM),(B+C*(TH+THU))*(TH-THU))
        IF(RATLOG.LT.ALOG(RLU(0))) GOTO 150
        TAU=1.
        XF=0.
        QT2=0.
        SQM1=PYVAR(3)**2
        SQM2=PYVAR(4)**2
        SQM3=PYVAR(14)
        SQM4=PYVAR(15)
        UH=SQM1+SQM2+SQM3+SQM4-SH-TH
        SQL12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2
        SQL34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
        CTHE=(SH*(TH-UH)+(SQM1-SQM2)*(SQM3-SQM4))/SQRT(SQL12*SQL34)
        PYVAR(20)=MIN(1.,MAX(-1.,CTHE))
 
      ELSEIF(ISET(IGRP).EQ.8) THEN
C...HIGGS PRODUCTION FROM INTERMEDIATE VECTOR BOSON FUSION:
C...CHOOSE H ( = MH**2/S) ACCORDING TO H1(H), WHERE
C...H1(H)=COEF(IGRP,1)/N1*1/(H*(H+HM))+COEF(IGRP,2)/N2*1/H+
C...COEF(IGRP,3)/N3*1/((H-HM)**2+HG**2)
C...WITH
C...N1=LN((1+HM/HMIN)/(1+HM))/HM;
C...N2=-LN(HMIN); AND
C...N3=(ATAN((1-HM)/HG)-ATAN((HMIN-HM)/HG))/HG
        HM=WM(IGRP,1)**2/PYVAR(2)
        HG=WM(IGRP,1)*WM(IGRP,3)/PYVAR(2)
        HMIN=MIN(1.,MAX(4.*PYVAR(12),PYPAR(20)**2)/PYVAR(2))
        RH=(COEF(IGRP,1)+COEF(IGRP,2)+COEF(IGRP,3))*RLU(0)
        IF(RH.LT.COEF(IGRP,1)) THEN
          H=HM/((1.+HM)*((1.+HM/HMIN)/(1.+HM))**RLU(0)-1.)
        ELSEIF(RH.LT.COEF(IGRP,1)+COEF(IGRP,2)) THEN
          H=HMIN**RLU(0)
        ELSE
          AUPP=ATAN((1.-HM)/HG)
          ALOW=ATAN((HMIN-HM)/HG)
          H=HM+HG*TAN(ALOW+(AUPP-ALOW)*RLU(0))
        ENDIF
        H=MIN(1.,MAX(HMIN,H))
        PYVAR(25)=H
        PYVAR(26)=HMIN
C...CHOOSE TAU ACCORDING TO H1(H,TAU)/TAU, WHERE
C...H1(H,TAU)=COEF(IGRP,5)+(-ALOG(H))*4*H/(1-H)**4*COEF(IGRP,6)*
C...(1-H/TAU)**3/TAU
        TAUMIN=MIN(1.,H+4./PYVAR(2))
        RTAU=(COEF(IGRP,5)+COEF(IGRP,6))*RLU(0)
        IF(RTAU.LT.COEF(IGRP,5)) THEN
          TAU=H**RLU(0)
        ELSE
          TAU=H/(1-(1-H)*RLU(0)**0.25)
        ENDIF
        TAU=MIN(1.,MAX(H,TAU))
        SH=TAU*PYVAR(2)
        PYVAR(16)=TAUMIN
C...CHOOSE XF ACCORDING TO 1/SQRT(XF**2+4*TAU)
        XFP=TAU**RLU(0)
        XF=TAU/XFP-XFP
C...CHOOSE COS(THE) (GIVES TH) FLAT
        CALL PYTHAT(THL,THU)
        CTHMIN=MAX(-1.,MIN(1.,1.+2.*THL/SH))
        CTHMAX=MIN(1.,MAX(-1.,1.+2.*THU/SH))
        CTHE=CTHMIN+(CTHMAX-CTHMIN)*RLU(0)
        PYVAR(20)=MIN(1.,MAX(-1.,CTHE))
        TH=MAX(THL,MIN(THU,-0.5*SH*(1.-PYVAR(20))))
        UH=MAX(THL,MIN(THU,-SH-TH))
        QT2=MAX(PYVAR(12),TH*UH/SH)
C...Q2 SCALE GIVEN BY INTERMEDIATE VECTOR BOSON MASS
        Q2=PMAS(2)**2
        IF(IGRP.EQ.28) Q2=PMAS(3)**2
      ENDIF
 
C...CALCULATE PARTON MOMENTUM FRACTIONS FOR BEAM AND TARGET, RESPECTIVELY
      IF(XF.GE.0) THEN
        X(1)=MIN(0.5*(SQRT(XF**2+4.*TAU)+XF),1.)
        X(2)=MIN(TAU/X(1),1.)
      ELSE
        X(2)=MIN(0.5*(SQRT(XF**2+4.*TAU)-XF),1.)
        X(1)=MIN(TAU/X(2),1.)
      ENDIF
      PYVAR(19)=QT2
      IF(ISET(IGRP).NE.4) XT2=4.*QT2/PYVAR(2)
 
C...CHECK AGAINST USER CUTS ON KINEMATICS AT PARTON LEVEL
      ICUT=0
      IF(ISUBPR(7)+ISUBPR(8)+ISUBPR(9)+ISUBPR(10).EQ.0)
     &CALL PYKCUT(X(1),X(2),SH,TH,SQRT(QT2),Q2,ICUT)
      IF(ICUT.NE.0) GOTO 100
 
C...CALCULATE DIFFERENTIAL CROSS-SECTION FOR DIFFERENT SUBPROCESSES
      PYVAR(21)=1.
      IF(IGRP.GE.2.AND.IGRP.LE.4) PYVAR(21)=(PYVAR(12)/QT2)**IPY(2)
      CALL PYDSIG(TAU,XF,XT2,DSIGS)
      IF(ISET(IGRP).EQ.8) Q2=PYVAR(25)*PYVAR(2)
 
C...CALCULATIONS FOR MONTE CARLO ESTIMATE OF ALL CROSS-SECTIONS
      IF(IGRP.LE.5) THEN
        DO 170 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 170
        XPRI(1)=XPRI(1)+DSIG(I,I,2)
        XPRI(2)=XPRI(2)+DSIG(I,-I,2)
        XPRI(3)=XPRI(3)+DSIG(I,-I,3)+DSIG(I,-I,4)
        XPRI(4)=XPRI(4)+DSIG(I,0,1)+DSIG(I,0,2)+DSIG(0,I,1)+
     &  DSIG(0,I,2)
        DO 160 J=-IPY(8),IPY(8)
        IF(J.EQ.0) GOTO 160
        XPRI(1)=XPRI(1)+DSIG(I,J,1)
  160   CONTINUE
  170   CONTINUE
        XPRI(5)=XPRI(5)+DSIG(0,0,1)+DSIG(0,0,2)
        XPRI(6)=XPRI(6)+DSIG(0,0,3)+DSIG(0,0,4)+DSIG(0,0,5)
      ELSEIF(IGRP.LE.10) THEN
        XPRI(IGRP)=XPRI(IGRP)+XMAX(IGRP)
      ELSE
        XPRI(IGRP)=XPRI(IGRP)+DSIGS
      ENDIF
 
C...MULTIPLE INTERACTIONS: STORE RESULTS OF CROSS-SECTION CALCULATION
      IF(IPY(12).GE.3) THEN
        XTS=XT2
        IF(ISET(IGRP).EQ.1) XTS=XT2+2.*(SQM1+SQM2)/PYVAR(2)
        IF(ISET(IGRP).EQ.2.OR.ISET(IGRP).EQ.3) XTS=TAU
        IF(ISET(IGRP).EQ.8) XTS=H
        RBIN=MAX(0.000001,MIN(0.999999,XTS*(1.+PYVAR(13))/
     &  (XTS+PYVAR(13))))
        IRBIN=INT(1.+20.*RBIN)
        IF(IGRP.EQ.5) NMUL(IRBIN)=NMUL(IRBIN)+1
        IF(IGRP.EQ.5) SIGMUL(IRBIN)=SIGMUL(IRBIN)+DSIGS
      ENDIF
 
C...WEIGHTING USING ESTIMATE OF MAXIMUM OF DIFFERENTIAL CROSS-SECTION
      VIOL=0.
      IF(IGRP.LE.5.OR.IGRP.GE.11) THEN
        VIOL=DSIGS/(XMAX(IGRP)*PYVAR(21))
        IF(VIOL.LT.RLU(0)) GOTO 100
      ENDIF
 
C...MULTIPLE INTERACTIONS: CHOOSE IMPACT PARAMETER
      PYVAR(30)=1.
      IF((IGRP.LE.5.OR.IGRP.GE.11).AND.IPY(12).GE.3) THEN
        IF(IPY(12).EQ.3) THEN
          PYVAR(30)=RLU(0)/(PAR(72)*PYVAR(29))
        ELSE
          RTYPE=RLU(0)
          CQ2=PYPAR(34)**2
          IF(RTYPE.LT.(1.-PYPAR(33))**2) THEN
            B2=-ALOG(RLU(0))
          ELSEIF(RTYPE.LT.1.-PYPAR(33)**2) THEN
            B2=-0.5*(1.+CQ2)*ALOG(RLU(0))
          ELSE
            B2=-CQ2*ALOG(RLU(0))
          ENDIF
          PYVAR(30)=((1.-PYPAR(33))**2*EXP(-B2)+2.*PYPAR(33)*
     &    (1.-PYPAR(33))*2./(1.+CQ2)*EXP(-B2*2./(1.+CQ2))+
     &    PYPAR(33)**2/CQ2*EXP(-B2/CQ2))/(PAR(72)*PYVAR(29))
        ENDIF
 
C...MULTIPLE INTERACTIONS (VARIABLE IMPACT PARAMETER) : REJECT WITH
C...PROBABILITY EXP(-OVERLAP*CROSS-SECTION ABOVE PT/NORMALIZATION)
        RNCOR=(IRBIN-20.*RBIN)*NMUL(IRBIN)
        SIGCOR=(IRBIN-20.*RBIN)*SIGMUL(IRBIN)
        DO 180 IBIN=IRBIN+1,20
        RNCOR=RNCOR+NMUL(IBIN)
  180   SIGCOR=SIGCOR+SIGMUL(IBIN)
        SIGABV=(SIGCOR/RNCOR)*PYVAR(13)*(1.-XTS)/(XTS+PYVAR(13))
        PKEEP=EXP(-PYVAR(28)*PYVAR(30)*SIGABV/PYVAR(54))
        IF(PKEEP.LT.RLU(0)) GOTO 100
      ENDIF
      IF(IGRP.LE.5.OR.IGRP.GE.11) IPY(45)=IPY(45)+1
 
C...CHECK FOR POSSIBLE VIOLATION OF ESTIMATED MAXIMUM OF DIFFERENTIAL
C...CROSS-SECTION USED IN WEIGHTING
      IF(IPY(32).EQ.0) THEN
        IF(VIOL.GT.1.) THEN
          WRITE(MST(20),1000) VIOL,NGEN(0,3)+1
          WRITE(MST(20),1100) IGRP,X(1),X(2),TH
          STOP
        ENDIF
      ELSEIF(IPY(32).EQ.1) THEN
        IF(VIOL.GT.VMAX) THEN
          IF(VIOL.GT.1.) THEN
            WRITE(MST(20),1200) VIOL,NGEN(0,3)+1
            WRITE(MST(20),1100) IGRP,X(1),X(2),TH
          ENDIF
          VMAX=VIOL
        ENDIF
      ELSEIF(VIOL.GT.VMAX) THEN
        VMAX=VIOL
        IF(VMAX.GT.1.) THEN
          XDIF=XMAX(IGRP)*(VMAX-1.)
          XMAX(IGRP)=XMAX(IGRP)*VMAX
          XMAX(0)=XMAX(0)+XDIF
          IF(IGRP.LE.6) PYVAR(41)=PYVAR(41)+XDIF
          IF(IGRP.LE.10) PYVAR(42)=PYVAR(42)+XDIF
          IF(IGRP.LE.30) PYVAR(43)=PYVAR(43)+XDIF
          WRITE(MST(20),1200) VMAX,NGEN(0,3)+1
          WRITE(MST(20),1100) IGRP,X(1),X(2),TH
          IF(IGRP.LE.9) WRITE(MST(20),1300) IGRP,XMAX(IGRP)
          IF(IGRP.GE.10) WRITE(MST(20),1400) IGRP,XMAX(IGRP)
          VMAX=1.
        ENDIF
      ENDIF
 
C...CHOOSE FLAVOUR OF REACTING PARTONS (AND SUBPROCESS)
      RDSIG=DSIGS*RLU(0)
      RQQBAR=1.-(QT2/(QT2+PYPAR(32)**2))**2
      IF(IGRP.EQ.5.AND.IPY(12).GE.2.AND.RLU(0).LT.RQQBAR) THEN
C...MULTIPLE INTERACTIONS: CHOOSE QQBAR PREFERENTIALLY AT SMALL PT
        CALL PYSPLI(IPY(41),500,IFL1,IFLDUM)
        CALL PYSPLI(IPY(42),500,IFL2,IFLDUM)
        IFL1=MOD(IFL1,500)
        IFL2=MOD(IFL2,500)
        IPY(43)=1
        IF(IFL1.EQ.IFL2.AND.RLU(0).LT.0.5) IPY(43)=2
      ELSEIF(IGRP.LE.5) THEN
C...QCD: FLAVOUR AND SUBPROCESS
        DO 190 I=-IPY(8),IPY(8)
        IFL1=I
        DO 190 J=-IPY(8),IPY(8)
        IFL2=J
        DO 190 L=1,NMX(KPR(I,J))
        IPY(43)=L
        RDSIG=RDSIG-DSIG(I,J,L)
        IF(RDSIG.LE.0.) GOTO 210
  190   CONTINUE
      ELSEIF(IGRP.GE.11) THEN
C...OTHER HIGH-PT PROCESSES: FLAVOUR
        IPY(43)=1
        DO 200 I=-IPY(8),IPY(8)
        IFL1=I
        DO 200 J=-IPY(8),IPY(8)
        IFL2=J
        RDSIG=RDSIG-DSIG(I,J,1)
        IF(RDSIG.LE.0.) GOTO 210
  200   CONTINUE
C...LOW-PT: CHOOSE STRING DRAWING CONFIGURATION
      ELSEIF(IGRP.EQ.7) THEN
        IFL1=0
        IFL2=0
        RSIGS=(DSIG(0,0,3)+DSIG(0,0,4)+DSIG(0,0,5))*RLU(0)
        IPY(43)=3
        IF(RSIGS.GT.DSIG(0,0,3)) IPY(43)=4
        IF(RSIGS.GT.DSIG(0,0,3)+DSIG(0,0,4)) IPY(43)=5
      ENDIF
  210 KFL(2,1)=ISIGN(500+IABS(IFL1),2*IFL1+1)
      KFL(2,2)=ISIGN(500+IABS(IFL2),2*IFL2+1)
      KFL(1,1)=KFL(2,1)
      KFL(1,2)=KFL(2,2)
      PYVAR(31)=X(1)
      PYVAR(32)=X(2)
 
      IF(IGRP.EQ.11) THEN
C...CALCULATE FLAVOUR SUPPRESSION FOR Z0/GAM* PRODUCTION
        XW=PYPAR(2)
        EI=ICH(IABS(IFL1))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        SQMZ=WM(11,1)**2
        GZMZ=WM(11,1)*WM(11,3)
        DSGG=EI**2
        DSZZ=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SH**2/
     &  ((SH-SQMZ)**2+GZMZ**2)
        DSZG=VI*EI/(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
        IF(IPY(11).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
          DSZZ=0.
          DSZG=0.
        ELSEIF(IPY(11).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED:
          DSGG=0.
          DSZG=0.
        ENDIF
        FSIGS=0.
        RADC=1.+PYVAR(23)/PAR(71)
        DO 220 I=1,2*IPY(9)
        IF(IPROD(2,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SH) THEN
          RMQ=PMAS(100+I)**2/SH
          EF=ICH(I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          FSIG(I,I,1)=3.*((DSGG*EF**2+DSZZ*VF**2+DSZG*EF*VF)*
     &    (1.+2.*RMQ)+DSZZ*AF**2*(1.-4.*RMQ))*SQRT(MAX(0.,1.-4.*RMQ))*
     &    RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
        IF(IPROD(2,10+I).EQ.1.AND.4.*PMAS(6+I)**2.LT.SH) THEN
          RML=PMAS(6+I)**2/SH
          EF=ICH(10+I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          FSIG(I,I,2)=((DSGG*EF**2+DSZZ*VF**2+DSZG*EF*VF)*(1.+2.*RML)+
     &    DSZZ*AF**2*(1.-4.*RML))*SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(I,I,2)
        ENDIF
  220   CONTINUE
        IF(IPROD(2,23).EQ.1.AND.4.*PMAS(92)**2.LT.SH) THEN
          RMB=PMAS(92)**2/SH
          CF=2.*(1.-2.*XW)
          FSIG(3,3,3)=0.25*(DSGG+DSZZ*CF**2+DSZG*CF)*(1.-4.*RMB)*
     &    SQRT(MAX(0.,1.-4.*RMB))*PYVAR(66)**2
          FSIGS=FSIGS+FSIG(I,I,3)
        ENDIF
        PYVAR(45)=FSIGS
      ENDIF
 
      IF(IGRP.EQ.33) THEN
C...CALCULATE FLAVOUR SUPPRESSION FOR Z'0/Z0/GAM* PRODUCTION
        XW=PYPAR(2)
        EI=ICH(IABS(IFL1))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        API=SIGN(1.,EI)
        VPI=API-4.*EI*XW
        SQMZ=WM(33,1)**2
        GZMZ=WM(33,1)*WM(33,3)
        SQMZP=WM(33,2)**2
        GZMZP=WM(33,2)*WM(33,4)
        DSGG=EI**2
        DSZZ=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*
     &  SH**2/((SH-SQMZ)**2+GZMZ**2)
        DSZPZP=(VPI**2+API**2)/(16.*XW*(1.-XW))**2*
     &  SH**2/((SH-SQMZP)**2+GZMZP**2)
        DSZG=VI*EI/(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
        DSZPG=VPI*EI/(8.*XW*(1.-XW))*SH*(SH-SQMZP)/
     &  ((SH-SQMZP)**2+GZMZP**2)
        DSZPZ=2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*
     &  SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/
     &  (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))
        IF(IPY(39).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
          DSZZ=0.
          DSZPZP=0.
          DSZG=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED:
          DSGG=0.
          DSZPZP=0.
          DSZG=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.3) THEN
C...ONLY Z'0 PRODUCTION INCLUDED:
          DSGG=0.
          DSZZ=0.
          DSZG=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.4) THEN
C...ONLY Z0/GAM* PRODUCTION INCLUDED:
          DSZPZP=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.5) THEN
C...ONLY Z'0/GAM* PRODUCTION INCLUDED:
          DSZZ=0.
          DSZG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.6) THEN
C...ONLY Z'0/Z0 PRODUCTION INCLUDED:
          DSGG=0.
          DSZG=0.
          DSZPG=0.
        ENDIF
        FSIGS=0.
        RADC=1.+PYVAR(23)/PAR(71)
        DO 230 I=1,2*IPY(9)
        IF(IPROD(7,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SH) THEN
          RMQ=PMAS(100+I)**2/SH
          EF=ICH(I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          APF=SIGN(1.,EF+0.1)
          VPF=APF-4.*EF*XW
          FSIG(I,I,1)=3.*((DSGG*EF**2+DSZZ*VF**2+DSZPZP*VPF**2+
     &    DSZG*EF*VF+DSZPG*EF*VPF+DSZPZ*(VF*VPF+AF*APF))*(1.+2.*RMQ)+
     &    (DSZZ*AF**2+DSZPZP*APF**2)*(1.-4.*RMQ))*
     &    SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
        IF(IPROD(7,10+I).EQ.1.AND.4.*PMAS(6+I)**2.LT.SH) THEN
          RML=PMAS(6+I)**2/SH
          EF=ICH(10+I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          APF=SIGN(1.,EF+0.1)
          VPF=APF-4.*EF*XW
          FSIG(I,I,2)=((DSGG*EF**2+DSZZ*VF**2+DSZPZP*VPF**2+
     &    DSZG*EF*VF+DSZPG*EF*VPF+DSZPZ*(VF*VPF+AF*APF))*(1.+2.*RML)+
     &    (DSZZ*AF**2+DSZPZP*APF**2)*(1.-4.*RML))*
     &    SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(I,I,2)
        ENDIF
  230   CONTINUE
        PYVAR(45)=FSIGS
      ENDIF
 
C...FORMAT STATEMENTS FOR DIFFERENTIAL CROSS-SECTION MAXIMUM VIOLATIONS
 1000 FORMAT(1X,'ERROR: MAXIMUM VIOLATED BY A FACTOR',1X,F7.3,1X,
     &'IN EVENT',1X,I7,'. EXECUTION STOPPED.')
 1100 FORMAT(1X,'IGRP =',1X,I2,'; POINT OF VIOLATION: X1 =',F8.5,
     &', X2 =',F8.5,', TH =',1X,1P,E11.3)
 1200 FORMAT(1X,'WARNING: MAXIMUM VIOLATED BY A FACTOR',1X,F7.3,1X,
     &'IN EVENT',1X,I7)
 1300 FORMAT(1X,'XMAX(',I1,') INCREASED TO',1X,1P,E11.3)
 1400 FORMAT(1X,'XMAX(',I2,') INCREASED TO',1X,1P,E11.3)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYSCAT
 
C...FINDS OUTGOING FLAVOURS AND EVENT TYPE; SETS UP THE KINEMATICS
C...AND COLOUR FLOW OF THE HARD SCATTERING.
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYINT1/XQ(2,-6:6),DSIG(-6:6,-6:6,5),FSIG(10,10,3)
      COMMON/PYINT2/KPR(-6:6,-6:6),NMX(6),ICOL(40,4,2),ICH(30),VKM2(4,4)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
      DIMENSION PMQ(2),Z(2),CTHE(2),PHI(2)
 
C...CHOICE OF SUBPROCESS, NUMBER OF DOCUMENTATION LINES
      IGRP=IPY(44)
      ISUB=IGRP
      IF(IGRP.LE.5) THEN
        IF(KFL(2,1).NE.500.AND.KFL(2,2).NE.500) THEN
          ISUB=1
          IF(KFL(2,1)+KFL(2,2).EQ.0) ISUB=MIN(IPY(43),3)
        ELSEIF(KFL(2,1).NE.500.OR.KFL(2,2).NE.500) THEN
          ISUB=4
        ELSE
          ISUB=5
          IF(IPY(43).GE.3) ISUB=6
        ENDIF
      ENDIF
      IDOC=8
      IF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.25.OR.ISUB.EQ.26.OR.
     &ISUB.EQ.31.OR.ISUB.EQ.32.OR.ISUB.EQ.33) IDOC=9
      IF((ISUB.EQ.11.AND.IPY(22).EQ.0).OR.(ISUB.EQ.12.AND.IPY(23).EQ.0).
     &OR.(ISUB.EQ.25.AND.IPY(24).EQ.0).OR.(ISUB.EQ.26.AND.IPY(24).EQ.0).
     &OR.(ISUB.EQ.31.AND.IPY(25).EQ.0).OR.(ISUB.EQ.32.AND.IPY(26).EQ.0).
     &OR.(ISUB.EQ.33.AND.IPY(27).EQ.0)) IDOC=7
      IF(ISUB.EQ.27.OR.ISUB.EQ.28) IDOC=11
      IPY(40)=IDOC
 
C...STORE INCOMING PARTICLES, RESET P VECTORS
      DO 100 I=1,2
      K(I,1)=40000
      K(I,2)=IPY(40+I)
      P(I,1)=0.
      P(I,2)=0.
      P(I,5)=PYVAR(2+I)
      P(I,3)=PYVAR(5)*(-1)**(I+1)
  100 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
      IPY(46)=2
      DO 110 I=5,30
      K(I,1)=80000
      K(I,2)=0
      DO 110 J=1,5
  110 P(I,J)=0.
      KFRES=0
 
C...STORE INCOMING PARTONS IN THEIR CM-FRAME
      SHR=SQRT(SH)
      DO 120 JT=1,2
      I=2*JT+19
      K(I,1)=20000
      K(I,2)=KFL(2,JT)
      P(I,5)=ULMASS(0,K(I,2))
      K(I+1,1)=70000+I
      K(I+1,2)=1000
  120 IF(IPY(34).GE.1) K(I+1,2)=1002+JT
      IF(P(21,5)+P(23,5).GE.SHR) THEN
        P(21,5)=0.
        P(23,5)=0.
      ENDIF
      P(21,4)=0.5*(SHR+(P(21,5)**2-P(23,5)**2)/SHR)
      P(21,3)=SQRT(MAX(0.,P(21,4)**2-P(21,5)**2))
      P(23,4)=SHR-P(21,4)
      P(23,3)=-P(21,3)
 
C...CHOOSE NEW QUARK/LEPTON/BOSON FLAVOUR FOR RELEVANT ANNIHILATION
C...GRAPHS
      IF(ISUB.EQ.2.OR.ISUB.EQ.5.OR.(ISUB.GE.11.AND.(ISET(ISUB).EQ.2.
     &OR.ISET(ISUB).EQ.3))) THEN
        IRES=1
        IF(ISUB.EQ.11) IRES=2
        IF(ISUB.EQ.12) IRES=3
        IF(ISUB.EQ.25.OR.ISUB.EQ.26) IRES=4
        IF(ISUB.EQ.31) IRES=5
        IF(ISUB.EQ.32) IRES=6
        IF(ISUB.EQ.33) IRES=7
  130   RFSIG=PYVAR(45)*RLU(0)
        DO 150 I=1,2*IPY(9)
        IF(IPROD(IRES,I).LE.0) GOTO 150
        KFL1=500+I
        DO 140 J=1,2*IPY(9)
        IF(IPROD(IRES,J).LE.0) GOTO 140
        KFL2=-(500+J)
        RFSIG=RFSIG-FSIG(I,J,1)
        IF(RFSIG.LE.0.) GOTO 200
  140   CONTINUE
  150   CONTINUE
        DO 170 I=1,2*IPY(9)
        IF(IPROD(IRES,10+I).LE.0) GOTO 170
        KFL1=6+I
        DO 160 J=1,2*IPY(9)
        IF(IPROD(IRES,10+J).LE.0) GOTO 160
        KFL2=-(6+J)
        RFSIG=RFSIG-FSIG(I,J,2)
        IF(RFSIG.LE.0.) GOTO 200
  160   CONTINUE
  170   CONTINUE
        DO 190 I=1,3
        IF(IPROD(IRES,20+I).LE.0) GOTO 190
        KFL1=I+1
        IF(KFL1.EQ.4) KFL1=92
        DO 180 J=1,3
        IF(IPROD(IRES,20+J).LE.0) GOTO 180
        KFL2=-(J+1)
        IF(KFL2.EQ.-4) KFL2=-92
        IF(KFL2.EQ.-2) KFL2=2
        RFSIG=RFSIG-FSIG(I,J,3)
        IF(RFSIG.LE.0.) GOTO 200
  180   CONTINUE
  190   CONTINUE
  200   IF(ULMASS(0,KFL1)+ULMASS(0,KFL2)+0.2.GE.MAX(1.,SHR)) GOTO 130
      ENDIF
 
C...FINAL STATE FLAVOURS AND COLOUR FLOW
      KFL(3,1)=KFL(2,1)
      KFL(3,2)=KFL(2,2)
      KCC=20
      KCS=ISIGN(1,KFL(2,1))
      IF(ISUB.EQ.1) THEN
C...Q + Q' -> Q + Q'; TH = (P(Q)-P(Q))**2
        KCC=IPY(43)
        IF(RLU(0).LT.PYPAR(19)) KCC=3-KCC
        IF(KFL(2,1)*KFL(2,2).LT.0) KCC=KCC+2
      ELSEIF(ISUB.EQ.2) THEN
C...Q + QB -> Q' + QB'; TH = (P(Q)-P(Q'))**2
        KFL(3,1)=ISIGN(KFL1,KFL(2,1))
        KFL(3,2)=-KFL(3,1)
        KCC=4
        IF(RLU(0).LT.PYPAR(19)) KCC=3
      ELSEIF(ISUB.EQ.3) THEN
C...Q + QB -> G + G; TH ARBITRARY
        KFL(3,1)=500
        KFL(3,2)=500
        KCC=IPY(43)+2
      ELSEIF(ISUB.EQ.4) THEN
C...G + Q -> G + Q; TH = (P(Q)-P(Q))**2
        KCC=IPY(43)+6
        IF(KFL(2,1).EQ.500) KCC=KCC+2
        KCS=ISIGN(1,KFL(2,1)+KFL(2,2))
      ELSEIF(ISUB.EQ.5) THEN
C...G + G -> Q + QB; TH ARBITRARY
        KCS=(-1)**INT(1.5+RLU(0))
        KFL(3,1)=ISIGN(KFL1,KCS)
        KFL(3,2)=-KFL(3,1)
        KCC=IPY(43)+10
      ELSEIF(ISUB.EQ.6) THEN
C...G + G -> G + G; TH ARBITRARY
        KCC=IPY(43)+10
        KCS=(-1)**INT(1.5+RLU(0))
      ELSEIF(ISUB.EQ.7) THEN
C...LOW-PT ( = ENERGYLESS G + G -> G + G)
        KCC=IPY(43)+10
        KCS=(-1)**INT(1.5+RLU(0))
      ELSEIF(ISUB.EQ.11) THEN
C...Q + QB -> Z0/GAM* ( + FORWARD-BACKWARD ASYMMETRY)
        KFL(3,1)=ISIGN(KFL1,KFL(2,1))
        KFL(3,2)=-KFL(3,1)
        KFRES=5
        IF(IPY(11).EQ.1) KFRES=1
        IF(IPY(11).EQ.2) KFRES=2
        IF(KFL1.NE.92) THEN
C...QUARKS, LEPTONS: MODIFY 1+COS(THE)**2 TO 1+A*COS(THE)+COS(THE)**2
          XW=PYPAR(2)
          EI=ICH(IABS(KFL(2,1))-500)/3.
          AI=SIGN(1.,EI+0.1)
          VI=AI-4.*EI*XW
          IF(KFL1.GE.500) EF=ICH(KFL1-500)/3.
          IF(KFL1.LT.500) EF=ICH(KFL1+4)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          SQMZ=WM(11,1)**2
          GZMZ=WM(11,1)*WM(11,3)
          DSGG=1.
          DSZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
          DSZG=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
          IF(IPY(11).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
            DSZZ=0.
            DSZG=0.
          ELSEIF(IPY(11).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED
            DSGG=0.
            DSZG=0.
          ENDIF
          ASYM=2.*(4.*VI*AI*DSZZ*VF*AF+EI*AI*DSZG*EF*AF)/
     &    (EI**2*DSGG*EF**2+(VI**2+AI**2)*DSZZ*(VF**2+AF**2)+
     &    EI*VI*DSZG*EF*VF)
          IF(1.+ASYM*PYVAR(20)/(1.+PYVAR(20)**2).LT.RLU(0)) THEN
            THSAV=TH
            TH=UH
            UH=THSAV
            PYVAR(20)=-PYVAR(20)
          ENDIF
        ELSE
C...H+/- : MODIFY 1+COS(THE)**2 TO SIN(THE)**2
          PYVAR(20)=-2.*COS((ACOS(0.25*PYVAR(20)*(3.+PYVAR(20)**2))-
     &    2.*PAR(71))/3.)
        ENDIF
      ELSEIF(ISUB.EQ.12) THEN
C...Q + QB' -> W+/- ( + FORWARD-BACKWARD ASYMMETRY)
        ICH1=ICH(IABS(KFL(2,1))-500)*ISIGN(1,KFL(2,1))
        ICH2=ICH(IABS(KFL(2,2))-500)*ISIGN(2,KFL(2,2))
        IF(ICH(IABS(KFL(2,1))-500).GT.0) THEN
          KFL(3,1)=ISIGN(KFL2,KFL(2,1))
          KFL(3,2)=ISIGN(KFL1,KFL(2,2))
        ELSE
          KFL(3,1)=ISIGN(KFL1,KFL(2,1))
          KFL(3,2)=ISIGN(KFL2,KFL(2,2))
        ENDIF
        KFRES=ISIGN(3,ICH1+ICH2)
C...MODIFY 1+COS(THE)**2 TO (1+COS(THE))**2
        IF(1.+2.*PYVAR(20)/(1.+PYVAR(20)**2).LT.RLU(0)) THEN
          THSAV=TH
          TH=UH
          UH=THSAV
          PYVAR(20)=-PYVAR(20)
        ENDIF
      ELSEIF(ISUB.EQ.13) THEN
C...G + Q -> GAM + Q; TH = (P(Q)-P(Q))**2
        IF(KFL(2,1).EQ.500) KFL(3,1)=1
        IF(KFL(2,2).EQ.500) KFL(3,2)=1
        KCC=16
        IF(KFL(2,1).EQ.500) KCC=17
        KCS=ISIGN(1,KFL(2,1)+KFL(2,2))
      ELSEIF(ISUB.EQ.14) THEN
C...G + Q -> Z0 + Q; TH = (P(Q)-P(Q))**2
        IF(KFL(2,1).EQ.500) KFL(3,1)=2
        IF(KFL(2,2).EQ.500) KFL(3,2)=2
        KCC=16
        IF(KFL(2,1).EQ.500) KCC=17
        KCS=ISIGN(1,KFL(2,1)+KFL(2,2))
      ELSEIF(ISUB.EQ.15) THEN
C...G + Q -> W+/- + Q'; TH = (P(Q)-P(Q'))**2; CHOOSE FLAVOUR Q'
        JT=1
        IF(KFL(2,1).EQ.500) JT=2
        KFL(3,3-JT)=ISIGN(3,ICH(IABS(KFL(2,JT))-500)*KFL(2,JT))
        IA=IABS(KFL(2,JT))-500
        IF(IA.LE.2) IA=3-IA
        FSIGS=0.
        DO 210 J=1,IPY(9)
        JA=2*J-1+MOD(IA,2)
        IF(JA.LE.2) JA=3-JA
  210   IF(IPROD(0,JA).EQ.1) FSIGS=FSIGS+VKM2((IA+1)/2,(JA+1)/2)
  220   RFSIG=FSIGS*RLU(0)
        DO 230 J=1,IPY(9)
        JA=2*J-1+MOD(IA,2)
        IF(JA.LE.2) JA=3-JA
        IF(IPROD(0,JA).EQ.0) GOTO 230
        KFL(3,JT)=ISIGN(500+JA,KFL(2,JT))
        RFSIG=RFSIG-VKM2((IA+1)/2,(JA+1)/2)
        IF(RFSIG.LE.0.) GOTO 240
  230   CONTINUE
  240   IF((ULMASS(0,KFL(3,JT))+PAR(22))**2.GE.SH) GOTO 220
        KCC=15+JT
        KCS=ISIGN(1,KFL(2,1)+KFL(2,2))
      ELSEIF(ISUB.EQ.16) THEN
C...Q + QB -> GAM + G; TH ARBITRARY
        IF(RLU(0).LT.0.5) THEN
          KFL(3,1)=1
          KFL(3,2)=500
          KCC=19
        ELSE
          KFL(3,1)=500
          KFL(3,2)=1
          KCC=18
        ENDIF
      ELSEIF(ISUB.EQ.17) THEN
C...Q + QB -> Z0 + G; TH ARBITRARY
        IF(RLU(0).LT.0.5) THEN
          KFL(3,1)=2
          KFL(3,2)=500
          KCC=19
        ELSE
          KFL(3,1)=500
          KFL(3,2)=2
          KCC=18
        ENDIF
      ELSEIF(ISUB.EQ.18) THEN
C...Q + QB' -> W+/- + G; TH ARBITRARY
        ICH1=ICH(IABS(KFL(2,1))-500)*ISIGN(1,KFL(2,1))
        ICH2=ICH(IABS(KFL(2,2))-500)*ISIGN(1,KFL(2,2))
        IF(RLU(0).LT.0.5) THEN
          KFL(3,1)=ISIGN(3,ICH1+ICH2)
          KFL(3,2)=500
          KCC=19
        ELSE
          KFL(3,1)=500
          KFL(3,2)=ISIGN(3,ICH1+ICH2)
          KCC=18
        ENDIF
      ELSEIF(ISUB.EQ.19) THEN
C...Q + QB -> GAM + GAM; TH ARBITRARY
        KFL(3,1)=1
        KFL(3,2)=1
      ELSEIF(ISUB.EQ.20) THEN
C...Q + QB -> GAM + Z0; TH ARBITRARY
        KFL(3,1)=1+INT(RLU(0)+0.5)
        KFL(3,2)=3-KFL(3,1)
      ENDIF
      IF(ISUB.EQ.21) THEN
C...Q + QB' -> GAM + W+/-; TH = (P(Q)-P(W-))**2 OR (P(QB')-P(W+))**2
        ICH1=ICH(IABS(KFL(2,1))-500)*ISIGN(1,KFL(2,1))
        ICH2=ICH(IABS(KFL(2,2))-500)*ISIGN(1,KFL(2,2))
        KFL(3,1)=ISIGN(3,ICH1+ICH2)
        KFL(3,2)=1
        IF(KFL(2,1)*KFL(3,1).GT.0) THEN
          KFL(3,2)=KFL(3,1)
          KFL(3,1)=1
        ENDIF
      ELSEIF(ISUB.EQ.22) THEN
C...Q + QB -> Z0 + Z0; TH ARBITRARY
        KFL(3,1)=2
        KFL(3,2)=2
      ELSEIF(ISUB.EQ.23) THEN
C...Q + QB' -> Z0 + W+/-; TH = (P(Q)-P(W-))**2 OR (P(QB')-P(W+))**2
        ICH1=ICH(IABS(KFL(2,1))-500)*ISIGN(1,KFL(2,1))
        ICH2=ICH(IABS(KFL(2,2))-500)*ISIGN(1,KFL(2,2))
        KFL(3,1)=ISIGN(3,ICH1+ICH2)
        KFL(3,2)=2
        IF(KFL(2,1)*KFL(3,1).GT.0) THEN
          KFL(3,2)=KFL(3,1)
          KFL(3,1)=2
        ENDIF
      ELSEIF(ISUB.EQ.24) THEN
C...Q + QB -> W+ + W-; TH = (P(Q)-P(W-))**2
        KFL(3,1)=-ISIGN(3,KFL(2,1))
        KFL(3,2)=-KFL(3,1)
      ELSEIF(ISUB.EQ.25) THEN
C...Q + QB -> H0
        KFL(3,1)=ISIGN(KFL1,KFL(2,1))
        IF(KFL(3,1).EQ.-2) KFL(3,1)=2
        KFL(3,2)=-KFL(3,1)
        IF(KFL(3,2).EQ.-2) KFL(3,2)=2
        KFRES=4
      ELSEIF(ISUB.EQ.26) THEN
C...G + G -> H0
        KFL(3,1)=KFL1
        KFL(3,2)=KFL2
        KCC=21
        KFRES=4
      ELSEIF(ISUB.EQ.27) THEN
C...Z0 + Z0 -> H0
        SQMH=PYVAR(25)*PYVAR(2)
        XH=SQMH/SH
        KFL(3,1)=KFL(2,1)
        KFL(3,2)=KFL(2,2)
        PMQ(1)=ULMASS(0,KFL(3,1))
        PMQ(2)=ULMASS(0,KFL(3,2))
  250   JT=INT(1.5+RLU(0))
        ZMIN=2.*PMQ(JT)/SHR
        ZMAX=1.-PMQ(3-JT)/SHR-(SQMH-PMQ(JT)**2)/(SHR*(SHR-PMQ(3-JT)))
        ZMAX=MIN(1.-XH,ZMAX)
        Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
        IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
     &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 250
        SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SH)
        IF(SQC1.LT.1.E-8) GOTO 250
        C1=SQRT(SQC1)
        C2=1.+2.*(PMAS(2)**2-PMQ(JT)**2)/(Z(JT)*SH)
        CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
        CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
        Z(3-JT)=1.-XH/(1.-Z(JT))
        SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SH)
        IF(SQC1.LT.1.E-8) GOTO 250
        C1=SQRT(SQC1)
        C2=1.+2.*(PMAS(2)**2-PMQ(3-JT)**2)/(Z(3-JT)*SH)
        CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
        CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
        PHIR=PAR(72)*RLU(0)
        CPHI=COS(PHIR)
        ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
        Z1=2.-Z(JT)
        Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SH)
        Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SH
        Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
     &  PMQ(3-JT)**2/SH))
        ZMIN=2.*PMQ(3-JT)/SHR
        ZMAX=1.-PMQ(JT)/SHR-(SQMH-PMQ(3-JT)**2)/(SHR*(SHR-PMQ(JT)))
        ZMAX=MIN(1.-XH,ZMAX)
        IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 250
        KCC=22
        KFRES=4
      ELSEIF(ISUB.EQ.28) THEN
C...W+ + W- -> H0
        SQMH=PYVAR(25)*PYVAR(2)
        XH=SQMH/SH
  260   DO 290 JT=1,2
        IA=IABS(KFL(2,JT))-500
        IF(IA.LE.2) IA=3-IA
        FSIGS=0.
        DO 270 J=1,IPY(9)
        JA=2*J-1+MOD(IA,2)
        IF(JA.LE.2) JA=3-JA
  270   IF(IPROD(0,JA).EQ.1) FSIGS=FSIGS+VKM2((IA+1)/2,(JA+1)/2)
        RFSIG=FSIGS*RLU(0)
        DO 280 J=1,IPY(9)
        JA=2*J-1+MOD(IA,2)
        IF(JA.LE.2) JA=3-JA
        IF(IPROD(0,JA).EQ.0) GOTO 280
        KFL(3,JT)=ISIGN(500+JA,KFL(2,JT))
        RFSIG=RFSIG-VKM2((IA+1)/2,(JA+1)/2)
        IF(RFSIG.LE.0.) GOTO 290
  280   CONTINUE
  290   PMQ(JT)=ULMASS(0,KFL(3,JT))
        JT=INT(1.5+RLU(0))
        ZMIN=2.*PMQ(JT)/SHR
        ZMAX=1.-PMQ(3-JT)/SHR-(SQMH-PMQ(JT)**2)/(SHR*(SHR-PMQ(3-JT)))
        ZMAX=MIN(1.-XH,ZMAX)
        Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
        IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
     &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 260
        SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SH)
        IF(SQC1.LT.1.E-8) GOTO 260
        C1=SQRT(SQC1)
        C2=1.+2.*(PMAS(3)**2-PMQ(JT)**2)/(Z(JT)*SH)
        CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
        CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
        Z(3-JT)=1.-XH/(1.-Z(JT))
        SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SH)
        IF(SQC1.LT.1.E-8) GOTO 260
        C1=SQRT(SQC1)
        C2=1.+2.*(PMAS(3)**2-PMQ(3-JT)**2)/(Z(3-JT)*SH)
        CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
        CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
        PHIR=PAR(72)*RLU(0)
        CPHI=COS(PHIR)
        ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
        Z1=2.-Z(JT)
        Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SH)
        Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SH
        Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
     &  PMQ(3-JT)**2/SH))
        ZMIN=2.*PMQ(3-JT)/SHR
        ZMAX=1.-PMQ(JT)/SHR-(SQMH-PMQ(3-JT)**2)/(SHR*(SHR-PMQ(JT)))
        ZMAX=MIN(1.-XH,ZMAX)
        IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 260
        KCC=22
        KFRES=4
      ELSEIF(ISUB.EQ.29) THEN
C...Q + QB -> H0 + Z0; TH ARBITRARY
        KFL(3,1)=2+2*INT(RLU(0)+0.5)
        KFL(3,2)=6-KFL(3,1)
      ELSEIF(ISUB.EQ.30) THEN
C...Q + QB' -> H0 + W+/-; TH = (P(Q)-P(W-))**2 OR (P(QB')-P(W+))**2
        ICH1=ICH(IABS(KFL(2,1))-500)*ISIGN(1,KFL(2,1))
        ICH2=ICH(IABS(KFL(2,2))-500)*ISIGN(1,KFL(2,2))
        KFL(3,1)=ISIGN(3,ICH1+ICH2)
        KFL(3,2)=4
        IF(KFL(2,1)*KFL(3,1).GT.0) THEN
          KFL(3,2)=KFL(3,1)
          KFL(3,1)=4
        ENDIF
      ELSEIF(ISUB.EQ.31) THEN
C...Q + QB' -> R
        KFRES=ISIGN(91,KFL(2,1)+KFL(2,2))
        KFL(3,1)=KFL1
        KFL(3,2)=KFL2
        IF(IABS(KFL(3,1)).GT.IABS(KFL(3,2))) THEN
          KFL(3,1)=-KFL(3,1)
          KFL(3,2)=-KFL(3,2)
        ENDIF
        KFLA=IABS(KFL(3,1))
        IF(KFLA.EQ.503.OR.KFLA.EQ.504.OR.KFLA.EQ.9) THEN
          KFLSAV=KFL(3,1)
          KFL(3,1)=KFL(3,2)
          KFL(3,2)=KFLSAV
        ENDIF
        IF(-KFL(2,1).LT.KFL(2,2)) THEN
          KFL(3,1)=-KFL(3,1)
          KFL(3,2)=-KFL(3,2)
        ENDIF
        KFLA=IABS(KFL(2,1))
        IF(KFLA.EQ.503.OR.KFLA.EQ.504) THEN
          KFLSAV=KFL(3,1)
          KFL(3,1)=KFL(3,2)
          KFL(3,2)=KFLSAV
        ENDIF
      ELSEIF(ISUB.EQ.32) THEN
C...Q + QB' -> H+/-
        ICH1=ICH(IABS(KFL(2,1))-500)*ISIGN(1,KFL(2,1))
        ICH2=ICH(IABS(KFL(2,2))-500)*ISIGN(1,KFL(2,2))
        IF(ICH(IABS(KFL(2,1))-500).GT.0) THEN
          KFL(3,1)=ISIGN(KFL2,KFL(2,1))
          KFL(3,2)=ISIGN(KFL1,KFL(2,2))
        ELSE
          KFL(3,1)=ISIGN(KFL1,KFL(2,1))
          KFL(3,2)=ISIGN(KFL2,KFL(2,2))
        ENDIF
        KFRES=ISIGN(92,ICH1+ICH2)
      ELSEIF(ISUB.EQ.33) THEN
C...Q + QB -> Z'0/Z0/GAM* ( + FORWARD-BACKWARD ASYMMETRY)
        KFL(3,1)=ISIGN(KFL1,KFL(2,1))
        KFL(3,2)=-KFL(3,1)
        KFRES=93
C...MODIFY 1+COS(THE)**2 TO 1+A*COS(THE)+COS(THE)**2
        XW=PYPAR(2)
        EI=ICH(IABS(KFL(2,1))-500)/3.
        AI=SIGN(1.,EI+0.1)
        VI=AI-4.*EI*XW
        API=SIGN(1.,EI+0.1)
        VPI=API-4.*EI*XW
        IF(KFL1.GE.500) EF=ICH(KFL1-500)/3.
        IF(KFL1.LT.500) EF=ICH(KFL1+4)/3.
        AF=SIGN(1.,EF+0.1)
        VF=AF-4.*EF*XW
        APF=SIGN(1.,EF+0.1)
        VPF=APF-4.*EF*XW
        SQMZ=WM(33,1)**2
        GZMZ=WM(33,1)*WM(33,3)
        SQMZP=WM(33,2)**2
        GZMZP=WM(33,2)*WM(33,4)
        DSGG=1.
        DSZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
        DSZPZP=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZP)**2+GZMZP**2)
        DSZG=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
        DSZPG=1./(8.*XW*(1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GZMZP**2)
        DSZPZ=2./(16.*XW*(1.-XW))**2*
     &  SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/
     &  (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))
        IF(IPY(39).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
          DSZZ=0.
          DSZPZP=0.
          DSZG=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED:
          DSGG=0.
          DSZPZP=0.
          DSZG=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.3) THEN
C...ONLY Z'0 PRODUCTION INCLUDED:
          DSGG=0.
          DSZZ=0.
          DSZG=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.4) THEN
C...ONLY Z0/GAM* PRODUCTION INCLUDED:
          DSZPZP=0.
          DSZPG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.5) THEN
C...ONLY Z'0/GAM* PRODUCTION INCLUDED:
          DSZZ=0.
          DSZG=0.
          DSZPZ=0.
        ELSEIF(IPY(39).EQ.6) THEN
C...ONLY Z'0/Z0 PRODUCTION INCLUDED:
          DSGG=0.
          DSZG=0.
          DSZPG=0.
        ENDIF
        ASYM=2.*(4.*VI*AI*DSZZ*VF*AF+4.*VPI*API*DSZPZP*VPF*APF+
     &  EI*AI*DSZG*EF*AF+EI*API*DSZPG*EF*APF+(VI*API+VPI*AI)*DSZPZ*
     &  (VF*APF+VPF*AF))/(EI**2*DSGG*EF**2+(VI**2+AI**2)*DSZZ*
     &  (VF**2+AF**2)+(VPI**2+API**2)*DSZPZP*(VPF**2+APF**2)+
     &  EI*VI*DSZG*EF*VF+EI*VPI*DSZPG*EF*VPF+(VI*VPI+AI*API)*DSZPZ*
     &  (VF*VPF+AF*APF))
        IF(1.+ASYM*PYVAR(20)/(1.+PYVAR(20)**2).LT.RLU(0)) THEN
          THSAV=TH
          TH=UH
          UH=THSAV
          PYVAR(20)=-PYVAR(20)
        ENDIF
      ENDIF
 
C...DOCUMENT EXCHANGED RESONANCE
      IF(IDOC.EQ.7.OR.IDOC.EQ.9) THEN
        K(7,1)=40000
        K(7,2)=KFRES
        P(7,4)=SHR
        P(7,5)=SHR
      ENDIF
 
      IF(IDOC.EQ.7) THEN
C...RESONANCE NOT DECAYING: STORE COLOUR CONNECTION INDICES
        K(25,1)=7
        K(25,2)=KFRES
        P(25,4)=SHR
        P(25,5)=SHR
        K(26,1)=70025
        K(26,2)=1000
        IF(IPY(34).GE.1) K(26,2)=1007
        N=26
        P(22,3)=23.
        P(22,4)=23.
        P(24,3)=21.
        P(24,4)=21.
        DO 300 I=1,2
        I1=4+I
        I2=19+2*I
        K(I2,1)=K(I2,1)+I1
        K(I1,1)=40002+I
        K(I1,2)=K(I2,2)
        DO 300 J=1,5
  300   P(I1,J)=P(I2,J)
 
      ELSEIF(IDOC.EQ.8.OR.IDOC.EQ.9) THEN
C...2 -> 2 PROCESSES: STORE OUTGOING PARTONS IN THEIR CM-FRAME
        DO 310 JT=1,2
        I=2*JT+23
        K(I,1)=0
        K(I,2)=KFL(3,JT)
        P(I,5)=ULMASS(0,K(I,2))
        K(I+1,1)=70000+I
        K(I+1,2)=1000
  310   IF(IPY(34).GE.1) K(I+1,2)=1000+IDOC+JT-2
        IF(P(25,5)+P(27,5).GE.SHR) THEN
          KFA1=IABS(KFL(3,1))-500
          KFA2=IABS(KFL(3,2))-500
          IF(KFA1.LT.0.OR.KFA1.GT.3.OR.KFA2.LT.0.OR.KFA2.GT.3) THEN
            IPY(48)=1
            RETURN
          ENDIF
          P(25,5)=0.
          P(27,5)=0.
        ENDIF
        P(25,4)=0.5*(SHR+(P(25,5)**2-P(27,5)**2)/SHR)
        P(25,3)=SQRT(MAX(0.,P(25,4)**2-P(25,5)**2))
        P(27,4)=SHR-P(25,4)
        P(27,3)=-P(25,3)
        N=28
 
C...ROTATE OUTGOING PARTONS USING COS(THETA)=(TH-UH)/LAM(SH,SQM1,SQM2)
        MST(1)=25
        CALL LUROBO(ACOS(PYVAR(20)),PAR(72)*RLU(0),0.,0.,0.)
        MST(1)=0
 
      ELSE
C...Z0 + Z0 -> H0, W+ + W- -> H0: STORE HIGGS AND OUTGOING PARTONS
        PHI(1)=PAR(72)*RLU(0)
        PHI(2)=PHI(1)-PHIR
        DO 320 JT=1,2
        I=2*JT+23
        K(I,1)=0
        K(I,2)=KFL(3,JT)
        P(I,5)=ULMASS(0,K(I,2))
        IF(0.5*SHR*Z(JT).LE.P(I,5)) P(I,5)=0.
        PABS=SQRT(MAX(0.,(0.5*SHR*Z(JT))**2-P(I,5)**2))
        PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
        P(I,1)=PTABS*COS(PHI(JT))
        P(I,2)=PTABS*SIN(PHI(JT))
        P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
        P(I,4)=0.5*SHR*Z(JT)
        K(I+1,1)=70000+I
        K(I+1,2)=1000
        IF(IPY(34).GE.1) K(I+1,2)=1000+IDOC+JT-2
        IZW=6+JT
        K(IZW,1)=40000+IZW-2
        K(IZW,2)=2
        IF(ISUB.EQ.28) K(IZW,2)=ISIGN(3,LUCHGE(KFL(2,JT)))
        P(IZW,1)=-P(I,1)
        P(IZW,2)=-P(I,2)
        P(IZW,3)=(0.5*SHR-PABS*CTHE(JT))*(-1)**(JT+1)
        P(IZW,4)=0.5*SHR*(1.-Z(JT))
  320   P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
        K(29,1)=9
        K(29,2)=KFRES
        P(29,5)=SQRT(SQMH)
        P(29,1)=-P(25,1)-P(27,1)
        P(29,2)=-P(25,2)-P(27,2)
        P(29,3)=-P(25,3)-P(27,3)
        P(29,4)=SHR-P(25,4)-P(27,4)
        K(30,1)=70029
        K(30,2)=1000
        IF(IPY(34).GE.1) K(30,2)=1009
        K(9,1)=40000
        K(9,2)=KFRES
        DO 330 J=1,5
  330   P(9,J)=P(29,J)
        N=30
      ENDIF
 
      IF(IDOC.GE.8) THEN
C...STORE COLOUR CONNECTION INDICES
        DO 340 J=1,2
        JC=J
        IF(KCS.EQ.-1) JC=3-J
        IF(ICOL(KCC,1,JC).NE.0) P(22,J+2)=19+2*ICOL(KCC,1,JC)
        IF(ICOL(KCC,2,JC).NE.0) P(24,J+2)=19+2*ICOL(KCC,2,JC)
        IF(ICOL(KCC,3,JC).NE.0) P(26,J)=19+2*ICOL(KCC,3,JC)
  340   IF(ICOL(KCC,4,JC).NE.0) P(28,J)=19+2*ICOL(KCC,4,JC)
 
C...COPY INCOMING AND OUTGOING PARTONS TO DOCUMENTATION LINES,
C...ALSO DOCUMENT EXCHANGED RESONANCE
        DO 350 I=1,4
        IF(I.LE.2) I1=4+I
        IF(I.GE.3) I1=IDOC-4+I
        I2=19+2*I
        K(I2,1)=K(I2,1)+I1
        IF(I.LE.2) K(I1,1)=40002+I
        IF(I.GE.3.AND.IDOC.EQ.8) K(I1,1)=40000
        IF(I.GE.3.AND.IDOC.EQ.9) K(I1,1)=40007
        IF(I.GE.3.AND.IDOC.EQ.11) K(I1,1)=40002+I
        K(I1,2)=K(I2,2)
        DO 350 J=1,5
  350   P(I1,J)=P(I2,J)
      ENDIF
      IPY(47)=N
 
C...LOW-PT EVENTS: REMOVE GLUONS USED FOR STRING DRAWING PURPOSES
      IF(ISUB.EQ.7) THEN
        K(25,1)=K(25,1)+20000
        K(27,1)=K(27,1)+20000
        X(1)=0.
        X(2)=0.
        SH=0.
        TH=0.
        UH=0.
        Q2=0.
        DO 360 I=5,8
        DO 360 J=1,5
  360   P(I,J)=0.
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYSSPA(IPU1,IPU2)
 
C...GENERATES SPACELIKE PARTON SHOWERS
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYINT1/XQ(2,-6:6),DSIG(-6:6,-6:6,5),FSIG(10,10,3)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
      DIMENSION IFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVS(2),ROBO(5),
     &XFS(2,-6:6),XFA(-6:6),XFB(-6:6),XFN(-6:6),WTAP(-6:6),WTSF(-6:6)
      DOUBLE PRECISION DQ2(3),DSH,DSHZ,DSHR,DPLCM,DPC(3),DPD(4),DMS,
     &DMSMA,DPT2,DPB(4)
 
C...COMMON CONSTANTS, SET UP INITIAL VALUES
      Q2E=Q2
      IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.3) Q2E=Q2E/PYPAR(26)
      IF(ISUB.EQ.27) Q2E=PMAS(2)**2
      IF(ISUB.EQ.28) Q2E=PMAS(3)**2
      TMAX=ALOG(PYPAR(26)*PYPAR(27)*Q2E/PYPAR(21)**2)
      IF(PYPAR(26)*Q2E.LT.MAX(PYPAR(22),2.*PYPAR(21)**2).OR.
     &TMAX.LT.0.2) RETURN
      XE0=2.*PYPAR(23)/PYVAR(1)
      B0=(33.-2.*IPY(8))/6.
      NS=N
      MST(2)=0
  100 N=NS
      DO 110 JT=1,2
      IFLS(JT)=MOD(KFL(2,JT),500)
      IFLS(JT+2)=IFLS(JT)
      XS(JT)=X(JT)
      ZS(JT)=1.
      Q2S(JT)=PYPAR(26)*Q2E
      TEVS(JT)=TMAX
      DO 110 IFL=-6,6
  110 XFS(JT,IFL)=XQ(JT,IFL)
      DSH=SH
 
C...PICK UP LEG WITH HIGHEST VIRTUALITY
  120 N=N+2
      JT=1
      IF(N.GT.NS+2.AND.Q2S(2).GT.Q2S(1)) JT=2
      IFLB=IFLS(JT)
      XB=XS(JT)
      DO 130 IFL=-6,6
  130 XFB(IFL)=XFS(JT,IFL)
      Q2B=Q2S(JT)
      TEVB=TEVS(JT)
      IF(IPY(14).GE.9.AND.N.GT.NS+4) THEN
        Q2B=0.5*(1./ZS(JT)+1.)*Q2S(JT)+0.5*(1./ZS(JT)-1.)*(Q2S(3-JT)-
     &  SNGL(DSH)+SQRT((SNGL(DSH)+Q2S(1)+Q2S(2))**2+8.*Q2S(1)*Q2S(2)*
     &  ZS(JT)/(1.-ZS(JT))))
        TEVB=ALOG(PYPAR(27)*Q2B/PYPAR(21)**2)
      ENDIF
      DSHR=2.*DSQRT(DSH)
      DSHZ=DSH/DBLE(ZS(JT))
      XE=MAX(XE0,XB*(1./(1.-PYPAR(24))-1.))
      IF(XB+XE.GE.0.999) THEN
        Q2B=0.
        GOTO 200
      ENDIF
      TEVBSV=TEVB
 
C...CALCULATE ALTARELLI-PARISI AND STRUCTURE FUNCTION WEIGHTS
      DO 140 IFL=-6,6
      WTAP(IFL)=0.
  140 WTSF(IFL)=0.
      IF(IFLB.EQ.0) THEN
        WTAPQ=16.*(1.-SQRT(XB+XE))/(3.*SQRT(XB))
        DO 150 IFL=-IPY(8),IPY(8)
        IF(IFL.EQ.0) WTAP(IFL)=6.*ALOG((1.-XB)/XE)
  150   IF(IFL.NE.0) WTAP(IFL)=WTAPQ
      ELSE
        WTAP(0)=0.5*XB*(1./(XB+XE)-1.)
        WTAP(IFLB)=8.*ALOG((1.-XB)*(XB+XE)/XE)/3.
      ENDIF
  160 WTSUM=0.
      DO 170 IFL=-IPY(8),IPY(8)
      WTSF(IFL)=XFB(IFL)/XFB(IFLB)
  170 WTSUM=WTSUM+WTAP(IFL)*WTSF(IFL)
 
C...CHOOSE NEW T AND FLAVOUR
  180 IF(IPY(14).LE.6.OR.IPY(14).GE.9) THEN
        TEVEXP=B0/MAX(0.0001,WTSUM)
      ELSE
        TEVEXP=B0/MAX(0.0001,5.*WTSUM)
      ENDIF
      TEVB=TEVB*EXP(MAX(-100.,ALOG(RLU(0))*TEVEXP))
  185 Q2REF=PYPAR(21)**2*EXP(TEVB)
      Q2B=Q2REF/PYPAR(27)
      IF(Q2B.LT.PYPAR(22)) THEN
        Q2B=0.
      ELSE
        WTRAN=RLU(0)*WTSUM
        IFLA=-IPY(8)-1
  190   IFLA=IFLA+1
        WTRAN=WTRAN-WTAP(IFLA)*WTSF(IFLA)
        IF(IFLA.LT.IPY(8).AND.WTRAN.GT.0.) GOTO 190
 
C...CHOOSE Z VALUE AND CORRECTIVE WEIGHT
        IF(IFLB.EQ.0.AND.IFLA.EQ.0) THEN
          Z=1./(1.+((1.-XB)/XB)*(XE/(1.-XB))**RLU(0))
          WTZ=(1.-Z*(1.-Z))**2
        ELSEIF(IFLB.EQ.0) THEN
          Z=XB/(1.-RLU(0)*(1.-SQRT(XB+XE)))**2
          WTZ=0.5*(1.+(1.-Z)**2)*SQRT(Z)
        ELSEIF(IFLA.EQ.0) THEN
          Z=XB*(1.+RLU(0)*(1./(XB+XE)-1.))
          WTZ=1.-2.*Z*(1.-Z)
        ELSE
          Z=1.-(1.-XB)*(XE/((XB+XE)*(1.-XB)))**RLU(0)
          WTZ=0.5*(1.+Z**2)
        ENDIF
 
C...SUM UP SOFT GLUON EMISSION AS EFFECTIVE Z SHIFT
        IF(IPY(15).GE.1) THEN
          RSOFT=6.
          IF(IFLB.NE.0) RSOFT=8./3.
          Z=Z*(TEVB/TEVS(JT))**(RSOFT*XE/((XB+XE)*B0))
          IF(Z.LE.XB) GOTO 180
        ENDIF
 
C...OPTION WITH EVOLUTION IN KT2=(1-Z)Q2:
        IF(IPY(14).GE.5.AND.IPY(14).LE.6.AND.N.LE.NS+4) THEN
C...CHECK THAT (Q2)LAST BRANCHING < (Q2)HARD
          IF(Q2B/(1.-Z).GT.PYPAR(26)*Q2) GOTO 180
        ELSEIF(IPY(14).GE.3.AND.IPY(14).LE.6.AND.N.GE.NS+6) THEN
C...CHECK THAT Z,Q2 COMBINATION IS KINEMATICALLY ALLOWED
          Q2MAX=0.5*(1./ZS(JT)+1.)*DQ2(JT)+0.5*(1./ZS(JT)-1.)*
     &    (DQ2(3-JT)-DSH+SQRT((DSH+DQ2(1)+DQ2(2))**2+8.*DQ2(1)*DQ2(2)*
     &    ZS(JT)/(1.-ZS(JT))))
          IF(Q2B/(1.-Z).GE.Q2MAX) GOTO 180
 
        ELSEIF(IPY(14).EQ.7.OR.IPY(14).EQ.8) THEN
C...OPTION WITH ALPHAS((1-Z)Q2): DEMAND KT2 > CUTOFF, REWEIGHT
          IF((1.-Z)*Q2B.LT.PYPAR(22)) GOTO 180
          ALPRAT=TEVB/(TEVB+ALOG(1.-Z))
          IF(ALPRAT.LT.5.*RLU(0)) GOTO 180
          IF(ALPRAT.GT.5.) WTZ=WTZ*ALPRAT/5.
        ENDIF
 
C...WEIGHTING WITH NEW STRUCTURE FUNCTIONS
        CALL PYSTFU(IPY(40+JT),XB,Q2REF,XFN)
        IF(XFN(IFLB).LT.1E-20) THEN
          IF(IFLA.EQ.IFLB) THEN
            TEVB=TEVBSV
            WTAP(IFLB)=0.
            GOTO 160
          ELSEIF(TEVBSV-TEVB.GT.0.2) THEN
            TEVB=0.5*(TEVBSV+TEVB)
            GOTO 185
          ELSE
            XFN(IFLB)=1E-10
          ENDIF
        ENDIF
        DO 195 IFL=-6,6
  195   XFB(IFL)=XFN(IFL)
        XA=XB/Z
        CALL PYSTFU(IPY(40+JT),XA,Q2REF,XFA)
        IF(XFA(IFLA).LT.1E-20) GOTO 160
        IF(WTZ*XFA(IFLA)/XFB(IFLB).LT.RLU(0)*WTSF(IFLA)) GOTO 160
      ENDIF
 
  200 IF(N.EQ.NS+4) THEN
C...DEFINE TWO HARD SCATTERERS IN THEIR CM-FRAME
        DQ2(JT)=Q2B
        IF(IPY(14).GE.3.AND.IPY(14).LE.6) DQ2(JT)=Q2B/(1.-Z)
        DPLCM=DSQRT((DSH+DQ2(1)+DQ2(2))**2-4.*DQ2(1)*DQ2(2))/DSHR
        DO 210 JR=1,2
        I=NS+2*JR-1
        IPO=19+2*JR
        K(I,1)=20000
        K(I,2)=ISIGN(500+IABS(IFLS(JR+2)),2*IFLS(JR+2)+1)
        P(I,1)=0.
        P(I,2)=0.
        P(I,3)=DPLCM*(-1)**(JR+1)
        P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
        P(I,5)=-SQRT(SNGL(DQ2(JR)))
        K(I+1,1)=70000+I
        K(I+1,2)=K(IPO+1,2)
        P(I+1,1)=0.
        P(I+1,2)=0.
        P(I+1,3)=IPO
        P(I+1,4)=IPO
        P(I+1,5)=0.
        P(IPO+1,1)=I
  210   P(IPO+1,2)=I
 
      ELSEIF(N.GT.NS+4) THEN
C...FIND MAXIMUM ALLOWED MASS OF TIMELIKE PARTON
        JR=3-JT
        DQ2(3)=Q2B
        IF(IPY(14).GE.3.AND.IPY(14).LE.6) DQ2(3)=Q2B/(1.-Z)
        DPC(1)=P(IS(1),4)
        DPC(2)=P(IS(2),4)
        DPC(3)=0.5*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
        DPD(1)=DSH+DQ2(JR)+DQ2(JT)
        DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
        DPD(3)=DSQRT(DPD(1)**2-4.*DQ2(JR)*DQ2(JT))
        DPD(4)=DSQRT(DPD(2)**2-4.*DQ2(JR)*DQ2(3))
        IKIN=0
        IF(Q2S(JR).GE.0.5*PYPAR(22).AND.DPD(1)-DPD(3).GE.1D-10*DPD(1))
     &  IKIN=1
        IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/DBLE(ZS(JT))-DQ2(3))*(DSH/
     &  (DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
        IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/(2.*
     &  DQ2(JR))-DQ2(JT)-DQ2(3)
 
C...GENERATE TIMELIKE PARTON SHOWER (IF REQUIRED)
        IT=N-1
        K(IT,1)=0
        K(IT,2)=ISIGN(500+IABS(IFLB-IFLS(JT+2)),2*(IFLB-IFLS(JT+2))+1)
        P(IT,5)=ULMASS(0,K(IT,2))
        IF(SNGL(DMSMA).LE.P(IT,5)**2) GOTO 100
        P(IT,2)=0.
        K(IT+1,1)=70000+IT
        K(IT+1,2)=K(IS(JT)+1,2)
        DO 220 J=1,5
  220   P(IT+1,J)=0.
        IF(MOD(IPY(14),2).EQ.0) THEN
          P(IT,1)=0.
          P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
          P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
          CALL LUSHOW(IT,0,SQRT(MIN(SNGL(DMSMA),PYPAR(25)*Q2)))
          IF(N.GE.IT+2) P(IT,5)=P(IT+2,5)
        ENDIF
 
C...RECONSTRUCT KINEMATICS OF BRANCHING: TIMELIKE PARTON SHOWER
        DMS=P(IT,5)**2
        IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
        IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5*DPD(1)*DPD(2)+0.5*DPD(3)*
     &  DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.*DSH*DPC(3)**2)
        IF(DPT2.LT.0.) GOTO 100
        K(IT,1)=K(IT,1)+N+1
        DPB(1)=(0.5*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
     &  DSHR)/DPC(3)-DPC(3)
        P(IT,1)=SQRT(SNGL(DPT2))
        P(IT,3)=DPB(1)*(-1)**(JT+1)
        P(IT,4)=(DSHZ-DSH-DMS)/DSHR
        IF(N.GE.IT+2) THEN
          MST(1)=IT+2
          DPB(1)=DSQRT(DPB(1)**2+DPT2)
          DPB(2)=DSQRT(DPB(1)**2+DMS)
          DPB(3)=P(IT+2,3)
          DPB(4)=DSQRT(DPB(3)**2+DMS)
          BEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
     &    DPB(1))
          CALL LUROBO(0.,0.,0.,0.,BEZ)
          THE=ULANGL(P(IT,3),P(IT,1))
          CALL LUROBO(THE,0.,0.,0.,0.)
        ENDIF
 
C...RECONSTRUCT KINEMATICS OF BRANCHING: SPACELIKE PARTON
        K(N+1,1)=20000
        K(N+1,2)=ISIGN(500+IABS(IFLB),2*IFLB+1)
        P(N+1,1)=P(IT,1)
        P(N+1,2)=0.
        P(N+1,3)=P(IT,3)+P(IS(JT),3)
        P(N+1,4)=P(IT,4)+P(IS(JT),4)
        P(N+1,5)=-SQRT(SNGL(DQ2(3)))
        K(N+2,1)=70001+N
        K(N+2,2)=K(IS(JT)+1,2)
        DO 230 J=1,5
  230   P(N+2,J)=0.
 
C...DEFINE COLOUR FLOW OF BRANCHING
        K(IS(JT),1)=20001+N
        ID1=IT
        IF((K(N+1,2).GE.501.AND.K(ID1,2).GE.501).OR.(K(N+1,2).LT.0.AND.
     &  K(ID1,2).EQ.500).OR.(K(N+1,2).EQ.500.AND.K(ID1,2).EQ.500.AND.
     &  RLU(0).GT.0.5).OR.(K(N+1,2).EQ.500.AND.K(ID1,2).LT.0))
     &  ID1=IS(JT)
        ID2=IT+IS(JT)-ID1
        P(N+2,3)=ID1
        P(N+2,4)=ID2
        P(ID1+1,1)=N+1
        P(ID1+1,2)=ID2
        P(ID2+1,1)=ID1
        P(ID2+1,2)=N+1
        N=N+2
 
C...BOOST TO NEW CM-FRAME
        MST(1)=NS+1
        CALL LUROBO(0.,0.,-(P(N-1,1)+P(IS(JR),1))/(P(N-1,4)+P(IS(JR),
     &  4)),0.,-(P(N-1,3)+P(IS(JR),3))/(P(N-1,4)+P(IS(JR),4)))
        IR=N-1+(JT-1)*(IS(1)-N+1)
        CALL LUROBO(-ULANGL(P(IR,3),P(IR,1)),PAR(72)*RLU(0),0.,0.,0.)
        MST(1)=0
      ENDIF
 
C...SAVE QUANTITIES, LOOP BACK
      IS(JT)=N-1
      Q2S(JT)=Q2B
      DQ2(JT)=Q2B
      IF(IPY(14).GE.3.AND.IPY(14).LE.6) DQ2(JT)=Q2B/(1.-Z)
      DSH=DSHZ
      IF(Q2B.GE.0.5*PYPAR(22)) THEN
        IFLS(JT+2)=IFLS(JT)
        IFLS(JT)=IFLA
        XS(JT)=XA
        ZS(JT)=Z
        DO 240 IFL=-6,6
  240   XFS(JT,IFL)=XFA(IFL)
        TEVS(JT)=TEVB
      ELSE
        IF(JT.EQ.1) IPU1=N-1
        IF(JT.EQ.2) IPU2=N-1
      ENDIF
      IF(MAX(Q2S(1),Q2S(2)).GE.0.5*PYPAR(22).OR.N.LE.NS+2) GOTO 120
 
C...BOOST HARD SCATTERING PARTONS TO FRAME OF SHOWER INITIATORS
      DO 250 J=1,3
  250 ROBO(J+2)=(P(NS+1,J)+P(NS+3,J))/(P(NS+1,4)+P(NS+3,4))
      DO 260 J=1,5
  260 P(N+2,J)=P(NS+1,J)
      MST(1)=N+2
      MST(2)=N+2
      ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
      IF(ROBOT.GE.0.999999) THEN
        ROBOT=1.00001*SQRT(ROBOT)
        ROBO(3)=ROBO(3)/ROBOT
        ROBO(4)=ROBO(4)/ROBOT
        ROBO(5)=ROBO(5)/ROBOT
      ENDIF
      CALL LUROBO(0.,0.,-ROBO(3),-ROBO(4),-ROBO(5))
      ROBO(2)=ULANGL(P(N+2,1),P(N+2,2))
      ROBO(1)=ULANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
      MST(1)=5
      MST(2)=NS
      CALL LUROBO(ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
      MST(1)=0
      MST(2)=0
 
C...STORE USER INFORMATION
      K(21,1)=20001+NS
      K(23,1)=20003+NS
      DO 270 JT=1,2
      KFL(1,JT)=ISIGN(500+IABS(IFLS(JT)),2*IFLS(JT)+1)
  270 PYVAR(30+JT)=XS(JT)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYMULT
 
C...GENERATES ADDITIONAL MULTIPLE SEMIHARD INTERACTIONS
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
      DIMENSION KSTR(500,2)
 
C...SAVE SOME QUANTITIES AT HARD SCATTERING
      X1SAV=X(1)
      X2SAV=X(2)
      SHSAV=SH
      THSAV=TH
      UHSAV=UH
      Q2SAV=Q2
 
C...RECONSTRUCT STRINGS IN HARD SCATTERING
      NMAX=27
      IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.3) NMAX=23
      NSTR=0
      DO 110 I=21,NMAX,2
      KCS=ISIGN(1,K(I,2)*(510-IABS(K(I,2))))
      IF(IABS(K(I,2)).LE.500) KCS=0
      DO 100 J=1,4
      IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 100
      IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 100
      IST=NINT(P(I+1,J))
      IF(IST.LT.20.OR.IST.GT.I) GOTO 100
      IF(IABS(K(I,2)).LT.500.OR.IABS(K(IST,2)).LT.500) GOTO 100
      NSTR=NSTR+1
      IF(J.EQ.1.OR.J.EQ.4) THEN
        KSTR(NSTR,1)=I
        KSTR(NSTR,2)=IST
      ELSE
        KSTR(NSTR,1)=IST
        KSTR(NSTR,2)=I
      ENDIF
  100 CONTINUE
  110 CONTINUE
 
C...SET UP STARTING VALUES FOR ITERATION IN XT2:
      IGRP=5
      IPY(44)=5
      XT2=4.*PYVAR(19)/PYVAR(2)
      IF(IPY(12).LE.1) THEN
        XT2FAC=XMAX(IGRP)*PYVAR(13)/((1.-PYVAR(13))*PYVAR(54))
      ELSE
        XT2FAC=PYVAR(28)*PYVAR(30)*XMAX(IGRP)/PYVAR(54)*
     &  PYVAR(13)*(1.+PYVAR(13))
      ENDIF
      PYVAR(14)=0.
      PYVAR(15)=0.
      PYVAR(33)=0.
      PYVAR(34)=0.
      PYVAR(35)=1.-PYVAR(31)
      PYVAR(36)=1.-PYVAR(32)
 
C...ITERATE DOWNWARDS IN XT2; CHOOSE TAU AND XF (CF. SUBROUTINE PYRAND):
  120 IF(IPY(12).LE.1) THEN
        XT2=XT2FAC*XT2/(XT2FAC-XT2*ALOG(RLU(0)))
        IF(XT2.LT.PYVAR(13)) GOTO 170
      ELSE
        IF(XT2.LE.0.01*PYVAR(13)) GOTO 170
        XT2=XT2FAC*(XT2+PYVAR(13))/(XT2FAC-(XT2+PYVAR(13))*
     &  ALOG(RLU(0)))-PYVAR(13)
        IF(XT2.LE.0.) GOTO 170
        XT2=MAX(0.01*PYVAR(13),XT2)
      ENDIF
      RTAU=(1.+COEF(IGRP,1))*RLU(0)
      IF(RTAU.LE.1.) THEN
        TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
        TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
      ELSE
        TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
      ENDIF
      SH=TAU*PYVAR(2)
      CALL PYTHAT(THL,THU)
      XLS=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
      TH=MAX(THL,MIN(THU,-0.5*SH*(1.-XLS)))
      UH=MAX(THL,MIN(THU,-0.5*SH*(1.+XLS)))
      IF(XLS.GT.0.9999) TH=MIN(THU,-PYVAR(2)*XT2/4.)
      IF(XLS.LT.-0.9999) UH=MIN(THU,-PYVAR(2)*XT2/4.)
      RXF=(1.+COEF(IGRP,3))*RLU(0)
      IF(RXF.LE.1.) THEN
        XFP=TAU**RLU(0)
        XF=TAU/XFP-XFP
      ELSE
        XF=2.*SQRT(TAU)*TAN((2.*RLU(0)-1.)*ATAN((1.-TAU)/
     &  (2.*SQRT(TAU))))
      ENDIF
 
C...CALCULATE DERIVED QUANTITIES: X, Q2
      IF(XF.GE.0.) THEN
        X(1)=MIN(0.5*(SQRT(XF**2+4.*TAU)+XF),1.)
        X(2)=MIN(TAU/X(1),1.)
      ELSE
        X(2)=MIN(0.5*(SQRT(XF**2+4.*TAU)-XF),1.)
        X(1)=MIN(TAU/X(2),1.)
      ENDIF
      IF(X(1).GE.PYVAR(35).OR.X(2).GE.PYVAR(36)) GOTO 120
      IF(IPY(4).EQ.1) THEN
        Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
      ELSEIF(IPY(4).EQ.2) THEN
        Q2=TH*UH/SH
      ELSEIF(IPY(4).EQ.3) THEN
        Q2=MIN(-TH,-UH)
      ENDIF
 
C...ACCEPT OR REJECT SELECTED KINEMATICAL VARIABLES
      CALL PYDSIG(TAU,XF,XT2,DSIGS)
      IF(DSIGS.LT.XMAX(IGRP)*RLU(0)) GOTO 120
 
C...ADD FIRST PARTON TO EVENT RECORD
      RFLAV=RLU(0)
      PT=0.5*PYVAR(1)*SQRT(XT2)
      PHI=PAR(72)*RLU(0)
      XE=X(1)+X(2)
      K(N+1,1)=0
      K(N+1,2)=500
      IF(RFLAV.GE.MAX(PYPAR(37),PYPAR(38))) K(N+1,2)=501+
     &INT((2.+PAR(2))*RLU(0))
      P(N+1,1)=PT*COS(PHI)
      P(N+1,2)=PT*SIN(PHI)
      P(N+1,3)=0.25*(XF-XE*XLS)*PYVAR(1)
      P(N+1,4)=0.25*(XE-XF*XLS)*PYVAR(1)
      P(N+1,5)=0.
      K(N+2,1)=70000+N+1
      K(N+2,2)=1000
      DO 130 J=1,5
  130 P(N+2,J)=0.
 
C...ADD SECOND PARTON TO EVENT RECORD
      K(N+3,1)=0
      K(N+3,2)=500
      IF(K(N+1,2).NE.500) K(N+3,2)=-K(N+1,2)
      P(N+3,1)=-P(N+1,1)
      P(N+3,2)=-P(N+1,2)
      P(N+3,3)=0.25*(XF+XE*XLS)*PYVAR(1)
      P(N+3,4)=0.25*(XE+XF*XLS)*PYVAR(1)
      P(N+3,5)=0.
      K(N+4,1)=70000+N+3
      K(N+4,2)=1000
      DO 140 J=1,5
  140 P(N+4,J)=0.
 
      IF(RFLAV.LT.PYPAR(37).AND.NSTR.GE.1) THEN
C....CHOOSE RELEVANT STRING PIECES TO PLACE GLUONS ON
        DO 160 I=N+1,N+3,2
        DMIN=1E8
        DO 150 ISTR=1,NSTR
        I1=KSTR(ISTR,1)
        I2=KSTR(ISTR,2)
        DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
     &  P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
     &  P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1.,P(I1,4)*P(I2,4)-
     &  P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
        IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
          DMIN=DIST
          IST1=I1
          IST2=I2
          ISTM=ISTR
        ENDIF
  150   CONTINUE
 
C....COLOUR FLOW ADJUSTMENTS, NEW STRING PIECES
        IF(NINT(P(IST1+1,1)).EQ.IST2) P(IST1+1,1)=I
        IF(NINT(P(IST1+1,4)).EQ.IST2) P(IST1+1,4)=I
        P(I+1,2)=IST1
        P(I+1,1)=IST2
        IF(NINT(P(IST2+1,2)).EQ.IST1) P(IST2+1,2)=I
        IF(NINT(P(IST2+1,3)).EQ.IST1) P(IST2+1,3)=I
        KSTR(ISTM,2)=I
        KSTR(NSTR+1,1)=I
        KSTR(NSTR+1,2)=IST2
  160   NSTR=NSTR+1
 
C....STRING DRAWING AND COLOUR FLOW FOR GLUON LOOP
      ELSEIF(K(N+1,2).EQ.500) THEN
        P(N+2,1)=N+3
        P(N+2,2)=N+3
        P(N+4,1)=N+1
        P(N+4,2)=N+1
        KSTR(NSTR+1,1)=N+1
        KSTR(NSTR+1,2)=N+3
        KSTR(NSTR+2,1)=N+3
        KSTR(NSTR+2,2)=N+1
        NSTR=NSTR+2
 
C...STRING DRAWING AND COLOUR FLOW FOR Q-QBAR PAIR
      ELSE
        P(N+2,1)=N+3
        P(N+4,2)=N+1
        KSTR(NSTR+1,1)=N+1
        KSTR(NSTR+1,2)=N+3
        NSTR=NSTR+1
      ENDIF
 
C...UPDATE REMAINING ENERGY; ITERATE
      N=N+4
      IPY(45)=IPY(45)+1
      PYVAR(33)=PYVAR(33)+X(1)
      PYVAR(34)=PYVAR(34)+X(2)
      PYVAR(35)=PYVAR(35)-X(1)
      PYVAR(36)=PYVAR(36)-X(2)
      IF(IPY(45).LT.240) GOTO 120
 
C...RESTORE QUANTITIES AT HARD SCATTERING
  170 X(1)=X1SAV
      X(2)=X2SAV
      SH=SHSAV
      TH=THSAV
      UH=UHSAV
      Q2=Q2SAV
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYREMN(IPU1,IPU2)
 
C...ADDS ON TARGET REMNANTS (ONE OR TWO FROM EACH SIDE) AND
C...INCLUDES PRIMORDIAL KT.
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)
 
C...FIND EVENT TYPE, SET POINTERS
      IF(IPU1.EQ.0.AND.IPU2.EQ.0) RETURN
      ILEP=0
      IF(IPU1.EQ.0) ILEP=1
      IF(IPU2.EQ.0) ILEP=2
      IF(ISUB.EQ.7) ILEP=-1
      IF(ILEP.EQ.1) IQ=21
      IF(ILEP.EQ.2) IQ=23
      IP=MAX(IPU1,IPU2)
      NS=N
 
C...DEFINE INITIAL PARTONS, INCLUDING PRIMORDIAL KT
  100 DO 120 I=3,4
      IF(I.EQ.3) IPU=IPU1
      IF(I.EQ.4) IPU=IPU2
      K(I,1)=40000+I-2
      DO 110 J=1,5
  110 P(I,J)=0.
      IF(ISUB.EQ.7) THEN
        K(I,2)=500
        SHS=0.
      ELSEIF(IPU.NE.0) THEN
        K(I,2)=K(IPU,2)
        P(I,5)=P(IPU,5)
        CALL PYPRKT(P(I,1),P(I,2))
        PMS(I-2)=P(I,5)**2+P(I,1)**2+P(I,2)**2
      ELSE
        K(I,2)=K(IQ,2)
        P(I,5)=-SQRT(Q2)
        PMS(I-2)=-Q2
        SHS=(1.-X(5-I))*Q2/X(5-I)+PYVAR(7-I)**2
      ENDIF
  120 CONTINUE
 
C...KINEMATICS CONSTRUCTION FOR INITIAL PARTONS
      IF(ILEP.EQ.0) SHS=PYVAR(31)*PYVAR(32)*PYVAR(2)+
     &(P(3,1)+P(4,1))**2+(P(3,2)+P(4,2))**2
      SHR=SQRT(MAX(0.,SHS))
      IF(ILEP.EQ.0) THEN
        IF((SHS-PMS(1)-PMS(2))**2-4.*PMS(1)*PMS(2).LE.0.) GOTO 100
        P(3,4)=0.5*(SHR+(PMS(1)-PMS(2))/SHR)
        P(3,3)=SQRT(MAX(0.,P(3,4)**2-PMS(1)))
        P(4,4)=SHR-P(3,4)
        P(4,3)=-P(3,3)
      ELSEIF(ILEP.EQ.1) THEN
        P(3,4)=P(IQ,4)
        P(3,3)=P(IQ,3)
        P(4,4)=P(IP,4)
        P(4,3)=P(IP,3)
      ELSEIF(ILEP.EQ.2) THEN
        P(3,4)=P(IP,4)
        P(3,3)=P(IP,3)
        P(4,4)=P(IQ,4)
        P(4,3)=P(IQ,3)
      ENDIF
 
C...TRANSFORM PARTONS TO OVERALL CM-FRAME (NOT FOR LEPTOPRODUCTION)
      IF(ILEP.EQ.0) THEN
        MST(1)=3
        MST(2)=4
        ROBO(3)=(P(3,1)+P(4,1))/SHR
        ROBO(4)=(P(3,2)+P(4,2))/SHR
        CALL LUROBO(0.,0.,-ROBO(3),-ROBO(4),0.)
        ROBO(2)=ULANGL(P(3,1),P(3,2))
        CALL LUROBO(0.,-ROBO(2),0.,0.,0.)
        ROBO(1)=ULANGL(P(3,3),P(3,1))
        CALL LUROBO(-ROBO(1),0.,0.,0.,0.)
        MST(2)=MAX(IPY(47),IPU1,IPU2)
        CALL LUROBO(ROBO(1),ROBO(2),ROBO(3),ROBO(4),0.)
        ROBO(5)=MAX(-0.999999,MIN(0.999999,(PYVAR(31)-PYVAR(32))/
     &  (PYVAR(31)+PYVAR(32))))
        CALL LUROBO(0.,0.,0.,0.,ROBO(5))
        MST(1)=0
        MST(2)=0
      ENDIF
 
C...CHECK INVARIANT MASS OF REMNANT SYSTEM:
C...HADRONIC EVENTS OR LEPTOPRODUCTION
      IF(ILEP.LE.0) THEN
        IF(IPY(12).LE.0.OR.ISUB.EQ.7) PYVAR(33)=0.
        IF(IPY(12).LE.0.OR.ISUB.EQ.7) PYVAR(34)=0.
        PEH=P(3,4)+P(4,4)+0.5*PYVAR(1)*(PYVAR(33)+PYVAR(34))
        PZH=P(3,3)+P(4,3)+0.5*PYVAR(1)*(PYVAR(33)-PYVAR(34))
        SHH=(PYVAR(1)-PEH)**2-(P(3,1)+P(4,1))**2-(P(3,2)+P(4,2))**2-
     &  PZH**2
        PMMIN=P(1,5)+P(2,5)+ULMASS(0,K(3,2))+ULMASS(0,K(4,2))
        IF(SHR.GE.PYVAR(1).OR.SHH.LE.(PMMIN+PYPAR(12))**2) THEN
          IPY(48)=1
          RETURN
        ENDIF
        SHR=SQRT(SHH+(P(3,1)+P(4,1))**2+(P(3,2)+P(4,2))**2)
      ELSE
        PEI=P(IQ,4)+P(IP,4)
        PZI=P(IQ,3)+P(IP,3)
        PMS(ILEP)=MAX(0.,PEI**2-PZI**2+P(5-ILEP,1)**2+P(5-ILEP,2)**2)
        PMMIN=P(3-ILEP,5)+ULMASS(0,K(5-ILEP,2))+SQRT(PMS(ILEP))
        IF(SHR.LE.PMMIN+PYPAR(12)) THEN
          IPY(48)=1
          RETURN
        ENDIF
      ENDIF
 
C...SUBDIVIDE REMNANT IF NECESSARY, STORE FIRST PARTON
  130 I=NS-1
      DO 160 JT=1,2
      IF(JT.EQ.ILEP) GOTO 160
      IF(JT.EQ.1) IPU=IPU1
      IF(JT.EQ.2) IPU=IPU2
      CALL PYSPLI(IPY(40+JT),KFL(1,JT),KFLCH(JT),KFLSP(JT))
      I=I+2
      IS(JT)=I
      K(I,1)=0
      K(I,2)=KFLSP(JT)
      P(I,5)=ULMASS(0,K(I,2))
C...FIRST PARTON COLOUR CONNECTIONS AND TRANSVERSE MASS
      K(I+1,1)=70000+I
      K(I+1,2)=1000
      IF(IPY(34).GE.1) K(I+1,2)=1000+JT
      DO 140 J=1,5
  140 P(I+1,J)=0.
      IFLS=(3-ISIGN(1,KFLSP(JT)*(510-IABS(KFLSP(JT)))))/2
      P(I+1,IFLS+2)=IPU
      P(IPU+1,3-IFLS)=I
      IF(KFLCH(JT).EQ.0) THEN
        P(I,1)=-P(JT+2,1)
        P(I,2)=-P(JT+2,2)
        PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
      ELSE
C...WHEN EXTRA REMNANT PARTON OR HADRON: FIND RELATIVE PT, STORE
        CALL LUPTDI(1,P(I,1),P(I,2))
        PMS(JT+2)=P(I,5)**2+P(I,1)**2+P(I,2)**2
        I=I+2
        K(I,1)=0
        K(I,2)=KFLCH(JT)
        P(I,5)=ULMASS(0,K(I,2))
        P(I,1)=-P(JT+2,1)-P(I-2,1)
        P(I,2)=-P(JT+2,2)-P(I-2,2)
        PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
C...RELATIVE DISTRIBUTION OF ENERGY; EXTRA PARTON COLOUR CONNECTION
        CALL PYCHID(IPY(40+JT),KFLCH(JT),CHI(JT))
        PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1.-CHI(JT))
        K(I+1,1)=70000+I
        K(I+1,2)=1000
        IF(IPY(34).GE.1) K(I+1,2)=1000+JT
        DO 150 J=1,5
  150   P(I+1,J)=0.
        IF(IABS(KFLCH(JT)).GE.500) THEN
          IFLS=(3-ISIGN(1,KFLCH(JT)*(510-IABS(KFLCH(JT)))))/2
          P(I+1,IFLS+2)=IPU
          P(IPU+1,3-IFLS)=I
        ELSE
          IF(IPY(34).GE.1) K(I,1)=JT
        ENDIF
      ENDIF
  160 CONTINUE
      IF(SHR.LE.SQRT(PMS(1))+SQRT(PMS(2))) GOTO 130
      N=I+1
 
C...RECONSTRUCT KINEMATICS OF REMNANTS
      DO 170 JT=1,2
      IF(JT.EQ.ILEP) GOTO 170
      PE=0.5*(SHR+(PMS(JT)-PMS(3-JT))/SHR)
      PZ=SQRT(PE**2-PMS(JT))
      IF(KFLCH(JT).EQ.0) THEN
        P(IS(JT),4)=PE
        P(IS(JT),3)=PZ*(-1)**(JT-1)
      ELSE
        PW1=CHI(JT)*(PE+PZ)
        P(IS(JT)+2,4)=0.5*(PW1+PMS(JT+4)/PW1)
        P(IS(JT)+2,3)=0.5*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
        P(IS(JT),4)=PE-P(IS(JT)+2,4)
        P(IS(JT),3)=PZ*(-1)**(JT-1)-P(IS(JT)+2,3)
      ENDIF
  170 CONTINUE
 
C...HADRONIC EVENTS: BOOST REMNANTS TO CORRECT LONGITUDINAL FRAME
      IF(ILEP.LE.0) THEN
        MST(1)=NS+1
        CALL LUROBO(0.,0.,0.,0.,-PZH/(PYVAR(1)-PEH))
        MST(1)=0
C...LEPTOPRODUCTION EVENTS: BOOST COLLIDING SUBSYSTEM
      ELSE
        MST(1)=21
        MST(2)=MAX(IP,IPY(47))
        PEF=SHR-PE
        PZF=PZ*(-1)**(ILEP-1)
        PT2=P(5-ILEP,1)**2+P(5-ILEP,2)**2
        PHIPT=ULANGL(P(5-ILEP,1),P(5-ILEP,2))
        CALL LUROBO(0.,-PHIPT,0.,0.,0.)
        RQP=P(IQ,3)*(PT2+PEI**2)-P(IQ,4)*PEI*PZI
        SINTH=P(IQ,4)*SQRT(PT2*(PT2+PEI**2)/(RQP**2+PT2*
     &  P(IQ,4)**2*PZI**2))*SIGN(1.,-RQP)
        CALL LUROBO(ASIN(SINTH),0.,0.,0.,0.)
        BETAX=(-PEI*PZI*SINTH+SQRT(PT2*(PT2+PEI**2-(PZI*SINTH)**2)))/
     &  (PT2+PEI**2)
        CALL LUROBO(0.,0.,BETAX,0.,0.)
        CALL LUROBO(0.,PHIPT,0.,0.,0.)
        PEM=P(IQ,4)+P(IP,4)
        PZM=P(IQ,3)+P(IP,3)
        BETAZ=(-PEM*PZM+PZF*SQRT(PZF**2+PEM**2-PZM**2))/(PZF**2+PEM**2)
        CALL LUROBO(0.,0.,0.,0.,BETAZ)
        MST(1)=3
        MST(2)=4
        CALL LUROBO(ASIN(SINTH),0.,BETAX,0.,0.)
        CALL LUROBO(0.,PHIPT,0.,0.,BETAZ)
        MST(1)=0
        MST(2)=0
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYRESD
 
C...ALLOWS Z0, W+/-, H0 AND H+/- RESONANCES TO DECAY (INCLUDING PARTON
C...SHOWERS FOR HADRONIC CHANNELS)
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYINT1/XQ(2,-6:6),DSIG(-6:6,-6:6,5),FSIG(10,10,3)
      COMMON/PYINT2/KPR(-6:6,-6:6),NMX(6),ICOL(40,4,2),ICH(30),VKM2(4,4)
      DIMENSION IREF(10,6),KDCY(2),KFL1(2),KFL2(2),NSD(2),ILIN(6),
     &COUP(6,4),PK(6,4),PKK(6,6),THE(2),PHI(2)
      COMPLEX FGK,HA(6,6),HC(6,6)
      DOUBLE PRECISION XIGK,XJGK,DT,DU,D34,D56
 
C...THE F, XI AND XJ FUNCTIONS OF GUNION AND KUNSZT
C...(PHYS. REV. D33, 665, PLUS ERRATA FROM THE AUTHORS)
      FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
     &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
      XIGK(DT,DU)=-4.*D34*D56+DT*(3.*DT+4.*DU)+DT**2*(DT*DU/(D34*D56)-
     &2.*(1./D34+1./D56)*(DT+DU)+2.*(D34/D56+D56/D34))
      XJGK(DT,DU)=8.*(D34+D56)**2-8.*(D34+D56)*(DT+DU)-6.*DT*DU-
     &2.*DT*DU*(DT*DU/(D34*D56)-2.*(1./D34+1./D56)*(DT+DU)+
     &2.*(D34/D56+D56/D34))
 
C...DEFINE INITIAL TWO OBJECTS, INITIALIZE LOOP
      IREF(1,5)=0
      IREF(1,6)=0
      IF(ISUB.NE.27.AND.ISUB.NE.28) THEN
        IREF(1,1)=25
        IF(K(25,1).GE.20000) IREF(1,1)=NINT(P(26,3))
        IREF(1,2)=27
        IF(K(27,1).GE.20000) IREF(1,2)=NINT(P(28,3))
        IREF(1,3)=IPY(40)-1
        IREF(1,4)=IPY(40)
        IF(ISUB.EQ.11) IREF(1,5)=2
        IF(ISUB.EQ.25.OR.ISUB.EQ.26) IREF(1,5)=4
      ELSE
        IREF(1,1)=29
        IREF(1,2)=0
        IREF(1,3)=9
        IREF(1,4)=0
      ENDIF
      NP=1
      IP=0
  100 IP=IP+1
      NS=N
      NINH=0
 
C...LOOP OVER TWO RESONANCES; RESET DECAY RATES
      DO 380 JT=1,2
      KDCY(JT)=0
      KFL1(JT)=0
      KFL2(JT)=0
      NSD(JT)=IREF(IP,JT)
      ID=IREF(IP,JT)
      IF(ID.EQ.0) GOTO 380
      KFA=IABS(K(ID,2))
      DO 110 I1=1,10
      DO 110 I2=1,10
      DO 110 I3=1,3
  110 FSIG(I1,I2,I3)=0.
      FSIGS=0.
 
      IF(KFA.EQ.2.AND.IPY(22).NE.0) THEN
C...SUM UP ALLOWED Z0 DECAY MODE WEIGHTS
        RADC=1.+PYALPH(P(ID,5)**2)/PAR(71)
        DO 120 I=1,2*IPY(9)
        IF(IPROD(2,I).EQ.1.AND.2.*PMAS(100+I).LT.P(ID,5)) THEN
          RMQ=(PMAS(100+I)/P(ID,5))**2
          EF=ICH(I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*PYPAR(2)
          FSIG(I,I,1)=3.*(VF**2*(1.+2.*RMQ)+AF**2*(1.-4.*RMQ))*
     &    SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
        IF(IPROD(2,10+I).EQ.1.AND.2.*PMAS(6+I).LT.P(ID,5)) THEN
          RML=(PMAS(6+I)/P(ID,5))**2
          EF=ICH(10+I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*PYPAR(2)
          FSIG(I,I,2)=(VF**2*(1.+2.*RML)+AF**2*(1.-4.*RML))*
     &    SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(I,I,2)
        ENDIF
  120   CONTINUE
        IF(IPROD(2,23).EQ.1.AND.2.*PMAS(92).LT.P(ID,5)) THEN
          RMB=(PMAS(92)/P(ID,5))**2
          CF=2.*(1.-2.*PYPAR(2))
          FSIG(3,3,3)=0.25*CF**2*(1.-4.*RMB)*SQRT(MAX(0.,1.-4.*RMB))*
     &    PYVAR(66)**2
          FSIGS=FSIGS+FSIG(3,3,3)
        ENDIF
 
C...CHOOSE Z0 DECAY CHANNEL
  130   RFSIG=FSIGS*RLU(0)
        DO 140 I=1,2*IPY(9)
        IF(IPROD(2,I).LE.0) GOTO 140
        KFL1(JT)=500+I
        RFSIG=RFSIG-FSIG(I,I,1)
        IF(RFSIG.LE.0.) GOTO 170
  140   CONTINUE
        DO 150 I=1,2*IPY(9)
        IF(IPROD(2,10+I).LE.0) GOTO 150
        KFL1(JT)=6+I
        RFSIG=RFSIG-FSIG(I,I,2)
        IF(RFSIG.LE.0.) GOTO 170
  150   CONTINUE
        IF(IPROD(2,23).LE.0) GOTO 160
        KFL1(JT)=92
        RFSIG=RFSIG-FSIG(3,3,3)
        IF(RFSIG.LE.0.) GOTO 170
  160   CONTINUE
  170   KFL2(JT)=-KFL1(JT)
        IF(2.*ULMASS(0,KFL1(JT))+PAR(22).GE.P(ID,5)) GOTO 130
 
      ELSEIF(KFA.EQ.3.AND.IPY(23).NE.0) THEN
C...SUM UP ALLOWED W+/- DECAY MODE WEIGHTS
        RADC=1.+PYALPH(P(ID,5)**2)/PAR(71)
        DO 180 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        IF(IPROD(3,10+IL).EQ.1.AND.IPROD(3,10+IU).EQ.1.AND.
     &  PMAS(6+IL)+PMAS(6+IU).LT.P(ID,5)) THEN
          RMLL=(PMAS(6+IL)/P(ID,5))**2
          RMLU=(PMAS(6+IU)/P(ID,5))**2
          FSIG(IL,IU,2)=(1.-RMLL-RMLU)*(2.+RMLL+RMLU)*
     &    SQRT(MAX(0.,(1.-RMLL-RMLU)**2-4.*RMLL*RMLU))
          FSIGS=FSIGS+FSIG(IL,IU,2)
        ENDIF
        IF(IL.EQ.1) IL=2
        DO 180 J=1,IPY(9)
        JU=2*J
        IF(JU.EQ.2) JU=1
        IF(IPROD(3,IL).EQ.1.AND.IPROD(3,JU).EQ.1.AND.
     &  PMAS(100+IL)+PMAS(100+JU).LT.P(ID,5)) THEN
          RMQI=(PMAS(100+IL)/P(ID,5))**2
          RMQJ=(PMAS(100+JU)/P(ID,5))**2
          FSIG(IL,JU,1)=3.*(1.-RMQI-RMQJ)*(2.+RMQI+RMQJ)*
     &    SQRT(MAX(0.,(1.-RMQI-RMQJ)**2-4.*RMQI*RMQJ))*VKM2(I,J)*RADC
          FSIGS=FSIGS+FSIG(IL,JU,1)
        ENDIF
  180   CONTINUE
 
C...CHOOSE W+/- DECAY CHANNEL
  190   RFSIG=FSIGS*RLU(0)
        DO 200 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        IF(IPROD(3,10+IL).LE.0.OR.IPROD(3,10+IU).LE.0) GOTO 200
        KFL1(JT)=6+IL
        KFL2(JT)=-(6+IU)
        RFSIG=RFSIG-FSIG(IL,IU,2)
        IF(RFSIG.LE.0.) GOTO 230
  200   CONTINUE
        DO 220 I=1,2*IPY(9)
        IF(IPROD(3,I).LE.0) GOTO 220
        KFL1(JT)=500+I
        DO 210 J=1,2*IPY(9)
        IF(IPROD(3,J).LE.0) GOTO 210
        KFL2(JT)=-(500+J)
        RFSIG=RFSIG-FSIG(I,J,1)
        IF(RFSIG.LE.0.) GOTO 230
  210   CONTINUE
  220   CONTINUE
  230   IF(ULMASS(0,KFL1(JT))+ULMASS(0,KFL2(JT))+PAR(22).GE.P(ID,5))
     &  GOTO 190
        IF(K(ID,2).EQ.3) THEN
          KFL1(JT)=-KFL1(JT)
          KFL2(JT)=-KFL2(JT)
        ENDIF
 
      ELSEIF(KFA.EQ.4.AND.IPY(24).NE.0) THEN
C...SUM UP ALLOWED H0 DECAY MODES:
        RADC=1.+PYALPH(P(ID,5)**2)/PAR(71)
        DO 240 I=1,2*IPY(9)
        IF(IPROD(4,I).EQ.1.AND.2.*PMAS(100+I).LT.P(ID,5)) THEN
          RMQ=(PMAS(100+I)/P(ID,5))**2
          FSIG(I,I,1)=3.*RMQ*(1.-4.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
  240   CONTINUE
        DO 250 I=1,IPY(9)
        IL=2*I-1
        IF(IPROD(4,10+IL).EQ.1.AND.2.*PMAS(6+IL).LT.P(ID,5)) THEN
          RML=(PMAS(6+IL)/P(ID,5))**2
          FSIG(IL,IL,2)=RML*(1.-4.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(IL,IL,2)
        ENDIF
  250   CONTINUE
        DO 260 I=1,2
        IF(IPROD(4,20+I).EQ.1.AND.2.*PMAS(I+1).LT.P(ID,5)) THEN
          RMB=(PMAS(I+1)/P(ID,5))**2
          FSIG(I,I,3)=(1.-4.*RMB+12.*RMB**2)*SQRT(MAX(0.,1.-4.*RMB))/
     &    (2.*(3-I))*PYVAR(61+I)**2
          FSIGS=FSIGS+FSIG(I,I,3)
        ENDIF
  260   CONTINUE
 
C...CHOOSE H0 DECAY CHANNEL:
  270   RFSIG=FSIGS*RLU(0)
        DO 280 I=1,2*IPY(9)
        IF(IPROD(4,I).LE.0) GOTO 280
        KFL1(JT)=500+I
        RFSIG=RFSIG-FSIG(I,I,1)
        IF(RFSIG.LE.0.) GOTO 310
  280   CONTINUE
        DO 290 I=1,IPY(9)
        IL=2*I-1
        IF(IPROD(4,10+IL).LE.0) GOTO 290
        KFL1(JT)=6+IL
        RFSIG=RFSIG-FSIG(IL,IL,2)
        IF(RFSIG.LE.0.) GOTO 310
  290   CONTINUE
        DO 300 I=1,2
        IF(IPROD(4,20+I).LE.0) GOTO 300
        KFL1(JT)=I+1
        RFSIG=RFSIG-FSIG(I,I,3)
        IF(RFSIG.LE.0.) GOTO 310
  300   CONTINUE
  310   IF(2.*ULMASS(0,KFL1(JT))+PAR(22).GE.P(ID,5)) GOTO 270
        KFL2(JT)=-KFL1(JT)
        IF(KFL1(JT).EQ.2) KFL2(JT)=KFL1(JT)
 
      ELSEIF(KFA.EQ.92.AND.IPY(26).NE.0) THEN
C...SUM UP ALLOWED H+/- DECAY MODES:
        RADC=1.+PYALPH(P(ID,5)**2)/PAR(71)
        DO 320 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        IF(IPROD(6,10+IL).EQ.1.AND.IPROD(6,10+IU).EQ.1.AND.
     &  PMAS(6+IL)+PMAS(6+IU).LT.P(ID,5)) THEN
          RMLL=(PMAS(6+IL)/P(ID,5))**2
          RMLU=(PMAS(6+IU)/P(ID,5))**2
          FSIG(IL,IU,2)=((RMLL*PYPAR(36)+RMLU/PYPAR(36))*
     &    (1.-RMLL-RMLU)-4.*RMLL*RMLU)*
     &    SQRT(MAX(0.,(1.-RMLL-RMLU)**2-4.*RMLL*RMLU))
          FSIGS=FSIGS+FSIG(IL,IU,2)
        ENDIF
        IF(IL.EQ.1) IL=2
        IF(IU.EQ.2) IU=1
        IF(IPROD(6,IL).EQ.1.AND.IPROD(6,IU).EQ.1.AND.
     &  PMAS(100+IL)+PMAS(100+IU).LT.P(ID,5)) THEN
          RMQL=(PMAS(100+IL)/P(ID,5))**2
          RMQU=(PMAS(100+IU)/P(ID,5))**2
          FSIG(IL,IU,1)=3.*((RMQL*PYPAR(36)+RMQU/PYPAR(36))*
     &    (1.-RMQL-RMQU)-4.*RMQL*RMQU)*
     &    SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))*RADC
          FSIGS=FSIGS+FSIG(IL,IU,1)
        ENDIF
  320   CONTINUE
 
C...CHOOSE H+/- DECAY CHANNEL:
  330   RFSIG=FSIGS*RLU(0)
        DO 350 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        IF(IPROD(6,10+IL).LE.0.OR.IPROD(6,10+IU).LE.0) GOTO 340
        KFL1(JT)=6+IL
        KFL2(JT)=-(6+IU)
        RFSIG=RFSIG-FSIG(IL,IU,2)
        IF(RFSIG.LE.0.) GOTO 360
  340   IF(IL.EQ.1) IL=2
        IF(IU.EQ.2) IU=1
        IF(IPROD(6,IL).LE.0.OR.IPROD(6,IU).LE.0) GOTO 350
        KFL1(JT)=500+IL
        KFL2(JT)=-(500+IU)
        RFSIG=RFSIG-FSIG(IL,IU,1)
        IF(RFSIG.LE.0.) GOTO 360
  350   CONTINUE
  360   IF(ULMASS(0,KFL1(JT))+ULMASS(0,KFL2(JT))+PAR(22).GE.P(ID,5))
     &  GOTO 330
        IF(K(ID,2).EQ.92) THEN
          KFL1(JT)=-KFL1(JT)
          KFL2(JT)=-KFL2(JT)
        ENDIF
      ENDIF
 
C...SUMMARIZE RESULT ON DECAY CHANNEL CHOSEN
      IF((KFA.EQ.2.OR.KFA.EQ.3).AND.KFL1(JT).EQ.0) NINH=NINH+1
      IF(KFL1(JT).EQ.0) GOTO 380
      KDCY(JT)=2
      IF(IABS(KFL1(JT)).GE.500) KDCY(JT)=1
      IF(IABS(KFL1(JT)).GE.2.AND.IABS(KFL1(JT)).LE.5) KDCY(JT)=3
      NSD(JT)=N
 
C...FILL DECAY PRODUCTS, PREPARED FOR PARTON SHOWERS FOR QUARKS
      IF(KDCY(JT).EQ.1) THEN
        CALL LU2JET(-(N+1),MOD(KFL1(JT),500),MOD(KFL2(JT),500),P(ID,5))
      ELSE
        PE1=0.5*(P(ID,5)+(ULMASS(0,KFL1(JT))**2-
     &  ULMASS(0,KFL2(JT))**2)/P(ID,5))
        CALL LUPART(N+1,KFL1(JT),PE1,0.,0.)
        CALL LUPART(N+2,KFL2(JT),P(ID,5)-PE1,PAR(71),0.)
        N=N+1
        DO 370 I=N-2,N,2
        K(I,1)=70000+I-1
        K(I,2)=1000
        DO 370 J=1,5
  370   P(I,J)=0.
      ENDIF
      K(N-3,1)=K(N-3,1)+ID
      K(N-1,1)=K(N-1,1)+ID
      THE(JT)=ACOS(2.*RLU(0)-1.)
      PHI(JT)=PAR(72)*RLU(0)
  380 CONTINUE
      IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 530
      IF(IPY(38).EQ.0.OR.IREF(IP,2).EQ.0.OR.NINH.GE.1) GOTO 500
      IF(ISUB.EQ.11) GOTO 500
 
C...ORDER INCOMING PARTONS AND OUTGOING RESONANCES
      ILIN(1)=21
      IF(K(21,2).GT.0) ILIN(1)=23
      IF(IABS(K(ILIN(1),2)).EQ.500) ILIN(1)=44-ILIN(1)
      ILIN(2)=44-ILIN(1)
      IMIN=1
      IF(IREF(IP,5).EQ.4) IMIN=3
      IMAX=2
      IORD=1
      IF(IABS(K(IREF(IP,1),2)).EQ.2) IORD=2
      IF(K(IREF(IP,1),2).EQ.3.AND.K(IREF(IP,2),2).EQ.-3) IORD=2
      IF(IABS(K(IREF(IP,IORD),2)).EQ.4) IORD=3-IORD
      IF(KDCY(IORD).EQ.0) IORD=3-IORD
 
C...ORDER DECAY PRODUCTS OF RESONANCES
      DO 390 JT=IORD,3-IORD,3-2*IORD
      IF(KDCY(JT).EQ.0) THEN
        ILIN(IMAX+1)=NSD(JT)
        IMAX=IMAX+1
      ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
        ILIN(IMAX+1)=N+2*JT-1
        ILIN(IMAX+2)=N+2*JT
        IMAX=IMAX+2
        K(N+2*JT-1,2)=K(NSD(JT)+1,2)
        K(N+2*JT,2)=K(NSD(JT)+3,2)
      ELSE
        ILIN(IMAX+1)=N+2*JT
        ILIN(IMAX+2)=N+2*JT-1
        IMAX=IMAX+2
        K(N+2*JT-1,2)=K(NSD(JT)+1,2)
        K(N+2*JT,2)=K(NSD(JT)+3,2)
      ENDIF
  390 CONTINUE
 
C...FIND CHARGE, ISOSPIN, LEFT- AND RIGHTHANDED COUPLINGS
      DO 410 I=IMIN,IMAX
      DO 400 J=1,4
  400 COUP(I,J)=0.
      KFA=IABS(K(ILIN(I),2))
      IF(KFA.LT.6.OR.KFA.EQ.500) GOTO 410
      COUP(I,1)=LUCHGE(KFA)/3.
      COUP(I,2)=(-1)**MOD(KFA,2)
      IF(KFA.EQ.501.OR.KFA.EQ.502) COUP(I,2)=-COUP(I,2)
      COUP(I,4)=-2.*COUP(I,1)*PYPAR(2)
      COUP(I,3)=COUP(I,2)+COUP(I,4)
  410 CONTINUE
      SQMZ=PMAS(2)**2
      SQMW=PMAS(3)**2
 
C...SELECT RANDOM ANGLES; CONSTRUCT MASSLESS FOUR-VECTORS
  420 DO 430 I=N+1,N+4
      K(I,1)=0
      DO 430 J=1,5
  430 P(I,J)=0.
      DO 440 JT=1,2
      IF(KDCY(JT).EQ.0) GOTO 440
      ID=IREF(IP,JT)
      P(N+2*JT-1,3)=0.5*P(ID,5)
      P(N+2*JT-1,4)=0.5*P(ID,5)
      P(N+2*JT,3)=-0.5*P(ID,5)
      P(N+2*JT,4)=0.5*P(ID,5)
      THE(JT)=ACOS(2.*RLU(0)-1.)
      PHI(JT)=PAR(72)*RLU(0)
      MST(1)=N+2*JT-1
      MST(2)=N+2*JT
      CALL LUROBO(THE(JT),PHI(JT),P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),
     &P(ID,3)/P(ID,4))
      MST(1)=0
      MST(2)=0
  440 CONTINUE
 
C...STORE INCOMING AND OUTGOING MOMENTA, CALCULATE INTERNAL PRODUCTS
      DO 450 I=1,2
      PK(I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+
     &P(ILIN(I),5)**2)
      DO 450 J=1,3
  450 PK(I,J)=P(ILIN(I),J)
      DO 460 I=3,IMAX
      PK(I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+
     &P(ILIN(I),5)**2)
      DO 460 J=1,3
  460 PK(I,J)=P(ILIN(I),J)
      IF(ISUB.GE.22.AND.ISUB.LE.24) THEN
        DO 470 I1=IMIN,IMAX-1
        DO 470 I2=I1+1,IMAX
        HA(I1,I2)=SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+PK(I2,3))/
     &  (1E-20+PK(I1,1)**2+PK(I1,2)**2))*CMPLX(PK(I1,1),PK(I1,2))-
     &  SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
     &  (1E-20+PK(I2,1)**2+PK(I2,2)**2))*CMPLX(PK(I2,1),PK(I2,2))
        HC(I1,I2)=CONJG(HA(I1,I2))
        IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
        IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
        HA(I2,I1)=-HA(I1,I2)
  470   HC(I2,I1)=-HC(I1,I2)
      ENDIF
      DO 480 I=1,2
      DO 480 J=1,4
  480 PK(I,J)=-PK(I,J)
      DO 490 I1=IMIN,IMAX-1
      DO 490 I2=I1+1,IMAX
      PKK(I1,I2)=2.*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
     &PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
  490 PKK(I2,I1)=PKK(I1,I2)
 
      IF(IREF(IP,5).EQ.4) THEN
C...ANGULAR WEIGHT FOR H0 -> W+ + W- OR Z0 + Z0 -> 4 PARTONS/LEPTONS
        WT=16.*PKK(3,5)*PKK(4,6)
        IF(IP.EQ.1) WTMAX=SH**2
        IF(IP.GE.2) WTMAX=P(IREF(IP,6),5)**4
 
      ELSEIF(ISUB.EQ.14) THEN
C...ANGULAR WEIGHT FOR Q + G -> Q + Z0 -> Q + 2 PARTONS/LEPTONS
        IF(K(ILIN(1),2).GT.0) WT=((COUP(1,3)*COUP(3,3))**2+
     &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,4)**2+PKK(3,5)**2)+
     &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
     &  (PKK(1,3)**2+PKK(4,5)**2)
        IF(K(ILIN(1),2).LT.0) WT=((COUP(1,3)*COUP(3,3))**2+
     &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,3)**2+PKK(4,5)**2)+
     &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
     &  (PKK(1,4)**2+PKK(3,5)**2)
        WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
     &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
 
      ELSEIF(ISUB.EQ.15) THEN
C...ANGULAR WEIGHT FOR Q + G -> Q + W+/- -> Q + 2 PARTONS/LEPTONS
        IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
        IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
        WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
 
      ELSEIF(ISUB.EQ.17.OR.ISUB.EQ.20) THEN
C...ANGULAR WEIGHT FOR Q + QB -> Z0 + GAMMA/GLUON ->
C...-> 2 PARTONS/LEPTONS + GAMMA/GLUON
        WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
     &  (PKK(1,3)**2+PKK(2,4)**2)+((COUP(1,3)*COUP(3,4))**2+
     &  (COUP(1,4)*COUP(3,3))**2)*(PKK(1,4)**2+PKK(2,3)**2)
        WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
     &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
 
      ELSEIF(ISUB.EQ.18.OR.ISUB.EQ.21) THEN
C...ANGULAR WEIGHT FOR Q + QB' -> W+/- + GAMMA/GLUON ->
C...-> 2 PARTONS/LEPTONS + GAMMA/GLUON
        WT=PKK(1,3)**2+PKK(2,4)**2
        WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
 
      ELSEIF(ISUB.EQ.22) THEN
C...ANGULAR WEIGHT FOR Q + QB -> Z0 + Z0 -> 4 PARTONS/LEPTONS
        S34=P(IREF(IP,IORD),5)**2
        S56=P(IREF(IP,3-IORD),5)**2
        TI=PKK(1,3)+PKK(1,4)+S34
        UI=PKK(1,5)+PKK(1,6)+S56
        WT=COUP(1,3)**4*((COUP(3,3)*COUP(5,3)*ABS(FGK(1,2,3,4,5,6)/
     &  TI+FGK(1,2,5,6,3,4)/UI))**2+(COUP(3,4)*COUP(5,3)*ABS(
     &  FGK(1,2,4,3,5,6)/TI+FGK(1,2,5,6,4,3)/UI))**2+(COUP(3,3)*
     &  COUP(5,4)*ABS(FGK(1,2,3,4,6,5)/TI+FGK(1,2,6,5,3,4)/UI))**2+
     &  (COUP(3,4)*COUP(5,4)*ABS(FGK(1,2,4,3,6,5)/TI+FGK(1,2,6,5,4,3)/
     &  UI))**2)+COUP(1,4)**4*((COUP(3,3)*COUP(5,3)*ABS(
     &  FGK(2,1,5,6,3,4)/TI+FGK(2,1,3,4,5,6)/UI))**2+(COUP(3,4)*
     &  COUP(5,3)*ABS(FGK(2,1,6,5,3,4)/TI+FGK(2,1,3,4,6,5)/UI))**2+
     &  (COUP(3,3)*COUP(5,4)*ABS(FGK(2,1,5,6,4,3)/TI+FGK(2,1,4,3,5,6)/
     &  UI))**2+(COUP(3,4)*COUP(5,4)*ABS(FGK(2,1,6,5,4,3)/TI+
     &  FGK(2,1,4,3,6,5)/UI))**2)
        WTMAX=4.*S34*S56*(COUP(1,3)**4+COUP(1,4)**4)*(COUP(3,3)**2+
     &  COUP(3,4)**2)*(COUP(5,3)**2+COUP(5,4)**2)*4.*(TI/UI+UI/TI+
     &  2.*SH*(S34+S56)/(TI*UI)-S34*S56*(1./TI**2+1./UI**2))
 
      ELSEIF(ISUB.EQ.23) THEN
C...ANGULAR WEIGHT FOR Q + QB' -> W+/- + Z0 -> 4 PARTONS/LEPTONS
        D34=P(IREF(IP,IORD),5)**2
        D56=P(IREF(IP,3-IORD),5)**2
        DT=PKK(1,3)+PKK(1,4)+D34
        DU=PKK(1,5)+PKK(1,6)+D56
        CAWZ=COUP(2,3)/SNGL(DT)-2.*(1.-PYPAR(2))*COUP(1,2)/(SH-SQMW)
        CBWZ=COUP(1,3)/SNGL(DU)+2.*(1.-PYPAR(2))*COUP(1,2)/(SH-SQMW)
        WT=COUP(5,3)**2*ABS(CAWZ*FGK(1,2,3,4,5,6)+CBWZ*
     &  FGK(1,2,5,6,3,4))**2+COUP(5,4)**2*ABS(CAWZ*
     &  FGK(1,2,3,4,6,5)+CBWZ*FGK(1,2,6,5,3,4))**2
        WTMAX=4.*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
     &  XIGK(DT,DU)+CBWZ**2*XIGK(DU,DT)+CAWZ*CBWZ*XJGK(DT,DU))
 
      ELSEIF(ISUB.EQ.24) THEN
C...ANGULAR WEIGHT FOR Q + QB -> W+ + W- -> 4 PARTONS/LEPTONS
        D34=P(IREF(IP,IORD),5)**2
        D56=P(IREF(IP,3-IORD),5)**2
        DT=PKK(1,3)+PKK(1,4)+D34
        DU=PKK(1,5)+PKK(1,6)+D56
        CDWW=(COUP(1,3)*SQMZ/(SH-SQMZ)+COUP(1,2))/SH
        CAWW=CDWW+0.5*(COUP(1,2)+1.)/SNGL(DT)
        CBWW=CDWW+0.5*(COUP(1,2)-1.)/SNGL(DU)
        CCWW=COUP(1,4)*SQMZ/(SH-SQMZ)/SH
        WT=ABS(CAWW*FGK(1,2,3,4,5,6)-CBWW*FGK(1,2,5,6,3,4))**2+
     &  CCWW**2*ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))**2
        WTMAX=4.*D34*D56*(CAWW**2*XIGK(DT,DU)+CBWW**2*XIGK(DU,DT)-CAWW*
     &  CBWW*XJGK(DT,DU)+CCWW**2*(XIGK(DT,DU)+XIGK(DU,DT)-XJGK(DT,DU)))
 
      ELSEIF(ISUB.EQ.29) THEN
C...ANGULAR WEIGHT FOR Q + QB -> H0 + Z0 -> H0 + 2 PARTONS/LEPTONS
        WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
     &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
     &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
        WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
     &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
 
      ELSEIF(ISUB.EQ.30) THEN
C...ANGULAR WEIGHT FOR Q + QB' -> H0 + W+/- -> H0 + 2 PARTONS/LEPTONS
        WT=PKK(1,3)*PKK(2,4)
        WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
 
C...OBTAIN CORRECT ANGULAR DISTRIBUTION BY REJECTION TECHNIQUES
      ELSE
        WT=1.
        WTMAX=1.
      ENDIF
      IF(WT.LT.RLU(0)*WTMAX) GOTO 420
 
C...CONSTRUCT MASSIVE FOUR-VECTORS USING ANGLES CHOSEN, MARK DECAYED
C...RESONANCES, ADD DOCUMENTATION LINES, SHOWER EVOLUTION
  500 DO 520 JT=1,2
      IF(KDCY(JT).EQ.0) GOTO 520
      ID=IREF(IP,JT)
      MST(1)=NSD(JT)+1
      MST(2)=NSD(JT)+3
      CALL LUROBO(THE(JT),PHI(JT),P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),
     &P(ID,3)/P(ID,4))
      MST(1)=0
      MST(2)=0
      K(ID,1)=K(ID,1)+20000
      IDOC=IPY(40)
      DO 510 I=NSD(JT)+1,NSD(JT)+3,2
      IPY(40)=IPY(40)+1
      IF(IPY(34).GE.1) K(I+1,2)=1000+IPY(40)
      K(IPY(40),1)=40000+IREF(IP,JT+2)
      K(IPY(40),2)=K(I,2)
      DO 510 J=1,5
  510 P(IPY(40),J)=P(I,J)
      IF(IPY(13).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,
     &NSD(JT)+3,P(ID,5))
 
C...CHECK IF NEW RESONANCES WERE PRODUCED, LOOP BACK IF NEEDED
      IF(KDCY(JT).NE.3) GOTO 520
      NP=NP+1
      IREF(NP,1)=NSD(JT)+1
      IREF(NP,2)=NSD(JT)+3
      IREF(NP,3)=IDOC+1
      IREF(NP,4)=IDOC+2
      IREF(NP,5)=K(IREF(IP,JT),2)
      IREF(NP,6)=IREF(IP,JT)
  520 CONTINUE
  530 IF(IP.LT.NP) GOTO 100
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYDIFF
 
C...HANDLES DIFFRACTIVE AND ELASTIC SCATTERING
      COMMON/LUJETS/N,K(2000,2),P(2000,5)
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
 
C...STORE INCOMING PARTICLES, RESET P VECTORS
      N=20
      IPY(40)=4
      DO 100 I=1,2
      K(I,1)=40000
      K(I,2)=IPY(40+I)
      P(I,1)=0.
      P(I,2)=0.
      P(I,5)=PYVAR(2+I)
      P(I,3)=PYVAR(5)*(-1)**(I+1)
  100 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
      IPY(46)=2
      DO 110 I=3,30
      K(I,1)=80000
      K(I,2)=0
      DO 110 J=1,5
  110 P(I,J)=0.
 
C...SUBPROCESS; KINEMATICS:
      ISUB=IPY(44)
      SQLAM=(PYVAR(2)-PYVAR(14)-PYVAR(15))**2-4.*PYVAR(14)*PYVAR(15)
      PZ=SQRT(SQLAM)/(2.*PYVAR(1))
      DO 130 I=1,2
      PE=(PYVAR(2)+PYVAR(13+I)-PYVAR(16-I))/(2.*PYVAR(1))
 
C...ELASTICALLY SCATTERED PARTICLE
      IF(IPY(50+I).EQ.0) THEN
        N=N+1
        K(N,1)=0
        IF(IPY(34).GE.1) K(N,1)=I+2
        K(N,2)=K(I,2)
        P(N,3)=PZ*(-1)**(I+1)
        P(N,4)=PE
        P(N,5)=P(I,5)
 
C...DIFFRACTED PARTICLE: VALENCE QUARK KICKED OUT
      ELSEIF(IPY(18).EQ.1) THEN
        N=N+2
        K(N-1,1)=10000
        K(N,1)=0
        IF(IPY(34).GE.1) K(N-1,1)=K(N-1,1)+I+2
        IF(IPY(34).GE.1) K(N,1)=K(N,1)+I+2
        CALL PYSPLI(K(I,2),500,K(N,2),K(N-1,2))
        P(N-1,5)=ULMASS(0,K(N-1,2))
        P(N,5)=ULMASS(0,K(N,2))
        SQLAM=(PYVAR(13+I)-P(N-1,5)**2-P(N,5)**2)**2-
     &  4.*P(N-1,5)**2*P(N,5)**2
        P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(PYVAR(13+I)+P(N-1,5)**2-
     &  P(N,5)**2))/(2.*PYVAR(13+I))*(-1)**(I+1)
        P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
        P(N,3)=PZ*(-1)**(I+1)-P(N-1,3)
        P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
 
C...DIFFRACTED PARTICLE: GLUON KICKED OUT
      ELSE
        N=N+3
        K(N-2,1)=10000
        K(N-1,1)=10000
        K(N,1)=0
        IF(IPY(34).GE.1) K(N-2,1)=K(N-2,1)+I+2
        IF(IPY(34).GE.1) K(N-1,1)=K(N-1,1)+I+2
        IF(IPY(34).GE.1) K(N,1)=K(N,1)+I+2
        CALL PYSPLI(K(I,2),500,K(N,2),K(N-2,2))
        K(N-1,2)=500
        P(N-2,5)=ULMASS(0,K(N-2,2))
        P(N-1,5)=0.
        P(N,5)=ULMASS(0,K(N,2))
  120   CALL PYCHID(K(I,2),K(N,2),CHI)
        IF(CHI.LT.P(N,5)**2/PYVAR(13+I).OR.CHI.GT.1.-P(N-2,5)**2/
     &  PYVAR(13+I)) GOTO 120
        SQM=P(N-2,5)**2/(1.-CHI)+P(N,5)**2/CHI
        IF((SQRT(SQM)+PAR(22))**2.GE.PYVAR(13+I)) GOTO 120
        PZI=(PE*(PYVAR(13+I)-SQM)+PZ*(PYVAR(13+I)+SQM))/
     &  (2.*PYVAR(13+I))
        PEI=SQRT(PZI**2+SQM)
        PQQP=(1.-CHI)*(PEI+PZI)
        P(N-2,3)=0.5*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(I+1)
        P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
        P(N-1,3)=(PZ-PZI)*(-1)**(I+1)
        P(N-1,4)=ABS(P(N-1,3))
        P(N,3)=PZI*(-1)**(I+1)-P(N-2,3)
        P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
      ENDIF
 
C...DOCUMENTATION LINES
      K(I+2,1)=40000+I
      IF(IPY(50+I).EQ.0) K(I+2,2)=IPY(40+I)
      IF(IPY(50+I).NE.0) K(I+2,2)=ISIGN(38+I,IPY(40+I))
      P(I+2,3)=PZ*(-1)**(I+1)
      P(I+2,4)=PE
      P(I+2,5)=SQRT(PYVAR(13+I))
  130 CONTINUE
 
C...ROTATE OUTGOING PARTONS/PARTICLES USING COS(THETA)
      MST(1)=3
      CALL LUROBO(ACOS(PYVAR(20)),PAR(72)*RLU(0),0.,0.,0.)
      MST(1)=0
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYFRAM(IFRAME)
 
C...PERFORMS TRANSFORMATIONS BETWEEN DIFFERENT COORDINATE FRAMES.
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
 
      IF(IFRAME.LT.1.OR.IFRAME.GT.2) THEN
        WRITE(MST(20),1000) IFRAME,IPY(46)
        RETURN
      ENDIF
      IF(IFRAME.EQ.IPY(46)) RETURN
 
      IF(IPY(46).EQ.1) THEN
C...TRANSFORM FROM FIXED TARGET OR USER SPECIFIED FRAME TO
C...CM-FRAME OF INCOMING PARTICLES.
        CALL LUROBO(0.,0.,-PYVAR(8),-PYVAR(9),-PYVAR(10))
        CALL LUROBO(0.,-PYVAR(7),0.,0.,0.)
        CALL LUROBO(-PYVAR(6),0.,0.,0.,0.)
        IPY(46)=2
 
      ELSE
C...TRANSFORM FROM PARTICLE CM-FRAME TO FIXED TARGET OR USER SPECIFIED
C...FRAME.
        CALL LUROBO(PYVAR(6),PYVAR(7),PYVAR(8),PYVAR(9),PYVAR(10))
        IPY(46)=1
      ENDIF
 
 1000 FORMAT(1X,'ERROR: ILLEGAL VALUES IN SUBROUTINE PYFRAM.',1X,
     &'NO TRANSFORMATION PERFORMED.'/1X,'IFRAME =',1X,I5,'; IPY(46) =',
     &1X,I5)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYDSIG(TAU,XF,XT2,DSIGS)
 
C...DIFFERENTIAL MATRIX ELEMENTS FOR ALL INCLUDED SUBPROCESSES.
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYCROS/XMAX(0:40),NGEN(0:40,3),XPRI(0:40),VMAX
      COMMON/PYINT1/XQ(2,-6:6),DSIG(-6:6,-6:6,5),FSIG(10,10,3)
      COMMON/PYINT2/KPR(-6:6,-6:6),NMX(6),ICOL(40,4,2),ICH(30),VKM2(4,4)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
      DIMENSION DSIGH(6,5),XPQ(-6:6)
 
C...COMMON CONSTANTS; RESET MATRIX ELEMENTS
      IGRP=IPY(44)
      DO 100 I1=1,6
      DO 100 I2=1,5
  100 DSIGH(I1,I2)=0.
      DO 110 I1=-6,6
      DO 110 I2=-6,6
      DO 110 I3=1,5
  110 DSIG(I1,I2,I3)=0.
      DSIGS=0.
      DO 120 I1=1,10
      DO 120 I2=1,10
      DO 120 I3=1,3
  120 FSIG(I1,I2,I3)=0.
      FSIGS=0.
 
      IF(IGRP.LE.7.OR.IGRP.GE.11) THEN
C...CALCULATE PARTON STRUCTURE FUNCTIONS AND ALPHA-STRONG
        DO 130 I=1,2
        IF(IGRP.EQ.5) X(I)=X(I)/PYVAR(34+I)
        CALL PYSTFU(IPY(40+I),X(I),Q2,XPQ)
        IF(IGRP.EQ.5) X(I)=X(I)*PYVAR(34+I)
        DO 130 IFL=-6,6
  130   XQ(I,IFL)=XPQ(IFL)
        PYVAR(23)=PYALPH(Q2)
        RADC=1.+PYVAR(23)/PAR(71)
      ENDIF
 
C...COMMON CONVERSION FACTORS (INCLUDING JACOBIAN) FOR SUBPROCESSES
      SH2=SH**2
      TH2=TH**2
      UH2=UH**2
      SQM1=PYVAR(14)
      SQM2=PYVAR(15)
      SQMZ=PMAS(2)**2
      SQMW=PMAS(3)**2
      SQMH=PMAS(4)**2
      SQMR=PMAS(91)**2
      SQMHC=PMAS(92)**2
      SQMZP=PMAS(93)**2
      AS=PYVAR(23)
      AEM=PYPAR(1)
      XW=PYPAR(2)
      CONV=PYPAR(35)*PAR(71)
      IF(ISET(IGRP).EQ.1) THEN
C...2 -> 2 PROCESSES; PRE-WEIGHTED WITH LN(TAU)/LN(TAUMIN)*(THU-THL)/SH:
        TAUMIN=PYVAR(16)
        THL=PYVAR(17)
        THU=PYVAR(18)
        H1=1.+(-ALOG(TAUMIN))*TAUMIN/(1.-TAUMIN)*(COEF(IGRP,1)/TAU+
     &  2.*TAUMIN/(1.+TAUMIN)*COEF(IGRP,2)/TAU**2)
        H2=1.+(-ALOG(TAU))*SQRT(TAU)/ATAN((1.-TAU)/(2.*SQRT(TAU)))*
     &  COEF(IGRP,3)/SQRT(XF**2+4.*TAU)
        IF((THU-THL)/SH.GT.1.E-04) THEN
          H3=1.+(THU-THL)/ALOG(THU/THL)*(COEF(IGRP,5)/TH+
     &    COEF(IGRP,6)/UH)+THU*THL*(COEF(IGRP,7)/TH2+COEF(IGRP,8)/UH2)
        ELSE
          H3=1.+COEF(IGRP,5)+COEF(IGRP,6)+COEF(IGRP,7)+COEF(IGRP,8)
        ENDIF
        COMFAC=CONV*(1.+COEF(IGRP,1)+COEF(IGRP,2))*(1.+COEF(IGRP,3))*
     &  (1.+COEF(IGRP,5)+COEF(IGRP,6)+COEF(IGRP,7)+COEF(IGRP,8))/SH*
     &  (-ALOG(TAUMIN))**2/(H1*H2*H3)
      ELSEIF(ISET(IGRP).EQ.2.OR.ISET(IGRP).EQ.3) THEN
C...RESONANCE PRODUCTION; PRE-WEIGHTED WITH LN(TAU)/LN(TAUMIN):
        TAUMIN=PYVAR(16)
        SQM=WM(IGRP,1)**2
        GM=WM(IGRP,1)*WM(IGRP,3)
        TAUR=SQM/PYVAR(2)
        S1=ALOG((TAUR+TAUMIN)/((TAUR+1.)*TAUMIN))
        S2=(1.-TAUMIN)/TAUMIN
        S3=GM/PYVAR(2)*(ATAN((PYVAR(2)-SQM)/GM)-
     &  ATAN((PYVAR(2)*TAUMIN-SQM)/GM))
        H1=COEF(IGRP,1)/S1*TAUR/(TAU*(TAUR+TAU))+COEF(IGRP,2)/S2*
     &  1./TAU**2+COEF(IGRP,3)/S3*GM**2/((PYVAR(2)*TAU-SQM)**2+GM**2)
        IF(IGRP.EQ.33) THEN
          SQMP=WM(IGRP,2)**2
          GMP=WM(IGRP,2)*WM(IGRP,4)
          TAURP=SQMP/PYVAR(2)
          S5=ALOG((TAURP+TAUMIN)/((TAURP+1.)*TAUMIN))
          S6=GMP/PYVAR(2)*(ATAN((PYVAR(2)-SQMP)/GMP)-
     &    ATAN((PYVAR(2)*TAUMIN-SQMP)/GMP))
          H1=H1+COEF(IGRP,5)/S5*TAURP/(TAU*(TAURP+TAU))+COEF(IGRP,6)/S6*
     &    GMP**2/((PYVAR(2)*TAU-SQMP)**2+GMP**2)
        ENDIF
        COMFAC=CONV*PYPAR(6)*(COEF(IGRP,1)+COEF(IGRP,2)+COEF(IGRP,3)+
     &  COEF(IGRP,5)+COEF(IGRP,6))*PYVAR(2)/SH2*(-ALOG(TAUMIN))/H1*
     &  MAX(1.E-20,SQRT(1.-4.*PYVAR(12)/SH))
        IF(ISET(IGRP).EQ.3) COMFAC=COMFAC*(1.-PYVAR(12)/SH)
      ELSEIF(ISET(IGRP).EQ.4) THEN
C...LOW-PT AND MULTIPLE INTERACTIONS:
        H1=1.+ALOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)*SQRT(XT2)/
     &  (2.*(ATAN(1./XT2-1.)))*COEF(IGRP,1)/SQRT(TAU)
        H2=1.+(-ALOG(TAU))*SQRT(TAU)/ATAN((1.-TAU)/(2.*SQRT(TAU)))*
     &  COEF(IGRP,3)/SQRT(XF**2+4.*TAU)
        COMFAC=CONV*(1.+COEF(IGRP,1))*(1.+COEF(IGRP,3))*0.5*PYVAR(2)/
     &  SH2*(-ALOG(TAU))*ALOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)/(H1*H2)
        IF(IPY(12).LE.1) COMFAC=COMFAC*XT2**2*(1./PYVAR(13)-1.)
C...FOR IPY(12)>=2 AN ADDITIONAL FACTOR (XT2/(XT2+PYVAR(13))**2 IS
C...INTRODUCED TO MAKE CROSS SECTION FINITE FOR XT2 -> 0.
        IF(IPY(12).GE.2) COMFAC=COMFAC*XT2**2/(PYVAR(13)*
     &  (1.+PYVAR(13)))
      ELSEIF(ISET(IGRP).EQ.8) THEN
C...HIGGS PRODUCTION VIA INTERMEDIATE VECTOR BOSON FUSION:
        HMIN=PYVAR(26)
        H=PYVAR(25)
        SHH0=H*PYVAR(2)
        TAUMIN=PYVAR(16)
        HM=WM(IGRP,1)**2/PYVAR(2)
        HG=WM(IGRP,1)*WM(IGRP,3)/PYVAR(2)
        S1=ALOG((1.+HM/HMIN)/(1.+HM))/HM
        S2=-ALOG(HMIN)
        S3=(ATAN((1.-HM)/HG)-ATAN((HMIN-HM)/HG))/HG
        H1=COEF(IGRP,1)/S1*1./(H*(H+HM))+COEF(IGRP,2)/S2*1./H+
     &  COEF(IGRP,3)/S3*1./((H-HM)**2+HG**2)
        H2=COEF(IGRP,5)+4.*(-ALOG(H))*H/(1-H)**4*COEF(IGRP,6)*
     &  (1-H/TAU)**3/TAU
        IF(1.-H/TAU.GT.1.E-4) THEN
          F1=(1.+H/TAU)*ALOG(TAU/H)-2.*(1.-H/TAU)
        ELSE
          F1=1./6.*(1.-H/TAU)**3*H/TAU
        ENDIF
        COMFAC=CONV*(COEF(IGRP,1)+COEF(IGRP,2)+COEF(IGRP,3))*
     &  (COEF(IGRP,5)+COEF(IGRP,6))/(128.*PAR(71)**2*PYVAR(2))*
     &  (AEM/XW)**4*(SHH0/SQMW)**2*(-ALOG(H))*(-ALOG(TAU))/
     &  ((H-HM)**2+HG**2)*F1/(H1*H2)*
     &  MAX(1.E-20,SQRT(MAX(0.,1.-4.*PYVAR(12)/SHH0)))
      ENDIF
      IF(IGRP.GE.8) GOTO 180
 
C...QCD: CALCULATE FLAVOUR SUPPRESSION AND COMMON FACTORS
      DO 140 I=1,2*IPY(9)
      IF(IPROD(1,I).EQ.0) GOTO 140
      RMQ=PMAS(100+I)**2/SH
      FSIG(I,I,1)=(1.+2.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))
      FSIGS=FSIGS+FSIG(I,I,1)
  140 CONTINUE
      FACST=PYPAR(6)*AS**2
      FACAN=FACST
 
      IF(IPY(10).LE.1) THEN
C...QCD MATRIX ELEMENTS FOR DIFFERENT COLOUR FLOWS (INTERFERENCE TERMS
C...NEGLECTED)
C...Q + Q' -> Q + Q' (A)
        DSIGH(1,1)=FACST*4./9.*(SH2+UH2)/TH2
        DSIGH(2,1)=DSIGH(1,1)
C...Q + Q -> Q + Q (B)
        DSIGH(2,2)=FACST*4./9.*(SH2+TH2)/UH2
C...Q + QB' -> Q + QB' (A)
        DSIGH(3,1)=FACAN*4./9.*(SH2+UH2)/TH2
        DSIGH(4,1)=DSIGH(3,1)
C...Q + QB -> Q' + QB' (B)
        DSIGH(4,2)=FACST*4./9.*(TH2+UH2)/SH2*FSIGS
C...Q + QB -> G + G (A)
        DSIGH(4,3)=FACST*32./27.*(UH/TH-2.*UH2/SH2)
C...Q + QB -> G + G (B)
        DSIGH(4,4)=FACST*32./27.*(TH/UH-2.*TH2/SH2)
C...G + Q -> G + Q (A)
        DSIGH(5,1)=FACAN*4./9.*(2.*UH2/TH2-UH/SH)
C...G + Q -> G + Q (B)
        DSIGH(5,2)=FACST*4./9.*(2.*SH2/TH2-SH/UH)
C...G + G -> Q + QB (A)
        DSIGH(6,1)=FACAN*1./6.*(UH/TH-2.*UH2/SH2)*FSIGS
C...G + G -> Q + QB (B)
        DSIGH(6,2)=FACAN*1./6.*(TH/UH-2.*TH2/SH2)*FSIGS
C...G + G -> G + G (A1+A2)
        DSIGH(6,3)=FACAN*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+TH2/SH2)
C...G + G -> G + G (B1+B2)
        DSIGH(6,4)=FACAN*9./4.*(SH2/UH2+2.*SH/UH+3.+2.*UH/SH+UH2/SH2)
C...G + G -> G + G (C1+C2)
        DSIGH(6,5)=FACST*9./4.*(UH2/TH2+2.*UH/TH+3.+2.*TH/UH+TH2/UH2)
 
      ELSE
C...STANDARD QCD MATRIX ELEMENTS (INTERFERENCE TERMS INCLUDED)
C...Q + Q' -> Q + Q' (A)
        DSIGH(1,1)=FACST*4./9.*(SH2+UH2)/TH2
        DSIGH(2,1)=DSIGH(1,1)
C...Q + Q -> Q + Q (B)
        DSIGH(2,2)=FACST*(4./9.*(SH2+TH2)/UH2-8./27.*SH2/(TH*UH))
C...Q + QB' -> Q + QB' (A)
        DSIGH(3,1)=FACAN*4./9.*(SH2+UH2)/TH2
        DSIGH(4,1)=DSIGH(3,1)-FACST*8./27.*UH2/(SH*TH)
C...Q + QB -> Q' + QB' (B)
        DSIGH(4,2)=FACST*4./9.*(TH2+UH2)/SH2*FSIGS
C...Q + QB -> G + G (A)
        DSIGH(4,3)=FACST*(32./27.*UH/TH-8./3.*UH2/SH2)
C...Q + QB -> G + G (B)
        DSIGH(4,4)=FACST*(32./27.*TH/UH-8./3.*TH2/SH2)
C...G + Q -> G + Q (A)
        DSIGH(5,1)=FACAN*(UH2/TH2-4./9.*UH/SH)
C...G + Q -> G + Q (B)
        DSIGH(5,2)=FACST*(SH2/TH2-4./9.*SH/UH)
C...G + G -> Q + QB (A)
        DSIGH(6,1)=FACAN*(1./6.*UH/TH-3./8.*UH2/SH2)*FSIGS
C...G + G -> Q + QB (B)
        DSIGH(6,2)=FACAN*(1./6.*TH/UH-3./8.*TH2/SH2)*FSIGS
C...G + G -> G + G (A1+A2)
        DSIGH(6,3)=FACAN*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+TH2/SH2)
C...G + G -> G + G (B1+B2)
        DSIGH(6,4)=FACAN*9./4.*(SH2/UH2+2.*SH/UH+3.+2.*UH/SH+UH2/SH2)
C...G + G -> G + G (C1+C2)
        DSIGH(6,5)=FACST*9./4.*(UH2/TH2+2.*UH/TH+3.+2.*TH/UH+TH2/UH2)
      ENDIF
 
C...INCLUDE FACTOR 1/2! FOR PROCESSES WITH TWO IDENTICAL PARTONS IN THE
C...FINAL STATE
C...Q + Q -> Q + Q: SCATTERING OF IDENTICAL QUARKS (OR ANTIQUARKS)
      DSIGH(2,1)=0.5*DSIGH(2,1)
      DSIGH(2,2)=0.5*DSIGH(2,2)
C...Q + QB -> G + G: QUARK-ANTIQUARK ANNIHILATION INTO GLUONS
      DSIGH(4,3)=0.5*DSIGH(4,3)
      DSIGH(4,4)=0.5*DSIGH(4,4)
C...G + G -> G + G: GLUON-GLUON SCATTERING
      DSIGH(6,3)=0.5*DSIGH(6,3)
      DSIGH(6,4)=0.5*DSIGH(6,4)
      DSIGH(6,5)=0.5*DSIGH(6,5)
 
C...RESET CROSS-SECTION FOR EXCLUDED SUBPROCESSES
      IF(IGRP.NE.5) THEN
        IF(ISUBPR(1).EQ.0) DSIGH(1,1)=0.
        IF(ISUBPR(1).EQ.0) DSIGH(2,1)=0.
        IF(ISUBPR(1).EQ.0) DSIGH(2,2)=0.
        IF(ISUBPR(1).EQ.0) DSIGH(3,1)=0.
        IF(ISUBPR(1).EQ.0) DSIGH(4,1)=0.
        IF(ISUBPR(2).EQ.0) DSIGH(4,2)=0.
        IF(ISUBPR(3).EQ.0) DSIGH(4,3)=0.
        IF(ISUBPR(3).EQ.0) DSIGH(4,4)=0.
        IF(ISUBPR(4).EQ.0) DSIGH(5,1)=0.
        IF(ISUBPR(4).EQ.0) DSIGH(5,2)=0.
        IF(ISUBPR(5).EQ.0) DSIGH(6,1)=0.
        IF(ISUBPR(5).EQ.0) DSIGH(6,2)=0.
        IF(ISUBPR(6).EQ.0) DSIGH(6,3)=0.
        IF(ISUBPR(6).EQ.0) DSIGH(6,4)=0.
        IF(ISUBPR(6).EQ.0) DSIGH(6,5)=0.
      ENDIF
 
C...CALCULATE DIFFERENTIAL CROSS-SECTIONS FOR INCLUDED QCD SUBPROCESSES
      DO 170 I=-IPY(8),IPY(8)
      IF(IREAC(1,I).EQ.0.AND.IGRP.NE.5) GOTO 170
      IF(XQ(1,I).LT.1.E-20) GOTO 170
      DO 160 J=-IPY(8),IPY(8)
      IF(IREAC(2,J).EQ.0.AND.IGRP.NE.5) GOTO 160
      IF(XQ(2,J).LT.1.E-20) GOTO 160
      IJ=KPR(I,J)
      DO 150 L=1,NMX(IJ)
      DSIG(I,J,L)=COMFAC*XQ(1,I)*XQ(2,J)*DSIGH(IJ,L)
      DSIGS=DSIGS+DSIG(I,J,L)
  150 CONTINUE
  160 CONTINUE
  170 CONTINUE
      PYVAR(45)=FSIGS
      RETURN
 
  180 CONTINUE
C...NON-QCD PROCESSES
      IF(IGRP.GE.8.AND.IGRP.LE.10) THEN
C...DOUBLE AND SINGLE DIFFRACTIVE SCATTERING, ELASTIC SCATTERING:
        DSIGS=XMAX(IGRP)
 
      ELSEIF(IGRP.EQ.11) THEN
C...Q + QB -> Z0/GAM*
        FSGG=0.
        FSZZ=0.
        FSZG=0.
        DO 190 I=1,2*IPY(9)
        IF(IPROD(2,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SH) THEN
          RMQ=PMAS(100+I)**2/SH
          EF=ICH(I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          FSGG=FSGG+3.*EF**2*(1.+2.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSZZ=FSZZ+3.*(VF**2*(1.+2.*RMQ)+AF**2*(1.-4.*RMQ))*
     &    SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSZG=FSZG+3.*EF*VF*(1.+2.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
        ENDIF
        IF(IPROD(2,10+I).EQ.1.AND.4.*PMAS(6+I)**2.LT.SH) THEN
          RML=PMAS(6+I)**2/SH
          EF=ICH(10+I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          FSGG=FSGG+EF**2*(1.+2.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSZZ=FSZZ+(VF**2*(1.+2.*RML)+AF**2*(1.-4.*RML))*
     &    SQRT(MAX(0.,1.-4.*RML))
          FSZG=FSZG+EF*VF*(1.+2.*RML)*SQRT(MAX(0.,1.-4.*RML))
        ENDIF
  190   CONTINUE
        IF(IPROD(2,23).EQ.1.AND.4.*PMAS(92)**2.LT.SH) THEN
          RMB=PMAS(92)**2/SH
          CF=2.*(1.-2.*XW)
          FSGG=FSGG+0.25*(1.-4.*RMB)*SQRT(MAX(0.,1.-4.*RMB))*
     &    PYVAR(66)**2
          FSZZ=FSZZ+0.25*CF**2*(1.-4.*RMB)*SQRT(MAX(0.,1.-4.*RMB))*
     &    PYVAR(66)**2
          FSZG=FSZG+0.25*CF*(1.-4.*RMB)*SQRT(MAX(0.,1.-4.*RMB))*
     &    PYVAR(66)**2
        ENDIF
        IF(IPY(11).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
          FSZZ=0.
          FSZG=0.
        ELSEIF(IPY(11).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED:
          FSGG=0.
          FSZG=0.
        ENDIF
        FACZ=COMFAC*AEM**2*4./9.
        DO 200 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 200
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 200
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 200
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        DSIG(I,-I,1)=FACZ*(EI**2*FSGG+(VI**2+AI**2)/(16.*XW*(1.-XW))**2*
     &  SH2/((SH-SQM)**2+GM**2)*FSZZ+EI*VI/(8.*XW*(1.-XW))*SH*(SH-SQM)/
     &  ((SH-SQM)**2+GM**2)*FSZG)*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  200   CONTINUE
 
      ELSEIF(IGRP.EQ.12) THEN
C...Q + QB' -> W+/-
        DO 210 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        IF(IPROD(3,10+IL).EQ.1.AND.IPROD(3,10+IU).EQ.1.AND.
     &  (PMAS(6+IL)+PMAS(6+IU))**2.LT.SH) THEN
          RMLL=PMAS(6+IL)**2/SH
          RMLU=PMAS(6+IU)**2/SH
          FSIG(IL,IU,2)=(1.-RMLL-RMLU)*(2.+RMLL+RMLU)*
     &    SQRT(MAX(0.,(1.-RMLL-RMLU)**2-4.*RMLL*RMLU))
          FSIGS=FSIGS+FSIG(IL,IU,2)
        ENDIF
        IF(IL.EQ.1) IL=2
        DO 210 J=1,IPY(9)
        JU=2*J
        IF(JU.EQ.2) JU=1
        IF(IPROD(3,IL).EQ.1.AND.IPROD(3,JU).EQ.1.AND.
     &  (PMAS(100+IL)+PMAS(100+JU))**2.LT.SH) THEN
          RMQI=PMAS(100+IL)**2/SH
          RMQJ=PMAS(100+JU)**2/SH
          FSIG(IL,JU,1)=3.*(1.-RMQI-RMQJ)*(2.+RMQI+RMQJ)*
     &    SQRT(MAX(0.,(1.-RMQI-RMQJ)**2-4.*RMQI*RMQJ))*VKM2(I,J)*RADC
          FSIGS=FSIGS+FSIG(IL,JU,1)
        ENDIF
  210   CONTINUE
        FACW=COMFAC*(AEM/XW)**2*1./72*SH2/((SH-SQM)**2+GM**2)*FSIGS
        DO 230 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 230
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        DO 220 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(2,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 220
        JA=IABS(J)
        IF(JA.LE.2) JA=3-JA
        IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 220
        DSIG(I,J,1)=FACW*VKM2((IA+1)/2,(JA+1)/2)*XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  220   CONTINUE
  230   CONTINUE
 
      ELSEIF(IGRP.EQ.13) THEN
C...G + Q -> GAM + Q
        FGQ=COMFAC*PYPAR(6)*AS*AEM*1./3.*(SH2+UH2)/(-SH*UH)
        DO 250 I=-IPY(8),IPY(8)
        EI=ICH(IABS(I))/3.
        IF(I.EQ.0) GOTO 250
        FACGQ=FGQ*EI**2
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 240
        IF(IREAC(2,0).EQ.0.OR.XQ(2,0).LT.1.E-20) GOTO 240
        DSIG(I,0,1)=FACGQ*XQ(1,I)*XQ(2,0)
        DSIGS=DSIGS+DSIG(I,0,1)
  240   IF(IREAC(1,0).EQ.0.OR.XQ(1,0).LT.1.E-20) GOTO 250
        IF(IREAC(2,I).EQ.0.OR.XQ(2,I).LT.1.E-20) GOTO 250
        DSIG(0,I,1)=FACGQ*XQ(1,0)*XQ(2,I)
        DSIGS=DSIGS+DSIG(0,I,1)
  250   CONTINUE
 
      ELSEIF(IGRP.EQ.14) THEN
C...G + Q -> Z0 + Q
        FZQ=COMFAC*PYPAR(6)*AS*AEM/(XW*(1.-XW))*1./48.*
     &  (SH2+UH2+2.*SQM1*TH)/(-SH*UH)
        FZQ=FZQ*PYVAR(62)
        DO 270 I=-IPY(8),IPY(8)
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        IF(I.EQ.0) GOTO 270
        FACZQ=FZQ*(VI**2+AI**2)
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 260
        IF(IREAC(2,0).EQ.0.OR.XQ(2,0).LT.1.E-20) GOTO 260
        DSIG(I,0,1)=FACZQ*XQ(1,I)*XQ(2,0)
        DSIGS=DSIGS+DSIG(I,0,1)
  260   IF(IREAC(1,0).EQ.0.OR.XQ(1,0).LT.1.E-20) GOTO 270
        IF(IREAC(2,I).EQ.0.OR.XQ(2,I).LT.1.E-20) GOTO 270
        DSIG(0,I,1)=FACZQ*XQ(1,0)*XQ(2,I)
        DSIGS=DSIGS+DSIG(0,I,1)
  270   CONTINUE
 
      ELSEIF(IGRP.EQ.15) THEN
C...G + Q -> W+/- + Q'
        FACWQ=COMFAC*PYPAR(6)*AS*AEM/XW*1./12.*
     &  (SH2+UH2+2.*SQM1*TH)/(-SH*UH)
        FACWQ=FACWQ*PYVAR(63)
        DO 310 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 310
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 290
        IF(IREAC(2,0).EQ.0.OR.XQ(2,0).LT.1.E-20) GOTO 290
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        FSIGS1=0.
        DO 280 J=1,IPY(9)
        JA=2*J-1+MOD(IA,2)
        IF(JA.LE.2) JA=3-JA
  280   IF(IPROD(0,JA).EQ.1) FSIGS1=FSIGS1+VKM2((IA+1)/2,(JA+1)/2)
        DSIG(I,0,1)=DSIG(I,0,1)+FACWQ*FSIGS1*XQ(1,I)*XQ(2,0)
        DSIGS=DSIGS+DSIG(I,0,1)
  290   IF(IREAC(1,0).EQ.0.OR.XQ(1,0).LT.1.E-20) GOTO 310
        IF(IREAC(2,I).EQ.0.OR.XQ(2,I).LT.1.E-20) GOTO 310
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        FSIGS2=0.
        DO 300 J=1,IPY(9)
        JA=2*J-1+MOD(IA,2)
        IF(JA.LE.2) JA=3-JA
  300   IF(IPROD(0,JA).EQ.1) FSIGS2=FSIGS2+VKM2((IA+1)/2,(JA+1)/2)
        DSIG(0,I,1)=DSIG(0,I,1)+FACWQ*FSIGS2*XQ(1,0)*XQ(2,I)
        DSIGS=DSIGS+DSIG(0,I,1)
  310   CONTINUE
 
      ELSEIF(IGRP.EQ.16) THEN
C...Q + QB -> GAM + G
        FACGG=COMFAC*AS*AEM*8./9.*(TH2+UH2)/(TH*UH)
        DO 320 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 320
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 320
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 320
        EI=ICH(IABS(I))/3.
        DSIG(I,-I,1)=FACGG*EI**2*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  320   CONTINUE
 
      ELSEIF(IGRP.EQ.17) THEN
C...Q + QB -> Z0 + G
        FACZG=COMFAC*AS*AEM/(XW*(1.-XW))*1./18.*
     &  (TH2+UH2+2.*SQM1*SH)/(TH*UH)
        FACZG=FACZG*PYVAR(62)
        DO 330 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 330
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 330
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 330
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        DSIG(I,-I,1)=FACZG*(VI**2+AI**2)*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  330   CONTINUE
 
      ELSEIF(IGRP.EQ.18) THEN
C...Q + QB' -> W+/- + G
        FACWG=COMFAC*AS*AEM/XW*2./9.*(TH2+UH2+2.*SQM1*SH)/(TH*UH)
        FACWG=FACWG*PYVAR(63)
        DO 350 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 350
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        DO 340 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(2,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 340
        JA=IABS(J)
        IF(JA.LE.2) JA=3-JA
        IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
        DSIG(I,J,1)=FACWG*VKM2((IA+1)/2,(JA+1)/2)*XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  340   CONTINUE
  350   CONTINUE
 
      ELSEIF(IGRP.EQ.19) THEN
C...Q + QB -> GAM + GAM
        FACGG=COMFAC*PYPAR(6)*AEM**2*1./3.*(TH2+UH2)/(TH*UH)
        DO 360 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 360
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 360
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 360
        EI=ICH(IABS(I))/3.
        DSIG(I,-I,1)=FACGG*EI**4*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  360   CONTINUE
 
      ELSEIF(IGRP.EQ.20) THEN
C...Q + QB -> GAM + Z0
        FACGZ=COMFAC*PYPAR(6)*AEM**2/(XW*(1.-XW))*1./24.*
     &  (TH2+UH2+2.*SQM2*SH)/(TH*UH)
        FACGZ=FACGZ*PYVAR(62)
        DO 370 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 370
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 370
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 370
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        DSIG(I,-I,1)=FACGZ*EI**2*(VI**2+AI**2)*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  370   CONTINUE
      ENDIF
 
      IF(IGRP.EQ.21) THEN
C...Q + QB' -> GAM + W+/-
        FACGW=COMFAC*PYPAR(6)*AEM**2/XW*1./6.*
     &  ((2.*UH-TH)/(3.*(SH-SQM2)))**2*(TH2+UH2+2.*SQM2*SH)/(TH*UH)
        FACGW=FACGW*PYVAR(63)
        DO 390 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 390
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        DO 380 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(2,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 380
        JA=IABS(J)
        IF(JA.LE.2) JA=3-JA
        IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
        DSIG(I,J,1)=FACGW*VKM2((IA+1)/2,(JA+1)/2)*XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  380   CONTINUE
  390   CONTINUE
 
      ELSEIF(IGRP.EQ.22) THEN
C...Q + QB -> Z0 + Z0
        FACZZ=COMFAC*PYPAR(6)*(AEM/(XW*(1.-XW)))**2*1./768.*
     &  (UH/TH+TH/UH+2.*(SQM1+SQM2)*SH/(TH*UH)-
     &  SQM1*SQM2*(1./TH2+1./UH2))
        FACZZ=FACZZ*PYVAR(62)**2
        DO 400 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 400
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 400
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 400
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        DSIG(I,-I,1)=FACZZ*(VI**4+6.*VI**2*AI**2+AI**4)*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  400   CONTINUE
 
      ELSEIF(IGRP.EQ.23) THEN
C...Q + QB' -> Z0 + W+/-
        FACZW=COMFAC*PYPAR(6)*(AEM/XW)**2*1./6.
        FACZW=FACZW*PYVAR(62)*PYVAR(63)
        THUH=MAX(TH*UH-SQM1*SQM2,SH*PYVAR(12))
        DO 420 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 420
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        DO 410 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(2,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 410
        JA=IABS(J)
        IF(JA.LE.2) JA=3-JA
        IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        EJ=ICH(IABS(J))/3.
        AJ=SIGN(1.,EJ)
        VJ=AJ-4.*EJ*XW
        IF(VI+AI.GT.0) THEN
          VISAV=VI
          AISAV=AI
          VI=VJ
          AI=AJ
          VJ=VISAV
          AJ=AISAV
        ENDIF
        DSIG(I,J,1)=FACZW*VKM2((IA+1)/2,(JA+1)/2)*(1./(SH-SQMW)**2*
     &  ((9.-8.*XW)/4.*THUH+(8.*XW-6.)/4.*SH*(SQM1+SQM2))+
     &  (THUH-SH*(SQM1+SQM2))/(2.*(SH-SQMW))*((VJ+AJ)/TH-(VI+AI)/UH)+
     &  THUH/(16.*(1.-XW))*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
     &  SH*(SQM1+SQM2)/(8.*(1.-XW))*(VI+AI)*(VJ+AJ)/(TH*UH))*
     &  XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  410   CONTINUE
  420   CONTINUE
 
      ELSEIF(IGRP.EQ.24) THEN
C...Q + QB -> W+ + W-
        FACWW=COMFAC*PYPAR(6)*(AEM/XW)**2*1./12.
        FACWW=FACWW*PYVAR(63)**2
        THUH=MAX(TH*UH-SQM1*SQM2,SH*PYVAR(12))
        DO 430 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 430
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 430
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 430
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        DSIGWW=THUH/SH2*(3.-(SH-3.*(SQM1+SQM2))/(SH-SQMZ)*
     &  (VI+AI)/(2.*AI*(1.-XW))+(SH/(SH-SQMZ))**2*
     &  (1.-2.*(SQM1+SQM2)/SH+12.*SQM1*SQM2/SH2)*(VI**2+AI**2)/
     &  (8.*(1.-XW)**2))-2.*SQMZ/(SH-SQMZ)*(VI+AI)/AI+
     &  SQMZ*SH/(SH-SQMZ)**2*(1.-2.*(SQM1+SQM2)/SH)*(VI**2+AI**2)/
     &  (2.*(1.-XW))
        IF(ICH(IABS(I)).LT.0) THEN
          DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
     &    (THUH/(SH*TH)-(SQM1+SQM2)/TH)+THUH/TH2
        ELSE
          DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
     &    (THUH/(SH*UH)-(SQM1+SQM2)/UH)+THUH/UH2
        ENDIF
        DSIG(I,-I,1)=FACWW*DSIGWW*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  430   CONTINUE
 
      ELSEIF(IGRP.EQ.25) THEN
C...Q + QB -> H0
        DO 440 I=1,2*IPY(9)
        IF(IPROD(4,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SH) THEN
          RMQ=PMAS(100+I)**2/SH
          FSIG(I,I,1)=3.*RMQ*(1.-4.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
  440   CONTINUE
        DO 450 I=1,IPY(9)
        IL=2*I-1
        IF(IPROD(4,10+IL).EQ.1.AND.4.*PMAS(6+IL)**2.LT.SH) THEN
          RML=PMAS(6+IL)**2/SH
          FSIG(IL,IL,2)=RML*(1.-4.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(IL,IL,2)
        ENDIF
  450   CONTINUE
        DO 460 I=1,2
        IF(IPROD(4,20+I).EQ.1.AND.4.*PMAS(I+1)**2.LT.SH) THEN
          RMB=PMAS(I+1)**2/SH
          FSIG(I,I,3)=(1.-4.*RMB+12.*RMB**2)*SQRT(MAX(0.,1.-4.*RMB))/
     &    (2.*(3-I))*PYVAR(61+I)**2
          FSIGS=FSIGS+FSIG(I,I,3)
        ENDIF
  460   CONTINUE
        FACH=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/
     &  ((SH-SQM)**2+GM**2)*FSIGS
        DO 470 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 470
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 470
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 470
        RMQ=PMAS(100+IABS(I))**2/SH
        DSIG(I,-I,1)=FACH*RMQ*SQRT(MAX(0.,1.-4.*RMQ))*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  470   CONTINUE
 
      ELSEIF(IGRP.EQ.26) THEN
C...G + G -> H0
        DO 480 I=1,2*IPY(9)
        IF(IPROD(4,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SH) THEN
          RMQ=PMAS(100+I)**2/SH
          FSIG(I,I,1)=3.*RMQ*(1.-4.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
  480   CONTINUE
        DO 490 I=1,IPY(9)
        IL=2*I-1
        IF(IPROD(4,10+IL).EQ.1.AND.4.*PMAS(6+IL)**2.LT.SH) THEN
          RML=PMAS(6+IL)**2/SH
          FSIG(IL,IL,2)=RML*(1.-4.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(IL,IL,2)
        ENDIF
  490   CONTINUE
        DO 500 I=1,2
        IF(IPROD(4,20+I).EQ.1.AND.4.*PMAS(I+1)**2.LT.SH) THEN
          RMB=PMAS(I+1)**2/SH
          FSIG(I,I,3)=(1.-4.*RMB+12.*RMB**2)*SQRT(MAX(0.,1.-4.*RMB))/
     &    (2.*(3-I))*PYVAR(61+I)**2
          FSIGS=FSIGS+FSIG(I,I,3)
        ENDIF
  500   CONTINUE
        ETARE=0.
        ETAIM=0.
        DO 510 I=1,2*IPY(9)
        EPS=4.*PMAS(100+I)**2/SH
        IF(EPS.LE.1.) THEN
          IF(EPS.GT.1.E-4) THEN
            ROOT=SQRT(1.-EPS)
            RLN=ALOG((1.+ROOT)/(1.-ROOT))
          ELSE
            RLN=ALOG(4./EPS-2.)
          ENDIF
          PHIRE=0.25*(RLN**2-PAR(71)**2)
          PHIIM=0.5*PAR(71)*RLN
        ELSE
          PHIRE=-(ASIN(1./SQRT(EPS)))**2
          PHIIM=0.
        ENDIF
        ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
        ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
  510   CONTINUE
        ETA2=ETARE**2+ETAIM**2
        FACH=COMFAC*PYPAR(6)*(AS/PAR(71)*AEM/XW)**2*1./512.*
     &  (SH/SQMW)**2*ETA2*SH2/((SH-SQM)**2+GM**2)*FSIGS
        IF(IREAC(1,0).EQ.0.OR.XQ(1,0).LT.1.E-20) GOTO 520
        IF(IREAC(2,0).EQ.0.OR.XQ(2,0).LT.1.E-20) GOTO 520
        DSIG(0,0,1)=FACH*XQ(1,0)*XQ(2,0)
        DSIGS=DSIGS+DSIG(0,0,1)
  520   CONTINUE
 
      ELSEIF(IGRP.EQ.27) THEN
C...Z0 + Z0 -> H0
        SHH0=PYVAR(25)*PYVAR(2)
        DO 530 I=1,2*IPY(9)
        IF(IPROD(4,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SHH0) THEN
          RMQ=PMAS(100+I)**2/SHH0
          FSIG(I,I,1)=3.*RMQ*(1.-4.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
  530   CONTINUE
        DO 540 I=1,IPY(9)
        IL=2*I-1
        IF(IPROD(4,10+IL).EQ.1.AND.4.*PMAS(6+IL)**2.LT.SHH0) THEN
          RML=PMAS(6+IL)**2/SHH0
          FSIG(IL,IL,2)=RML*(1.-4.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(IL,IL,2)
        ENDIF
  540   CONTINUE
        DO 550 I=1,2
        IF(IPROD(4,20+I).EQ.1.AND.4.*PMAS(I+1)**2.LT.SHH0) THEN
          RMB=PMAS(I+1)**2/SHH0
          FSIG(I,I,3)=(1.-4.*RMB+12.*RMB**2)*SQRT(MAX(0.,1.-4.*RMB))/
     &    (2.*(3-I))*PYVAR(61+I)**2
          FSIGS=FSIGS+FSIG(I,I,3)
        ENDIF
  550   CONTINUE
        FACH=COMFAC/(1-XW)**3*1./16.*FSIGS
        DO 570 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 570
        DO 560 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(2,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 560
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        EJ=ICH(IABS(J))/3.
        AJ=SIGN(1.,EJ)
        VJ=AJ-4.*EJ*XW
        DSIG(I,J,1)=FACH*(VI**2+AI**2)*(VJ**2+AJ**2)*XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  560   CONTINUE
  570   CONTINUE
 
      ELSEIF(IGRP.EQ.28) THEN
C...W+ + W- -> H0
        SHH0=PYVAR(25)*PYVAR(2)
        DO 580 I=1,2*IPY(9)
        IF(IPROD(4,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SHH0) THEN
          RMQ=PMAS(100+I)**2/SHH0
          FSIG(I,I,1)=3.*RMQ*(1.-4.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSIGS=FSIGS+FSIG(I,I,1)
        ENDIF
  580   CONTINUE
        DO 590 I=1,IPY(9)
        IL=2*I-1
        IF(IPROD(4,10+IL).EQ.1.AND.4.*PMAS(6+IL)**2.LT.SHH0) THEN
          RML=PMAS(6+IL)**2/SHH0
          FSIG(IL,IL,2)=RML*(1.-4.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSIGS=FSIGS+FSIG(IL,IL,2)
        ENDIF
  590   CONTINUE
        DO 600 I=1,2
        IF(IPROD(4,20+I).EQ.1.AND.4.*PMAS(I+1)**2.LT.SHH0) THEN
          RMB=PMAS(I+1)**2/SHH0
          FSIG(I,I,3)=(1.-4.*RMB+12.*RMB**2)*SQRT(MAX(0.,1.-4.*RMB))/
     &    (2.*(3-I))*PYVAR(61+I)**2
          FSIGS=FSIGS+FSIG(I,I,3)
        ENDIF
  600   CONTINUE
        FACH=COMFAC*FSIGS
        DO 640 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 640
        EI=SIGN(1.,FLOAT(I))*ICH(IABS(I))
        FSIGSI=0.
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        DO 610 IP=1,IPY(9)
        IB=2*IP-1+MOD(IA,2)
        IF(IB.LE.2) IB=3-IB
  610   IF(IPROD(0,IB).EQ.1) FSIGSI=FSIGSI+VKM2((IA+1)/2,(IB+1)/2)
        DO 630 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(2,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 630
        EJ=SIGN(1.,FLOAT(J))*ICH(IABS(J))
        FSIGSJ=0.
        JA=IABS(J)
        IF(JA.LE.2) JA=3-JA
        DO 620 JP=1,IPY(9)
        JB=2*JP-1+MOD(JA,2)
        IF(JB.LE.2) JB=3-JB
  620   IF(IPROD(0,JB).EQ.1) FSIGSJ=FSIGSJ+VKM2((JA+1)/2,(JB+1)/2)
        IF(EI*EJ.GT.0.) GOTO 630
        DSIG(I,J,1)=FACH*FSIGSI*FSIGSJ*XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  630   CONTINUE
  640   CONTINUE
 
      ELSEIF(IGRP.EQ.29) THEN
C...Q + QB -> H0 + Z0
        THUH=MAX(TH*UH-SQM1*SQM2,SH*PYVAR(12))
        FACHZ=COMFAC*PYPAR(6)*(AEM/(XW*(1.-XW)))**2*1./96.*
     &  (THUH+2.*SH*SQMZ)/(SH-SQMZ)**2
        FACHZ=FACHZ*PYVAR(64)*PYVAR(62)
        DO 650 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 650
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 650
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 650
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        DSIG(I,-I,1)=FACHZ*(VI**2+AI**2)*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  650   CONTINUE
 
      ELSEIF(IGRP.EQ.30) THEN
C...Q + QB' -> H0 + W+/-
        THUH=MAX(TH*UH-SQM1*SQM2,SH*PYVAR(12))
        FACHW=COMFAC*PYPAR(6)*(AEM/XW)**2*1./24.*(THUH+2.*SH*SQMW)/
     &  (SH-SQMW)**2
        FACHW=FACHW*PYVAR(64)*PYVAR(63)
        DO 670 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 670
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        DO 660 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(1,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 660
        JA=IABS(J)
        IF(JA.LE.2) JA=3-JA
        IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 660
        DSIG(I,J,1)=FACHW*VKM2((IA+1)/2,(JA+1)/2)*XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  660   CONTINUE
  670   CONTINUE
 
      ELSEIF(IGRP.EQ.31) THEN
C...Q + QB -> R
        DO 680 I=1,2*IPY(9)
        IA=I
        IF(IA.LE.2) IA=3-IA
        DO 680 J=I,2*IPY(9)
        JA=J
        IF(JA.LE.2) JA=3-JA
        IF(IPROD(5,I).EQ.1.AND.IPROD(5,J).EQ.1.AND.IABS(IA-JA).EQ.2)
     &  FSIG(I,J,1)=3.*RADC
        FSIGS=FSIGS+FSIG(I,J,1)
        IF(IPROD(5,10+I).EQ.1.AND.IPROD(5,10+J).EQ.1.AND.
     &  IABS(I-J).EQ.2.AND.MOD(I,2).EQ.1) FSIG(I,J,2)=1.
  680   FSIGS=FSIGS+FSIG(I,J,2)
        FACR=COMFAC*(AEM/XW)**2*1./9.*SH2/((SH-SQM)**2+GM**2)*FSIGS
        DO 700 I=-IPY(8),IPY(8)
        IF(I.EQ.0.OR.IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 700
        IA=IABS(I)
        IF(IA.LE.2) IA=3-IA
        DO 690 J=-IPY(8),IPY(8)
        IF(J.EQ.0.OR.IREAC(2,J).EQ.0.OR.XQ(2,J).LT.1.E-20) GOTO 690
        JA=IABS(J)
        IF(JA.LE.2) JA=3-JA
        IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 690
        DSIG(I,J,1)=FACR*XQ(1,I)*XQ(2,J)
        DSIGS=DSIGS+DSIG(I,J,1)
  690   CONTINUE
  700   CONTINUE
 
      ELSEIF(IGRP.EQ.32) THEN
C...Q + QB' -> H+/-
        DO 710 I=1,IPY(9)
        IL=2*I-1
        IU=2*I
        IF(IPROD(6,10+IL).EQ.1.AND.IPROD(6,10+IU).EQ.1.AND.
     &  (PMAS(6+IL)+PMAS(6+IU))**2.LT.SH) THEN
          RMLL=PMAS(6+IL)**2/SH
          RMLU=PMAS(6+IU)**2/SH
          FSIG(IL,IU,2)=((RMLL*PYPAR(36)+RMLU/PYPAR(36))*
     &    (1.-RMLL-RMLU)-4.*RMLL*RMLU)*
     &    SQRT(MAX(0.,(1.-RMLL-RMLU)**2-4.*RMLL*RMLU))
          FSIGS=FSIGS+FSIG(IL,IU,2)
        ENDIF
        IF(IL.EQ.1) IL=2
        IF(IU.EQ.2) IU=1
        IF(IPROD(6,IL).EQ.1.AND.IPROD(6,IU).EQ.1.AND.
     &  (PMAS(100+IL)+PMAS(100+IU))**2.LT.SH) THEN
          RMQL=PMAS(100+IL)**2/SH
          RMQU=PMAS(100+IU)**2/SH
          FSIG(IL,IU,1)=3.*((RMQL*PYPAR(36)+RMQU/PYPAR(36))*
     &    (1.-RMQL-RMQU)-4.*RMQL*RMQU)*
     &    SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))*RADC
          FSIGS=FSIGS+FSIG(IL,IU,1)
        ENDIF
  710   CONTINUE
        FHC=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/
     &  ((SH-SQM)**2+GM**2)*FSIGS
        DO 750 I=1,IPY(8)/2
        IL=2*I-1
        IF(IL.EQ.1) IL=2
        IU=2*I
        IF(IU.EQ.2) IU=1
        RMQL=PMAS(100+IL)**2/SH
        RMQU=PMAS(100+IU)**2/SH
        FACHC=FHC*((RMQL*PYPAR(36)+RMQU/PYPAR(36))*(1.-RMQL-RMQU)-
     &  4.*RMQL*RMQU)/SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))
        IF(IREAC(1,IL).EQ.0.OR.XQ(1,IL).LT.1.E-20) GOTO 720
        IF(IREAC(2,-IU).EQ.0.OR.XQ(2,-IU).LT.1.E-20) GOTO 720
        DSIG(IL,-IU,1)=FACHC*XQ(1,IL)*XQ(2,-IU)
        DSIGS=DSIGS+DSIG(IL,-IU,1)
  720   IF(IREAC(1,-IL).EQ.0.OR.XQ(1,-IL).LT.1.E-20) GOTO 730
        IF(IREAC(2,IU).EQ.0.OR.XQ(2,IU).LT.1.E-20) GOTO 730
        DSIG(-IL,IU,1)=FACHC*XQ(1,-IL)*XQ(2,IU)
        DSIGS=DSIGS+DSIG(-IL,IU,1)
  730   IF(IREAC(1,IU).EQ.0.OR.XQ(1,IU).LT.1.E-20) GOTO 740
        IF(IREAC(2,-IL).EQ.0.OR.XQ(2,-IL).LT.1.E-20) GOTO 740
        DSIG(IU,-IL,1)=FACHC*XQ(1,IU)*XQ(2,-IL)
        DSIGS=DSIGS+DSIG(IU,-IL,1)
  740   IF(IREAC(1,-IU).EQ.0.OR.XQ(1,-IU).LT.1.E-20) GOTO 750
        IF(IREAC(2,IL).EQ.0.OR.XQ(2,IL).LT.1.E-20) GOTO 750
        DSIG(-IU,IL,1)=FACHC*XQ(1,-IU)*XQ(2,IL)
        DSIGS=DSIGS+DSIG(-IU,IL,1)
  750   CONTINUE
 
      ELSEIF(IGRP.EQ.33) THEN
C...Q + QB -> Z'0/Z0/GAM*
        FSGG=0.
        FSZZ=0.
        FSZPZP=0.
        FSZG=0.
        FSZPG=0.
        FSZPZ=0.
        DO 760 I=1,2*IPY(9)
        IF(IPROD(7,I).EQ.1.AND.4.*PMAS(100+I)**2.LT.SH) THEN
          RMQ=PMAS(100+I)**2/SH
          EF=ICH(I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          APF=SIGN(1.,EF+0.1)
          VPF=APF-4.*EF*XW
          FSGG=FSGG+3.*EF**2*(1.+2.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSZZ=FSZZ+3.*(VF**2*(1.+2.*RMQ)+AF**2*(1.-4.*RMQ))*
     &    SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSZPZP=FSZPZP+3.*(VPF**2*(1.+2.*RMQ)+APF**2*(1.-4.*RMQ))*
     &    SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSZG=FSZG+3.*EF*VF*(1.+2.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSZPG=FSZPG+3.*EF*VPF*(1.+2.*RMQ)*SQRT(MAX(0.,1.-4.*RMQ))*RADC
          FSZPZ=FSZPZ+3.*(VF*VPF*(1.+2.*RMQ)+AF*APF*(1.-4.*RMQ))*
     &    SQRT(MAX(0.,1.-4.*RMQ))*RADC
        ENDIF
        IF(IPROD(7,10+I).EQ.1.AND.4.*PMAS(6+I)**2.LT.SH) THEN
          RML=PMAS(6+I)**2/SH
          EF=ICH(10+I)/3.
          AF=SIGN(1.,EF+0.1)
          VF=AF-4.*EF*XW
          APF=SIGN(1.,EF+0.1)
          VPF=AF-4.*EF*XW
          FSGG=FSGG+EF**2*(1.+2.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSZZ=FSZZ+(VF**2*(1.+2.*RML)+AF**2*(1.-4.*RML))*
     &    SQRT(MAX(0.,1.-4.*RML))
          FSZPZP=FSZPZP+(VPF**2*(1.+2.*RML)+APF**2*(1.-4.*RML))*
     &    SQRT(MAX(0.,1.-4.*RML))
          FSZG=FSZG+EF*VF*(1.+2.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSZPG=FSZPG+EF*VPF*(1.+2.*RML)*SQRT(MAX(0.,1.-4.*RML))
          FSZPZ=FSZPZ+(VF*VPF*(1.+2.*RML)+AF*APF*(1.-4.*RML))*
     &    SQRT(MAX(0.,1.-4.*RML))
        ENDIF
  760   CONTINUE
        IF(IPY(39).EQ.1) THEN
C...ONLY GAM* PRODUCTION INCLUDED:
          FSZZ=0.
          FSZPZP=0.
          FSZG=0.
          FSZPG=0.
          FSZPZ=0.
        ELSEIF(IPY(39).EQ.2) THEN
C...ONLY Z0 PRODUCTION INCLUDED:
          FSGG=0.
          FSZPZP=0.
          FSZG=0.
          FSZPG=0.
          FSZPG=0.
        ELSEIF(IPY(39).EQ.3) THEN
C...ONLY Z'0 PRODUCTION INCLUDED:
          FSGG=0.
          FSZZ=0.
          FSZG=0.
          FSZPG=0.
          FSZPZ=0.
        ELSEIF(IPY(39).EQ.4) THEN
C...ONLY Z0/GAM* PRODUCTION INCLUDED:
          FSZPZP=0.
          FSZPG=0.
          FSZPZ=0.
        ELSEIF(IPY(39).EQ.5) THEN
C...ONLY Z'0/GAM* PRODUCTION INCLUDED:
          FSZZ=0.
          FSZG=0.
          FSZPZ=0.
        ELSEIF(IPY(39).EQ.6) THEN
C...ONLY Z'0/Z0 PRODUCTION INCLUDED:
          FSGG=0.
          FSZG=0.
          FSZPG=0.
        ENDIF
        FACZP=COMFAC*AEM**2*4./9.
        DO 770 I=-IPY(8),IPY(8)
        IF(I.EQ.0) GOTO 770
        IF(IREAC(1,I).EQ.0.OR.XQ(1,I).LT.1.E-20) GOTO 770
        IF(IREAC(2,-I).EQ.0.OR.XQ(2,-I).LT.1.E-20) GOTO 770
        EI=ICH(IABS(I))/3.
        AI=SIGN(1.,EI)
        VI=AI-4.*EI*XW
        API=SIGN(1.,EI)
        VPI=API-4.*EI*XW
        DSIG(I,-I,1)=FACZP*(EI**2*FSGG+(VI**2+AI**2)/
     &  (16.*XW*(1.-XW))**2*SH2/((SH-SQM)**2+GM**2)*FSZZ+
     &  (VPI**2+API**2)/(16.*XW*(1.-XW))**2*SH2/((SH-SQMP)**2+GMP**2)*
     &  FSZPZP+EI*VI/(8.*XW*(1.-XW))*SH*(SH-SQM)/((SH-SQM)**2+GM**2)*
     &  FSZG+EI*VPI/(8.*XW*(1.-XW))*SH*(SH-SQMP)/((SH-SQMP)**2+GMP**2)*
     &  FSZPG+2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*SH2*
     &  ((SH-SQM)*(SH-SQMP)+GM*GMP)/(((SH-SQM)**2+GM**2)*
     &  ((SH-SQMP)**2+GMP**2))*FSZPZ)*XQ(1,I)*XQ(2,-I)
        DSIGS=DSIGS+DSIG(I,-I,1)
  770   CONTINUE
      ENDIF
      PYVAR(45)=FSIGS
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYSTFU(KF,X,Q2,XPQ)
 
C...GIVES PROTON AND PI+ PARTON STRUCTURE FUNCTIONS ACCORDING TO A FEW
C...DIFFERENT PARAMETRIZATIONS, OR ACCORDING TO THE EVOLUTION SCHEME OF
C...WU-KI TUNG. NOTE THAT WHAT IS CODED IS X TIMES THE PROBABILITY
C...DISTRIBUTION, I.E. XQ(X,Q2) ETC.
      COMMON/LUDAT1/MST(40),PAR(80)
      COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40)
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYFILE/FLNM
      DIMENSION XPQ(-6:6),XQ(6),TX(6),TT(6),TS(6),NEHLQ(8,2),
     &CEHLQ(6,6,2,8,2),CDO(3,6,5,2),COW(3,5,4,2)
      CHARACTER*40 FLNM
      DATA INIT/0/
 
C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
C...PARAMETRIZATIONS, SEE BELOW.
C...POWERS OF 1-X IN DIFFERENT CASES
      DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION
      DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
     1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,
     2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,
     3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,
     4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,
     5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,
     6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,
     1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,
     2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,
     3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,
     4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,
     5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,
     6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/
      DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
     1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,
     2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,
     3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,
     4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,
     5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,
     6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,
     1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,
     2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,
     3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,
     4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,
     5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,
     6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/
C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION
      DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
     1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,
     2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,
     3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,
     4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,
     5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,
     6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,
     1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,
     2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,
     3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,
     4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,
     5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,
     6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/
      DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
     1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,
     2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,
     3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,
     4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,
     5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,
     6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,
     1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,
     2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,
     3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,
     4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,
     5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,
     6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/
C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS
      DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
     1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,
     2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,
     3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,
     4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,
     5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,
     6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,
     1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,
     2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,
     3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,
     4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,
     5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,
     6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/
      DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
     1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,
     2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,
     3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,
     4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,
     5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,
     6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,
     1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,
     2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,
     3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,
     4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,
     5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,
     6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/
C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
      DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
     1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,
     2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,
     3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,
     4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,
     5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,
     6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,
     1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,
     2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,
     3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,
     4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,
     5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,
     6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/
      DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
     1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,
     2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,
     3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,
     4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,
     5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,
     6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,
     1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,
     2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,
     3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,
     4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,
     5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,
     6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/
C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION
      DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
     1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,
     2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,
     3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,
     4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,
     5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,
     6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,
     1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,
     2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,
     3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,
     4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,
     5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,
     6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/
      DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
     1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,
     2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,
     3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,
     4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,
     5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,
     6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,
     1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,
     2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,
     3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,
     4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,
     5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,
     6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/
C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION
      DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
     1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,
     2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,
     3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,
     4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,
     5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,
     6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,
     1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,
     2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,
     3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,
     4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,
     5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,
     6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/
      DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
     1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,
     2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,
     3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,
     4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,
     5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,
     6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,
     1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,
     2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,
     3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,
     4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,
     5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,
     6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/
C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION
      DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
     1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,
     2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,
     3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,
     4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,
     5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,
     6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,
     1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,
     2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,
     3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,
     4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,
     5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,
     6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/
      DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
     1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,
     2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,
     3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,
     4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,
     5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,
     6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,
     1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,
     2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,
     3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,
     4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,
     5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,
     6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/
C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION
      DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
     1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,
     2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,
     3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,
     4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,
     5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,
     6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
     1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,
     2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,
     3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,
     4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,
     5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,
     6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/
      DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
     1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,
     2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,
     3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,
     4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,
     5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,
     6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
     1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,
     2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,
     3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,
     4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,
     5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,
     6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/
 
C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
C...DUKE, OWENS PROTON STRUCTURE FUNCTION PARAMETRIZATIONS, SEE BELOW.
C...EXPANSION COEFFICIENTS FOR (UP+DOWN) VALENCE QUARK DISTRIBUTION
      DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
     1 4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2 4.000E-03, 7.240E-01,-4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     3-7.000E-03,-6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/
      DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
     1 3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2 1.400E-02, 7.530E-01,-6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     3 0.000E+00,-7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/
C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION
      DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
     1 7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2-2.370E-01, 6.270E-01,-4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00,
     3 2.600E-02,-1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/
      DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
     1 7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2-2.320E-01, 6.270E-01,-4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00,
     3 2.300E-02,-1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/
C...EXPANSION COEFFICIENTS FOR (UP+DOWN+STRANGE) SEA QUARK DISTRIBUTION
      DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
     1 1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2-1.132E+00,-3.720E-01, 1.590E+00, 6.310E+00,-1.050E+01, 1.470E+01,
     3 2.930E-01,-2.900E-02,-1.530E-01,-2.730E-01,-3.170E+00, 9.800E+00/
      DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
     1 1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2-1.920E+00,-2.730E-01, 5.300E-01, 1.570E+01,-1.010E+02, 2.230E+02,
     3 5.820E-01,-1.640E-01,-7.630E-01,-2.830E+00, 4.470E+01,-1.170E+02/
C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION
      DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
     1 0.000E+00,-3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2 1.350E-01,-2.220E-01, 3.260E+00,-3.030E+00, 1.740E+01,-1.790E+01,
     3-7.500E-02,-5.800E-02,-9.090E-01, 1.500E+00,-1.130E+01, 1.560E+01/
       DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
     1 0.000E+00,-1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00,
     2 6.700E-02,-2.330E-01, 3.660E+00,-4.740E-01, 9.500E+00,-1.660E+01,
     3-3.100E-02,-2.300E-02,-4.530E-01, 3.580E-01,-5.430E+00, 1.550E+01/
C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
      DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
     1 1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
     2-1.710E+00,-9.490E-01, 1.440E+00,-7.190E+00,-1.650E+01, 1.530E+01,
     3 6.380E-01, 3.250E-01,-1.050E+00, 2.550E-01, 1.090E+01,-1.010E+01/
      DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
     1 8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
     2-9.710E-01,-1.160E+00, 1.230E+00,-5.640E+00,-7.540E+00,-5.960E-01,
     3 4.340E-01, 4.760E-01,-2.540E-01,-8.170E-01, 5.500E+00, 1.260E-01/
 
C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
C...OWENS PION STRUCTURE FUNCTION PARAMETRIZATIONS, SEE BELOW.
C...EXPANSION COEFFICIENTS FOR UP AND DOWN VALENCE QUARK DISTRIBUTIONS
      DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
     1  4.0000E-01,  7.0000E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
     2 -6.2120E-02,  6.4780E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
     3 -7.1090E-03,  1.3350E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/
      DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
     1  4.0000E-01,  6.2800E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
     2 -5.9090E-02,  6.4360E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
     3 -6.5240E-03,  1.4510E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/
C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
      DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
     1  8.8800E-01,  0.0000E+00,  3.1100E+00,  6.0000E+00,  0.0000E+00,
     2 -1.8020E+00, -1.5760E+00, -1.3170E-01,  2.8010E+00, -1.7280E+01,
     3  1.8120E+00,  1.2000E+00,  5.0680E-01, -1.2160E+01,  2.0490E+01/
      DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
     1  7.9400E-01,  0.0000E+00,  2.8900E+00,  6.0000E+00,  0.0000E+00,
     2 -9.1440E-01, -1.2370E+00,  5.9660E-01, -3.6710E+00, -8.1910E+00,
     3  5.9660E-01,  6.5820E-01, -2.5500E-01, -2.3040E+00,  7.7580E+00/
C...EXPANSION COEFFICIENTS FOR (UP+DOWN+STRANGE) QUARK SEA DISTRIBUTION
      DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
     1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00,
     2 -2.4280E-01, -2.1200E-01,  8.6730E-01,  1.2660E+00,  2.3820E+00,
     3  1.3860E-01,  3.6710E-03,  4.7470E-02, -2.2150E+00,  3.4820E-01/
      DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
     1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00,
     2 -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00,  5.6210E-01,
     3 -1.7400E-01, -9.6230E-02,  1.5750E+00,  1.3780E+00, -2.7010E-01/
C...EXPANSION COEFFICIENTS FOR CHARM QUARK SEA DISTRIBUTION
      DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
     1  0.0000E+00, -2.2120E-02,  2.8940E+00,  0.0000E+00,  0.0000E+00,
     2  7.9280E-02, -3.7850E-01,  9.4330E+00,  5.2480E+00,  8.3880E+00,
     3 -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/
      DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
     1  0.0000E+00, -8.8200E-02,  1.9240E+00,  0.0000E+00,  0.0000E+00,
     2  6.2290E-02, -2.8920E-01,  2.4240E-01, -4.4630E+00, -8.3670E-01,
     3 -4.0990E-02, -1.0820E-01,  2.0360E+00,  5.2090E+00, -4.8400E-02/
 
C...EULER'S BETA FUNCTION, REQUIRES ORDINARY GAMMA FUNCTION
      EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
 
C...RESET STRUCTURE FUNCTIONS, CHECK X AND HADRON FLAVOUR
      ALAM=0.
      DO 100 IFL=-6,6
  100 XPQ(IFL)=0.
      IF(X.LT.0..OR.X.GT.1.) THEN
        WRITE(MST(20),1000) X
        RETURN
      ENDIF
      KFA=IABS(KF)
      IF(KFA.NE.17.AND.KFA.NE.41.AND.KFA.NE.42) THEN
        WRITE(MST(20),1100) KF
        RETURN
      ENDIF
      IF(KFA.EQ.17) GOTO 200
 
C...PARAMETRIZATIONS OF THE PROTON STRUCTURE FUNCTIONS.
      IF(IPY(7).EQ.0) THEN
C...SIMPLE SCALING STRUCTURE FUNCTIONS, VALENCE QUARKS AND GLUON ONLY.
        XPQ(0)=3.*(1.-X)**5
        XPQ(2)=(1.-X)**3*(1.274+.589*(1.-X)-1.675*(1.-X)**2)
        XPQ(1)=2.*XPQ(2)
        PYVAR(24)=ALAM
 
      ELSEIF(IPY(7).EQ.1.OR.IPY(7).EQ.2) THEN
C...PROTON STRUCTURE FUNCTIONS FROM EICHTEN, HINCHLIFFE, LANE, QUIGG:
C...REV. MOD. PHYS. 56 (1984) 579; AS REVISED IN EICHTEN, HINCHLIFFE,
C...LANE, QUIGG: FERMILAB-PUB-86/75-T (1986).
C...ALLOWED VARIABLE RANGE: 5 GEV2 < Q2 < 1E8 GEV2; 1E-4 < X < 1
 
C...DETERMINE SET, LAMDBA AND X AND T EXPANSION VARIABLES
        NSET=IPY(7)
        IF(NSET.EQ.1) ALAM=0.2
        IF(NSET.EQ.2) ALAM=0.29
        T=ALOG(Q2/ALAM**2)
        TMIN=ALOG(5./ALAM**2)
        TMAX=ALOG(1E8/ALAM**2)
        VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
        NX=1
        IF(X.LE.0.1) NX=2
        IF(NX.EQ.1) VX=(2.*X-1.1)/0.9
        IF(NX.EQ.2) VX=MAX(-1.,(2.*ALOG(X)+11.51293)/6.90776)
        CXS=1.
        IF(X.LT.1E-4.AND.ABS(PYPAR(40)-1.).GT.0.01) CXS=
     &  (1E-4/X)**(PYPAR(40)-1.)
 
C...CHEBYSHEV POLYNOMIALS FOR X AND T EXPANSION
        TX(1)=1.
        TX(2)=VX
        TX(3)=2.*VX**2-1.
        TX(4)=4.*VX**3-3.*VX
        TX(5)=8.*VX**4-8.*VX**2+1.
        TX(6)=16.*VX**5-20.*VX**3+5.*VX
        TT(1)=1.
        TT(2)=VT
        TT(3)=2.*VT**2-1.
        TT(4)=4.*VT**3-3.*VT
        TT(5)=8.*VT**4-8.*VT**2+1.
        TT(6)=16.*VT**5-20.*VT**3+5.*VT
 
C...CALCULATE STRUCTURE FUNCTIONS
        DO 120 IFL=1,6
        XQSUM=0.
        DO 110 IT=1,6
        DO 110 IX=1,6
  110   XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,NSET)*TX(IX)*TT(IT)
  120   XQ(IFL)=XQSUM*(1.-X)**NEHLQ(IFL,NSET)*CXS
 
C...PUT INTO OUTPUT ARRAY
        XPQ(0)=XQ(4)
        XPQ(1)=XQ(1)+XQ(3)
        XPQ(2)=XQ(2)+XQ(3)
        XPQ(3)=XQ(5)
        XPQ(4)=XQ(6)
        XPQ(-1)=XQ(3)
        XPQ(-2)=XQ(3)
        XPQ(-3)=XQ(5)
        XPQ(-4)=XQ(6)
 
C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS)
        IF(IPY(8).GE.5) THEN
          IF(NSET.EQ.1) TMIN=8.1905
          IF(NSET.EQ.2) TMIN=7.4474
          IF(T.LE.TMIN) GOTO 140
          VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
          TT(1)=1.
          TT(2)=VT
          TT(3)=2.*VT**2-1.
          TT(4)=4.*VT**3-3.*VT
          TT(5)=8.*VT**4-8.*VT**2+1.
          TT(6)=16.*VT**5-20.*VT**3+5.*VT
          XQSUM=0.
          DO 130 IT=1,6
          DO 130 IX=1,6
  130     XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
          XPQ(5)=XQSUM*(1.-X)**NEHLQ(7,NSET)
          XPQ(-5)=XPQ(5)
  140     CONTINUE
        ENDIF
 
C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS)
        IF(IPY(8).GE.6) THEN
          IF(NSET.EQ.1) TMIN=11.5528
          IF(NSET.EQ.2) TMIN=10.8097
          TMIN=TMIN+2.*ALOG(PMAS(106)/30.)
          TMAX=TMAX+2.*ALOG(PMAS(106)/30.)
          IF(T.LE.TMIN) GOTO 160
          VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
          TT(1)=1.
          TT(2)=VT
          TT(3)=2.*VT**2-1.
          TT(4)=4.*VT**3-3.*VT
          TT(5)=8.*VT**4-8.*VT**2+1.
          TT(6)=16.*VT**5-20.*VT**3+5.*VT
          XQSUM=0.
          DO 150 IT=1,6
          DO 150 IX=1,6
  150     XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
          XPQ(6)=XQSUM*(1.-X)**NEHLQ(8,NSET)
          XPQ(-6)=XPQ(6)
  160     CONTINUE
        ENDIF
        PYVAR(24)=ALAM
 
      ELSEIF(IPY(7).EQ.3.OR.IPY(7).EQ.4) THEN
C...PROTON STRUCTURE FUNCTIONS FROM DUKE, OWENS:
C...PHYS. REV. D30 (1984) 49.
C...ALLOWED VARIABLE RANGE: 4 GEV2 < Q2 < APPROX 1E6 GEV2
 
C...DETERMINE SET, LAMBDA AND S EXPANSION PARAMETER
        NSET=IPY(7)-2
        IF(NSET.EQ.1) ALAM=0.2
        IF(NSET.EQ.2) ALAM=0.4
        SD=ALOG(ALOG(MAX(Q2,4.)/ALAM**2)/ALOG(4./ALAM**2))
 
C...CALCULATE STRUCTURE FUNCTIONS
        DO 180 IFL=1,5
        DO 170 IS=1,6
  170   TS(IS)=CDO(1,IS,IFL,NSET)+CDO(2,IS,IFL,NSET)*SD+
     &  CDO(3,IS,IFL,NSET)*SD**2
        IF(IFL.LE.2) THEN
          XQ(IFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBET(TS(1),
     &    TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))
        ELSE
          XQ(IFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2+
     &    TS(6)*X**3)
        ENDIF
  180   CONTINUE
 
C...PUT INTO OUTPUT ARRAYS
        XPQ(0)=XQ(5)
        XPQ(1)=3.*XQ(1)-XQ(2)+XQ(3)/6.
        XPQ(2)=XQ(2)+XQ(3)/6.
        XPQ(3)=XQ(3)/6.
        XPQ(4)=XQ(4)
        XPQ(-1)=XQ(3)/6.
        XPQ(-2)=XQ(3)/6.
        XPQ(-3)=XQ(3)/6.
        XPQ(-4)=XQ(4)
        PYVAR(24)=ALAM
 
      ELSEIF(IPY(7).EQ.5) THEN
C...PROTON STRUCTURE FUNCTIONS FROM GLUCK, HOFFMANN, REYA:
C...Z. PHYSIK C13 (1982) 119.
C...ALLOWED VARIABLE RANGE: 4 GEV2 < Q2 < 4E4 GEV2; 0.01 < X < 0.8
        ALAM=0.4
        SD=ALOG(ALOG(MAX(Q2,4.)/ALAM**2)/ALOG(4./ALAM**2))
 
C...VALENCE U-QUARK DISTRIBUTION.
        A=.421-.0412*SD
        C=2.-.6223*SD**.8
        D=3.37+.4319*SD
        XU=2.*C*X**A*(1.-X**C)**D/EULBET(D+1.,A/C)
 
C...VALENCE D-QUARK DISTRIBUTION.
        A=.364-.0368*SD
        C=2.-.5414*SD**.8
        D=5.09+.3463*SD
        XD=C*X**A*(1.-X**C)**D/EULBET(D+1.,A/C)
 
C...XUB=XU=XUBAR=XD=XDBAR SYMMETRIC SEA DISTRIBUTION.
        A=.25+.088*SD**1.3
        B=.8128*SD-2.003*SD**1.8+.0831*SD**2
        C=3.97*SD
        D=7.+1.666*SD
        E=.2487*SD**2.5
        F=27.8+59.68*SD
        XUB=A*(1.+B*X+C*X**2)*(1.-X)**D + E*EXP(-F*X)
 
C...XS=XS=XSBAR SEA DISTRIBUTION.
        A=.0625+.1132*SD**1.3
        B=12.64*SD-51.70*SD**1.8+38.02*SD**2
        C=4.448*SD
        D=7.+1.562*SD
        E=.3081*SD**2.5
        F=47.24+67.91*SD
        XS=A*(1.+B*X+C*X**2)*(1.-X)**D + E*EXP(-F*X)
 
C...CHARM SEA IS ZERO.
 
C...GLUON DISTRIBUTION.
        A=.9243+2.51*SD**0.5
        B=8.558-9.227*SD**0.3-.655*SD**1.5
        C=53.57-68.78*SD**0.3+19.3*SD
        D=6.+1.454*SD
        E=11.29*SD**2
        F=41.24+50.71*SD
        XG=A*(1.+B*X+C*X**2)*(1.-X)**D + E*EXP(-F*X)
 
C...PUT INTO OUTPUT ARRAY
        XPQ(0)=XG
        XPQ(1)=XU+XUB
        XPQ(2)=XD+XUB
        XPQ(3)=XS
        XPQ(-1)=XUB
        XPQ(-2)=XUB
        XPQ(-3)=XS
        PYVAR(24)=ALAM
 
      ELSEIF(IABS(IPY(7)).GE.10.AND.IABS(IPY(7)).LE.14) THEN
C...PROTON STRUCTURE FUNCTION EVOLUTION FROM WU-KI TUNG: PARTON
C...DISTRIBUTION FUNCTIONS INCORPORATING HEAVY QUARK MASS EFFECTS.
C...ALLOWED VARIABLE RANGE: PYPAR(41) < Q < PYPAR(42); PYPAR(43) < X < 1
        IHDRN=1
        I1=0
        IF(IPY(7).LT.0) I1=1
        I2=MOD(IABS(IPY(7)),10)
        I3=IPY(54)
C...CONVERT TO LAMBDA IN CWZ SCHEME (APPROXIMATELY LINEAR RELATION)
        ALAM=0.75*PYPAR(4)
        TPMS=PMAS(106)
        QINI=PYPAR(41)
        QMAX=PYPAR(42)
        XMIN=PYPAR(43)
 
C...INITIALIZE EVOLUTION (PERFORM CALCULATION OR READ RESULTS FROM FILE)
        IF(INIT.EQ.0) THEN
          CALL PSETUP(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,FLNM,I2,I3,IRET,
     &    IRR)
          INIT=1
        ENDIF
 
C...PUT INTO OUTPUT ARRAY
        Q=SQRT(Q2)
        DO 190 I=-6,6
  190   XPQ(I)=X*MAX(0.,PDF(10,ISIGN(1,KF),I,X,Q,IR))
        PYVAR(24)=PYPAR(4)
 
      ELSE
        WRITE(MST(20),1200) IPY(7)
      ENDIF
 
C...ISOSPIN CONJUGATION FOR NEUTRON
      IF(KFA.EQ.42) THEN
        XPS=XPQ(1)
        XPQ(1)=XPQ(2)
        XPQ(2)=XPS
      ENDIF
      GOTO 230
 
C...PARAMETRIZATIONS OF THE PION (PI+) STRUCTURE FUNCTIONS.
  200 IF(IPY(7).EQ.0) THEN
C...SIMPLE SCALING STRUCTURE FUNCTIONS, VALENCE QUARKS AND GLUON ONLY.
        XPQ(0)=2.*(1.-X)**3
        XPQ(1)=SQRT(X)*(1.-X)
        XPQ(-2)=XPQ(1)
        PYVAR(24)=ALAM
 
      ELSEIF((IPY(7).GE.1.AND.IPY(7).LE.5).OR.
     &(IABS(IPY(7)).GE.10.AND.IABS(IPY(7)).LE.14)) THEN
C...PION STRUCTURE FUNCTIONS FROM OWENS:
C...PHYS. REV. D30 (1984) 943
C...ALLOWED VARIABLE RANGE: 4 GEV2 < Q2 < APPROX 2000 GEV2
 
C...DETERMINE SET, LAMBDA AND S EXPANSION VARIABLE
        NSET=MOD(IABS(IPY(7)),10)
        IF(NSET.EQ.0.OR.NSET.EQ.3) NSET=1
        IF(NSET.GE.4) NSET=2
        IF(NSET.EQ.1) ALAM=0.2
        IF(NSET.EQ.2) ALAM=0.4
        SD=ALOG(ALOG(MAX(Q2,4.)/ALAM**2)/ALOG(4./ALAM**2))
 
C...CALCULATE STRUCTURE FUNCTIONS
        DO 220 IFL=1,4
        DO 210 IS=1,5
  210   TS(IS)=COW(1,IS,IFL,NSET)+COW(2,IS,IFL,NSET)*SD+
     &  COW(3,IS,IFL,NSET)*SD**2
        IF(IFL.EQ.1) THEN
          XQ(IFL)=X**TS(1)*(1.-X)**TS(2)/EULBET(TS(1),TS(2)+1.)
        ELSE
          XQ(IFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2)
        ENDIF
  220   CONTINUE
 
C...PUT INTO OUTPUT ARRAYS
        XPQ(0)=XQ(2)
        XPQ(1)=XQ(1)+XQ(3)/6.
        XPQ(2)=XQ(3)/6.
        XPQ(3)=XQ(3)/6.
        XPQ(4)=XQ(4)
        XPQ(-1)=XQ(3)/6.
        XPQ(-2)=XQ(1)+XQ(3)/6.
        XPQ(-3)=XQ(3)/6.
        XPQ(-4)=XQ(4)
        PYVAR(24)=ALAM
 
      ELSE
        WRITE(MST(20),1200) IPY(7)
      ENDIF
 
C...CHARGE CONJUGATION FOR ANTIPARTICLE, POSITIVITY, MAX FLAVOUR
  230 IF(KF.LT.0) THEN
        DO 240 IFL=1,4
        XPS=XPQ(IFL)
        XPQ(IFL)=XPQ(-IFL)
  240   XPQ(-IFL)=XPS
      ENDIF
      DO 250 IFL=-6,6
      XPQ(IFL)=MAX(0.,XPQ(IFL))
  250 IF(IABS(IFL).GT.IPY(8)) XPQ(IFL)=0.
 
C...FORMATS FOR ERROR PRINTOUTS
 1000 FORMAT(' ERROR: X VALUE OUTSIDE PHYSICAL RANGE, X =',1P,E12.3)
 1100 FORMAT(' ERROR: ILLEGAL PARTICLE CODE FOR STRUCTURE FUNCTION,',
     &' KF =',I5)
 1200 FORMAT(' ERROR: BAD VALUE OF PARAMETER IPY(7) IN PYSTFU,',
     &' IPY(7) =',I5)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYTHAT(THL,THU)
 
C...GIVES LOWER AND UPPER LIMIT ON THE VARIABLE TH (MANDELSTAM T-HAT).
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYPROC/ISUB,KFL(3,2),X(2),SH,TH,UH,Q2,XSEC(0:40)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
 
      IGRP=IPY(44)
      SQM1=0.
      SQM2=0.
      IF(ISET(IGRP).EQ.1) THEN
C...2 -> 2 PROCESSES:
        SQM3=PYVAR(14)
        SQM4=PYVAR(15)
        QT2M=PYVAR(12)
      ELSEIF(ISET(IGRP).EQ.2.OR.ISET(IGRP).EQ.3) THEN
C...RESONANCE PRODUCTION:
        SQM3=0.
        SQM4=0.
        QT2M=PYVAR(12)
      ELSEIF(ISET(IGRP).EQ.4) THEN
C...MULTIPLE SCATTERING:
        SQM3=PYVAR(14)
        SQM4=PYVAR(15)
        IF(IPY(12).LE.1) QT2M=PYPAR(32)**2
        IF(IPY(12).GE.2) QT2M=0.01*PYPAR(32)**2
      ELSEIF(ISET(IGRP).GE.5.AND.ISET(IGRP).LE.7) THEN
C...DIFFRACTIVE AND ELASTIC SCATTERING:
        SQM1=PYVAR(3)**2
        SQM2=PYVAR(4)**2
        SQM3=PYVAR(14)
        SQM4=PYVAR(15)
        QT2M=0.
      ENDIF
 
      IF(ISET(IGRP).EQ.8) THEN
C...HIGGS PRODUCTION FROM INTERMEDIATE VECTOR BOSON FUSION:
        SHH0=PYVAR(25)*PYVAR(2)
        QT2M=PYVAR(12)
        THL=-0.5*SHH0*(1.+SQRT(MAX(0.,1.-4.*QT2M/SHH0)))
        THU=SHH0*QT2M/THL
      ELSE
C...ALL OTHER CASES:
        SQL12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2
        SQL34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
        THL=0.5*(SQM1+SQM2+SQM3+SQM4-SH-(SQM1-SQM2)*(SQM3-SQM4)/SH-
     &  SQRT(MAX(0.,SQL12*(SQL34-4.*SH*QT2M)))/SH)
        THU=((SQM1-SQM3)*(SQM2-SQM4)+(SH-SQM1-SQM2)*QT2M+
     &  ((SQM1*SQM4-SQM2*SQM3)*(SQM1-SQM2-SQM3+SQM4)+
     &  (SQM1-SQM2)**2*QT2M)/SH)/THL
      ENDIF
      PYVAR(17)=THL
      PYVAR(18)=THU
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYPRKT(PTX,PTY)
 
C...GIVES PRIMORDIAL KT TO REACTING PARTONS.
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/LUDAT1/MST(40),PAR(80)
 
C...NO PRIMORDIAL KT OR CHOSEN ACCORDING TO TRUNCATED GAUSSIAN OR
C...EXPONENTIAL
  100 IF(IPY(16).LE.0) THEN
        PT=0.
      ELSEIF(IPY(16).EQ.1) THEN
        PT=PYPAR(7)*SQRT(-ALOG(RLU(0)))
      ELSE
        RPT1=RLU(0)
        RPT2=RLU(0)
        PT=-PYPAR(8)*ALOG(RPT1*RPT2)
      ENDIF
      IF(PT.GT.PYPAR(11)) GOTO 100
      PHI=PAR(72)*RLU(0)
      PTX=PT*COS(PHI)
      PTY=PT*SIN(PHI)
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYSPLI(KPART,KFLIN,KFLCH,KFLSP)
 
C...IN CASE OF A HADRON REMNANT WHICH IS MORE COMPLICATED THAN JUST A
C...QUARK OR A DIQUARK, SPLIT IT INTO TWO (PARTONS OR HADRON + PARTON).
      IFLIN=KFLIN-ISIGN(500,KFLIN)
      KSIGN=ISIGN(1,KPART)
      IFL=KFLIN*KSIGN
      KFLCH=0
      IDUM=0
 
      IF(IABS(KPART).EQ.17) THEN
C...DECOMPOSE PI+ (PI-).
        IF(IFL.EQ.501) THEN
C...VALENCE U (UBAR) REMOVED.
          KFLSP=-502*KSIGN
        ELSEIF(IFL.EQ.-502) THEN
C...VALENCE D (DBAR) REMOVED.
          KFLSP=501*KSIGN
        ELSEIF(KFLIN.EQ.500) THEN
C...GLUON REMOVED.
          R=2.*RLU(0)
          IF(R.LT.1.) THEN
            KFLCH=501*KSIGN
            KFLSP=-502*KSIGN
          ELSE
            KFLCH=-502*KSIGN
            KFLSP=501*KSIGN
          ENDIF
        ELSEIF(IFL.GT.500.AND.IFL.NE.501) THEN
C...SEA QUARK (ANTIQUARK) REMOVED.
          CALL LUIFLD(-IFLIN,0,KSIGN,IDUM,KFLCH)
          KFLSP=-502*KSIGN
        ELSEIF(IFL.LT.-500.AND.IFL.NE.-502) THEN
C...SEA ANTIQUARK (QUARK) REMOVED.
          CALL LUIFLD(-IFLIN,0,-2*KSIGN,IDUM,KFLCH)
          KFLSP=501*KSIGN
        ENDIF
 
      ELSEIF(IABS(KPART).EQ.41) THEN
C...DECOMPOSE PROTON (ANTIPROTON).
        IF(IFL.EQ.501) THEN
C...VALENCE U (UBAR) REMOVED.
          R=4.*RLU(0)
          IF(R.LT.3.) THEN
            KFLSP=512*KSIGN
          ELSE
            KFLSP=521*KSIGN
          ENDIF
        ELSEIF(IFL.EQ.502) THEN
C...VALENCE D (DBAR) REMOVED.
          KFLSP=511*KSIGN
        ELSEIF(KFLIN.EQ.500) THEN
C...GLUON REMOVED.
          R=6.*RLU(0)
          IF(R.LT.3.) THEN
            KFLCH=501*KSIGN
            KFLSP=512*KSIGN
          ELSEIF(R.LT.4.) THEN
            KFLCH=501*KSIGN
            KFLSP=521*KSIGN
          ELSE
            KFLCH=502*KSIGN
            KFLSP=511*KSIGN
          ENDIF
        ELSEIF(IFL.GT.502) THEN
C...SEA QUARK (ANTIQUARK) REMOVED.
          R=6*RLU(0)
          IF(R.LT.3.) THEN
            CALL LUIFLD(-IFLIN,0,KSIGN,IDUM,KFLCH)
            KFLSP=512*KSIGN
          ELSEIF(R.LT.4.) THEN
            CALL LUIFLD(-IFLIN,0,KSIGN,IDUM,KFLCH)
            KFLSP=521*KSIGN
          ELSE
            CALL LUIFLD(-IFLIN,0,2*KSIGN,IDUM,KFLCH)
            KFLSP=511*KSIGN
          ENDIF
        ELSEIF(IFL.LT.-500) THEN
C...SEA ANTIQUARK (QUARK) REMOVED.
  100     R=6*RLU(0)
          IF(R.LT.3.) THEN
            CALL LUIFLD(12*KSIGN,KSIGN,-IFLIN,IDUM,KFLCH)
            KFLSP=501*KSIGN
          ELSEIF(R.LT.4.) THEN
            CALL LUIFLD(21*KSIGN,2*KSIGN,-IFLIN,IDUM,KFLCH)
            KFLSP=501*KSIGN
          ELSE
            CALL LUIFLD(11*KSIGN,KSIGN,-IFLIN,IDUM,KFLCH)
            KFLSP=502*KSIGN
          ENDIF
          IF(KFLCH.EQ.0) GOTO 100
        ENDIF
 
      ELSEIF(IABS(KPART).EQ.42) THEN
C...DECOMPOSE NEUTRON (ANTINEUTRON).
        IF(IFL.EQ.501) THEN
C...VALENCE U (UBAR) REMOVED.
          KFLSP=522*KSIGN
        ELSEIF(IFL.EQ.502) THEN
C...VALENCE D (DBAR) REMOVED.
          R=4.*RLU(0)
          IF(R.LT.3.) THEN
            KFLSP=512*KSIGN
          ELSE
            KFLSP=521*KSIGN
          ENDIF
        ELSEIF(KFLIN.EQ.500) THEN
C...GLUON REMOVED.
          R=6.*RLU(0)
          IF(R.LT.2.) THEN
            KFLCH=501*KSIGN
            KFLSP=522*KSIGN
          ELSEIF(R.LT.5.) THEN
            KFLCH=502*KSIGN
            KFLSP=512*KSIGN
          ELSE
            KFLCH=502*KSIGN
            KFLSP=521*KSIGN
          ENDIF
        ELSEIF(IFL.GT.502) THEN
C...SEA QUARK (ANTIQUARK) REMOVED.
          R=6*RLU(0)
          IF(R.LT.2.) THEN
            CALL LUIFLD(-IFLIN,0,KSIGN,IDUM,KFLCH)
            KFLSP=522*KSIGN
          ELSEIF(R.LT.5.) THEN
            CALL LUIFLD(-IFLIN,0,2*KSIGN,IDUM,KFLCH)
            KFLSP=512*KSIGN
          ELSE
            CALL LUIFLD(-IFLIN,0,2*KSIGN,IDUM,KFLCH)
            KFLSP=521*KSIGN
          ENDIF
        ELSEIF(IFL.LT.-500) THEN
C...SEA ANTIQUARK (QUARK) REMOVED.
  110     R=6*RLU(0)
          IF(R.LT.2.) THEN
            CALL LUIFLD(22*KSIGN,KSIGN,-IFLIN,IDUM,KFLCH)
            KFLSP=501*KSIGN
          ELSEIF(R.LT.5.) THEN
            CALL LUIFLD(12*KSIGN,KSIGN,-IFLIN,IDUM,KFLCH)
            KFLSP=502*KSIGN
          ELSE
            CALL LUIFLD(21*KSIGN,2*KSIGN,-IFLIN,IDUM,KFLCH)
            KFLSP=502*KSIGN
          ENDIF
          IF(KFLCH.EQ.0) GOTO 110
        ENDIF
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PYCHID(KPART,KFL,CHI)
 
C...ENERGY DISTRIBUTION AMONG FRAGMENTS OF HADRON REMNANT.
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
 
C...ENERGY DISTRIBUTION FOR PARTICLE INTO TWO JETS
      IF(IABS(KFL).GE.500) THEN
        IF(IABS(KPART).LE.40) CHIK=PYPAR(13)
        IF(IABS(KPART).GT.40) CHIK=PYPAR(15)
        IF(IPY(17).LE.1) THEN
          IF(IABS(KPART).LE.40) CHI=RLU(0)
          IF(IABS(KPART).GT.40) CHI=1.-SQRT(RLU(0))
        ELSEIF(IPY(17).EQ.2) THEN
          CHI=1.-RLU(0)**(1./(1.+CHIK))
        ELSEIF(IPY(17).EQ.3) THEN
          CUT=2.*0.3/PYVAR(1)
  100     CHI=RLU(0)**2
          IF((CHI**2/(CHI**2+CUT**2))**0.25*(1.-CHI)**CHIK.LT.
     &    RLU(0)) GOTO 100
        ELSE
          CUT=2.*0.3/PYVAR(1)
          CUTR=(1.+SQRT(1.+CUT**2))/CUT
  110     CHIR=CUT*CUTR**RLU(0)
          CHI=(CHIR**2-CUT**2)/(2.*CHIR)
          IF((1.-CHI)**CHIK.LT.RLU(0)) GOTO 110
        ENDIF
 
C...ENERGY DISTRIBUTION FOR PARTICLE INTO JET PLUS PARTICLE
      ELSE
        IF(IPY(17).LE.1) THEN
          IF(IABS(KPART).LE.40) CHI=RLU(0)
          IF(IABS(KPART).GT.40) CHI=1.-SQRT(RLU(0))
        ELSE
          IF(IABS(KPART).LE.40) CHI=1.-RLU(0)**(1./(1.+PYPAR(14)))
          IF(IABS(KPART).GT.40) CHI=1.-RLU(0)**(1./(1.+PYPAR(16)))
        ENDIF
        IF(IABS(KFL).GT.40) CHI=1.-CHI
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
      FUNCTION PYALPH(Q2)
 
C...RUNNING ALPHA-STRONG
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
 
C...CALCULATE NUMBER OF ACTIVE FLAVOURS NF
      NF=3
      DO 100 IFL=4,IPY(5)
  100 IF(Q2.GT.4.*ULMASS(0,IFL)**2) NF=NF+1
      B0=(33.-2.*NF)/6.
      B1=(153.-19.*NF)/6.
 
C...FIRST OR SECOND ORDER FORMULAE FOR ALPHA-STRONG
      IF(IPY(3).EQ.0) THEN
        PYALPH=PYPAR(3)
      ELSEIF(IPY(3).LE.10.AND.(IPY(12).LE.1.OR.IPY(44).NE.5)) THEN
        PYALPH=6.2832/(B0*ALOG(MAX(Q2,PYPAR(5))/PYPAR(4)**2))
      ELSEIF(IPY(3).LE.10) THEN
        PYALPH=6.2832/(B0*ALOG((Q2+PYPAR(32)**2)/PYPAR(4)**2))
      ELSEIF(IPY(12).LE.1.OR.IPY(44).NE.5) THEN
        ALG=ALOG(PYPAR(9)*MAX(Q2,PYPAR(5))/PYPAR(4)**2)
        PYALPH=6.2832/(B0*ALG)*(1.-B1/B0**2*ALOG(ALG)/ALG)
      ELSE
        ALG=ALOG(PYPAR(9)*(Q2+PYPAR(32)**2)/PYPAR(4)**2)
        PYALPH=6.2832/(B0*ALG)*(1.-B1/B0**2*ALOG(ALG)/ALG)
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
      FUNCTION PYGAMM(X)
 
C...GIVES ORDINARY GAMMA FUNCTION GAMMA(X) FOR POSITIVE, REAL ARGUMENTS;
C...SEE M. ABRAMOWITZ, I. A. STEGUN: HANDBOOK OF MATHEMATICAL FUNCTIONS
C...(DOVER, 1965) 6.1.36.
      DIMENSION B(8)
      DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857,
     &-0.756704078,0.482199394,-0.193527818,0.035868343/
 
      NX=INT(X)
      DX=X-NX
 
      PYGAMM=1.
      DO 100 I=1,8
  100 PYGAMM=PYGAMM+B(I)*DX**I
      IF(X.LT.1.) THEN
        PYGAMM=PYGAMM/X
      ELSE
        DO 110 IX=1,NX-1
  110   PYGAMM=(X-IX)*PYGAMM
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
      BLOCK DATA PYDATA
 
C...GIVE SENSIBLE DEFAULT VALUES TO ALL STATUS CODES AND PARAMETERS.
      COMMON/PYPARA/IPY(80),PYPAR(80),PYVAR(80)
      COMMON/PYSUBS/ISELEC,ISUBPR(40),IREAC(2,-6:6),IPROD(0:10,30)
      COMMON/PYINT2/KPR(-6:6,-6:6),NMX(6),ICOL(40,4,2),ICH(30),VKM2(4,4)
      COMMON/PYINT3/ISET(40),COEF(40,8),WM(40,4),NMUL(20),SIGMUL(20)
      COMMON/PYCHAR/PROC(-5:40)
      CHARACTER PROC*26
 
      DATA IPY/
     1 0,     0,     2,     2,     6,     1,     1,     6,     3,     1,
     2 3,     1,     1,     2,     1,     1,     4,     1,     1,     1,
     3 0,     1,     1,     1,     1,     1,     1,     0,     0,     0,
     4 1,     2,     1,     1,    30,    33,     1,     1,     7,     0,
     5 0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     6 0,     0,     0,     1,   100,     0,     0,     0,     0,     0,
     7 0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     8 0,     0,     0,     0,     0,     0,     0,     0,     0,     0/
      DATA (PYPAR(I),I=1,40)/
     1   7.299E-03,   2.290E-01,   2.000E-01,   2.500E-01,   4.000E+00,
     1   1.000E+00,   4.400E-01,   4.400E-01,   7.500E-02,   0.000E+00,
     2   2.000E+00,   2.000E+00,   1.000E+00,   0.000E+00,   3.000E+00,
     2   1.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   1.000E+00,
     3   2.500E-01,   1.000E+00,   2.000E+00,   1.000E-03,   4.000E+00,
     3   4.000E+00,   2.500E-01,  -1.000E+00,   0.000E+00,   0.000E+00,
     4   0.000E+00,   1.600E+00,   0.500E+00,   0.200E+00,   3.894E-01,
     4   1.000E+00,   3.300E-01,   6.600E-01,   0.000E+00,   1.000E+00/
      DATA (PYPAR(I),I=41,80)/
     5   2.260E+00,   1.000E+04,   1.000E-04,   0.000E+00,   0.000E+00,
     5   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,
     6   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,
     6   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,
     7   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,
     7   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,
     8   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,
     8   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00,   0.000E+00/
      DATA PYVAR/80*0./
      DATA ISELEC/1/,ISUBPR/40*0/
      DATA ((IREAC(I,J),J=-6,6),I=1,2)/
     1   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,
     2   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1/
      DATA ((IPROD(I,J),J=1,30),I=0,2)/
     &    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     &   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     &   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     1    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     1   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     1   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     2    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     2    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     2   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,   -1,   -1/
      DATA ((IPROD(I,J),J=1,30),I=3,5)/
     3    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     3    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     3   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     4    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     4    1,   -1,    1,   -1,    1,   -1,    0,   -1,   -1,   -1,
     4    1,    1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     5    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     5    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     5   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1/
      DATA ((IPROD(I,J),J=1,30),I=6,8)/
     6    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     6    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     6   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     7    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     7    1,    1,    1,    1,    1,    1,    0,    0,   -1,   -1,
     7   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     8   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     8   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     8   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1/
      DATA ((IPROD(I,J),J=1,30),I=9,10)/
     9   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     9   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     9   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     &   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     &   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     &   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1/
      DATA ((KPR(I,J),J=-6,6),I=-6,6)/
     6   2,   1,   1,   1,   1,   1,   5,   3,   3,   3,   3,   3,   4,
     5   1,   2,   1,   1,   1,   1,   5,   3,   3,   3,   3,   4,   3,
     4   1,   1,   2,   1,   1,   1,   5,   3,   3,   3,   4,   3,   3,
     3   1,   1,   1,   2,   1,   1,   5,   3,   3,   4,   3,   3,   3,
     2   1,   1,   1,   1,   2,   1,   5,   3,   4,   3,   3,   3,   3,
     1   1,   1,   1,   1,   1,   2,   5,   4,   3,   3,   3,   3,   3,
     &   5,   5,   5,   5,   5,   5,   6,   5,   5,   5,   5,   5,   5,
     1   3,   3,   3,   3,   3,   4,   5,   2,   1,   1,   1,   1,   1,
     2   3,   3,   3,   3,   4,   3,   5,   1,   2,   1,   1,   1,   1,
     3   3,   3,   3,   4,   3,   3,   5,   1,   1,   2,   1,   1,   1,
     4   3,   3,   4,   3,   3,   3,   5,   1,   1,   1,   2,   1,   1,
     5   3,   4,   3,   3,   3,   3,   5,   1,   1,   1,   1,   2,   1,
     6   4,   3,   3,   3,   3,   3,   5,   1,   1,   1,   1,   1,   2/
      DATA NMX/1,2,1,4,2,5/
      DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
     1 4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
     2 3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
     3 3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
     4 3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
     5 4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
     6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     7 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     8 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     9 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
      DATA ICH/2,-1,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,-3,0,-3,0,2*0,
     &0,3,3,7*0/
      DATA ((VKM2(I,J),J=1,4),I=1,4)/
     1        0.9500,        0.0500,        0.0000,        0.0000,
     2        0.0500,        0.9475,        0.0025,        0.0000,
     3        0.0000,        0.0025,        0.9975,        0.0000,
     4        0.0000,        0.0000,        0.0000,        1.0000/
      DATA ISET/
     1     1,    1,    1,    1,    4,    0,    0,    5,    6,    7,
     2     3,    3,    1,    1,    1,    1,    1,    1,    1,    1,
     3     1,    1,    1,    1,    2,    2,    8,    8,    1,    1,
     4     3,    2,    3,    0,    0,    0,    0,    0,    0,    0/
      DATA ((COEF(I,J),J=1,8),I=1,10)/
     1     1.0,    0.0,    4.0,    0.0,    0.0,    0.0,    2.0,    1.0,
     2     1.0,    0.0,    4.0,    0.0,    0.0,    0.0,    2.0,    1.0,
     3     0.0,    0.0,    4.0,    0.0,    2.0,    1.0,    0.0,    0.0,
     4     0.0,    0.0,    4.0,    0.0,    2.0,    1.0,    0.0,    0.0,
     5     1.0,    0.0,    4.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     6     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     7     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     8     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     9     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     &     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0/
      DATA ((COEF(I,J),J=1,8),I=11,20)/
     1    60.0,    1.0,    1.0,    1.5,    0.0,    0.0,    0.0,    0.0,
     2    60.0,    0.0,    1.0,    1.5,    0.0,    0.0,    0.0,    0.0,
     3    10.0,    0.0,    0.0,    0.0,    0.0,    0.5,    0.0,    0.0,
     4    10.0,    0.0,    0.0,    0.0,    0.0,    0.5,    0.0,    0.0,
     5    10.0,    0.0,    0.0,    0.0,    0.0,    0.5,    0.0,    0.0,
     6     5.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,    0.0,
     7     5.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,    0.0,
     8     5.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,    0.0,
     9     5.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,    0.0,
     &     6.0,    0.0,    0.0,    0.0,    0.5,    0.5,    0.0,    0.0/
      DATA ((COEF(I,J),J=1,8),I=21,30)/
     1    10.0,    0.0,    0.0,    0.0,    1.0,    0.2,    0.0,    0.0,
     2    10.0,    0.0,    0.0,    0.0,    0.5,    0.5,    0.0,    0.0,
     3    10.0,    0.0,    0.0,    0.0,    0.5,    1.0,    0.0,    0.0,
     4    10.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,    0.0,
     5    40.0,    0.0,    1.0,    0.6,    0.0,    0.0,    0.0,    0.0,
     6    60.0,    0.0,    1.0,    1.5,    0.0,    0.0,    0.0,    0.0,
     7     0.0,    0.5,    1.0,    0.0,    1.0,    0.5,    0.0,    0.0,
     8     0.0,    0.5,    1.0,    0.0,    1.0,    0.5,    0.0,    0.0,
     9    10.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,    0.0,
     &    10.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,    0.0/
      DATA ((COEF(I,J),J=1,8),I=31,40)/
     1    60.0,    0.0,    1.0,    1.5,    0.0,    0.0,    0.0,    0.0,
     2    60.0,    0.0,    1.0,    1.5,    0.0,    0.0,    0.0,    0.0,
     3    60.0,    1.0,    1.0,    1.5,   60.0,    1.0,    0.0,    0.0,
     4     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     5     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     6     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     7     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     8     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     9     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
     &     0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0/
      DATA WM/160*0./
      DATA (PROC(I),I=-5,0)/
     1 'MULTIPLE INTERACTIONS    ',        'QCD, WEIGHT QT**6         ',
     2 'QCD, WEIGHT QT**4        ',        'QCD, WEIGHT QT**2         ',
     3 'QCD, UNWEIGHTED          ',        'ALL                       '/
      DATA (PROC(I),I=1,20)/
     1 'Q + Q'' -> Q + Q''       ',        'Q + QB -> Q'' + QB''      ',
     2 'Q + QB -> G + G          ',        'G + Q -> G + Q            ',
     3 'G + G -> Q + QB          ',        'G + G -> G + G            ',
     4 'LOW-PT SCATTERING        ',        'DOUBLE DIFFRACTIVE        ',
     5 'SINGLE DIFFRACTIVE       ',        'ELASTIC SCATTERING        ',
     6 'Q + QB -> Z0/GAM*        ',        'Q + QB'' -> W+/-          ',
     7 'G + Q -> GAM + Q         ',        'G + Q -> Z0 + Q           ',
     8 'G + Q -> W+/- + Q''      ',        'Q + QB -> G + GAM         ',
     9 'Q + QB -> G + Z0         ',        'Q + QB'' -> G + W+/-      ',
     & 'Q + QB -> GAM + GAM      ',        'Q + QB -> GAM + Z0        '/
      DATA (PROC(I),I=21,40)/
     1 'Q + QB'' -> GAM + W+/-   ',        'Q + QB -> Z0 + Z0         ',
     2 'Q + QB'' -> Z0 + W+/-    ',        'Q + QB -> W+ + W-         ',
     3 'Q + QB -> H0             ',        'G + G -> H0               ',
     4 'Z0 + Z0 -> H0            ',        'W+ + W- -> H0             ',
     5 'Q + QB -> H0 + Z0        ',        'Q + QB'' -> H0 + W+/-     ',
     6 'Q + QB'' -> R            ',        'Q + QB'' -> H+/-          ',
     7 'Q + QB -> Z''0/Z0/GAM*   ',        '                          ',
     8 '                         ',        '                          ',
     9 '                         ',        '                          ',
     & '                         ',        '                          '/
 
      END
 
C***********************************************************************
 
      SUBROUTINE PYKCUT(X1,X2,SH,TH,QT,Q2,ICUT)
 
C...DUMMY ROUTINE, WHICH THE USER CAN REPLACE IN ORDER TO MAKE CUTS ON
C...THE KINEMATICS ON THE PARTON LEVEL BEFORE THE QCD MATRIX ELEMENTS
C...ARE EVALUATED AND THE EVENT IS GENERATED. THE CROSS-SECTION ESTIMATES
C...WILL AUTOMATICALLY TAKE THESE CUTS INTO ACCOUNT, SO THE GIVEN VALUES
C...ARE FOR THE ALLOWED PHASE SPACE REGION ONLY. ICUT=0 MEANS THAT THE
C...EVENT HAS PASSED THE CUTS, ICUT=1 THAT IT HAS FAILED.
      ICUT=0
 
      RETURN
      END
 
C***********************************************************************
 
      SUBROUTINE PSETUP(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,FLNM,I2,I3,
     &IRET,IRR)
 
C...DUMMY ROUTINE, WHICH THE USER SHOULD REPLACE IN ORDER TO ACCESS THE
C...STRUCTURE FUNCTION EVOLUTION PROGRAM OF WU-KI TUNG; SEE MANUAL.
      COMMON/LUDAT1/MST(40),PAR(80)
 
      WRITE(MST(20),1000)
      STOP
 
C...FORMAT STATEMENT FOR ERROR
 1000 FORMAT(1X,'ERROR: STRUCTURE FUNCTION EVOLUTION PROGRAM OF WU-KI',
     &' TUNG REQUESTED,'/8X,'BUT NOT LINKED (SEE MANUAL). EXECUTION ',
     &'STOPPED.')
 
      END
 
C***********************************************************************
 
      FUNCTION PDF(ISET,IHDRN,IPRTN,X,Q,IR)
 
C...DUMMY FUNCTION, WHICH THE USER SHOULD REPLACE IN ORDER TO ACCESS THE
C...STRUCTURE FUNCTION EVOLUTION PROGRAM OF WU-KI TUNG; SEE MANUAL.
      COMMON/LUDAT1/MST(40),PAR(80)
 
      PDF=0.
      WRITE(MST(20),1000)
      STOP
 
C...FORMAT STATEMENT FOR ERROR
 1000 FORMAT(1X,'ERROR: STRUCTURE FUNCTION EVOLUTION PROGRAM OF WU-KI',
     &' TUNG REQUESTED,'/8X,'BUT NOT LINKED (SEE MANUAL). EXECUTION ',
     &'STOPPED.')
 
      END