Hadr02/hijing1_383/hipyset1.35.f

0001 C
0002 C
0003 C
0004 C     Modified for HIJING program
0005 c
0006 c    modification July 22, 1997  In pyremnn put an upper limit
0007 c     on the total pt kick the parton can accumulate via multiple
0008 C     scattering. Set the upper limit to be the sqrt(s)/2,
0009 c     this is fix cronin bug for Pb+Pb events at SPS energy.
0010 c
0011 C
0012 C Last modification Oct. 1993 to comply with non-vax
0013 C machines' compiler
0014 C
0015 C
0016       SUBROUTINE LU1ENT(IP,KF,PE,THE,PHI)
0017
0018 C...Purpose: to store one parton/particle in commonblock LUJETS.
0019       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0020       SAVE /LUJETS/
0021       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0022       SAVE /LUDAT1/
0023       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0024       SAVE /LUDAT2/
0025
0026 C...Standard checks.
0027       MSTU(28)=0
0028       IF(MSTU(12).GE.1) CALL LULIST(0)
0029       IPA=MAX(1,IABS(IP))
0030       IF(IPA.GT.MSTU(4)) CALL LUERRM(21,
0031      &'(LU1ENT:) writing outside LUJETS memory')
0032       KC=LUCOMP(KF)
0033       IF(KC.EQ.0) CALL LUERRM(12,'(LU1ENT:) unknown flavour code')
0034
0035 C...Find mass. Reset K, P and V vectors.
0036       PM=0.
0037       IF(MSTU(10).EQ.1) PM=P(IPA,5)
0038       IF(MSTU(10).GE.2) PM=ULMASS(KF)
0039       DO 100 J=1,5
0040       K(IPA,J)=0
0041       P(IPA,J)=0.
0042   100 V(IPA,J)=0.
0043
0044 C...Store parton/particle in K and P vectors.
0045       K(IPA,1)=1
0046       IF(IP.LT.0) K(IPA,1)=2
0047       K(IPA,2)=KF
0048       P(IPA,5)=PM
0049       P(IPA,4)=MAX(PE,PM)
0050       PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
0051       P(IPA,1)=PA*SIN(THE)*COS(PHI)
0052       P(IPA,2)=PA*SIN(THE)*SIN(PHI)
0053       P(IPA,3)=PA*COS(THE)
0054
0055 C...Set N. Optionally fragment/decay.
0056       N=IPA
0057       IF(IP.EQ.0) CALL LUEXEC
0058
0059       RETURN
0060       END
0061
0062 C*********************************************************************
0063
0064       SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
0065
0066 C...Purpose: to store two partons/particles in their CM frame,
0067 C...with the first along the +z axis.
0068       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0069       SAVE /LUJETS/
0070       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0071       SAVE /LUDAT1/
0072       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0073       SAVE /LUDAT2/
0074
0075 C...Standard checks.
0076       MSTU(28)=0
0077       IF(MSTU(12).GE.1) CALL LULIST(0)
0078       IPA=MAX(1,IABS(IP))
0079       IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
0080      &'(LU2ENT:) writing outside LUJETS memory')
0081       KC1=LUCOMP(KF1)
0082       KC2=LUCOMP(KF2)
0083       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
0084      &'(LU2ENT:) unknown flavour code')
0085
0086 C...Find masses. Reset K, P and V vectors.
0087       PM1=0.
0088       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
0089       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
0090       PM2=0.
0091       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
0092       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
0093       DO 100 I=IPA,IPA+1
0094       DO 100 J=1,5
0095       K(I,J)=0
0096       P(I,J)=0.
0097   100 V(I,J)=0.
0098
0099 C...Check flavours.
0100       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
0101       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
0102       IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
0103      &'(LU2ENT:) unphysical flavour combination')
0104       K(IPA,2)=KF1
0105       K(IPA+1,2)=KF2
0106
0107 C...Store partons/particles in K vectors for normal case.
0108       IF(IP.GE.0) THEN
0109         K(IPA,1)=1
0110         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
0111         K(IPA+1,1)=1
0112
0113 C...Store partons in K vectors for parton shower evolution.
0114       ELSE
0115         IF(KQ1.EQ.0.OR.KQ2.EQ.0) CALL LUERRM(2,
0116      &  '(LU2ENT:) requested flavours can not develop parton shower')
0117         K(IPA,1)=3
0118         K(IPA+1,1)=3
0119         K(IPA,4)=MSTU(5)*(IPA+1)
0120         K(IPA,5)=K(IPA,4)
0121         K(IPA+1,4)=MSTU(5)*IPA
0122         K(IPA+1,5)=K(IPA+1,4)
0123       ENDIF
0124
0125 C...Check kinematics and store partons/particles in P vectors.
0126       IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
0127      &'(LU2ENT:) energy smaller than sum of masses')
0128       PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
0129      &(2.*PECM)
0130       P(IPA,3)=PA
0131       P(IPA,4)=SQRT(PM1**2+PA**2)
0132       P(IPA,5)=PM1
0133       P(IPA+1,3)=-PA
0134       P(IPA+1,4)=SQRT(PM2**2+PA**2)
0135       P(IPA+1,5)=PM2
0136
0137 C...Set N. Optionally fragment/decay.
0138       N=IPA+1
0139       IF(IP.EQ.0) CALL LUEXEC
0140
0141       RETURN
0142       END
0143
0144 C*********************************************************************
0145
0146       SUBROUTINE LU3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
0147
0148 C...Purpose: to store three partons or particles in their CM frame,
0149 C...with the first along the +z axis and the third in the (x,z)
0150 C...plane with x > 0.
0151       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0152       SAVE /LUJETS/
0153       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0154       SAVE /LUDAT1/
0155       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0156       SAVE /LUDAT2/
0157
0158 C...Standard checks.
0159       MSTU(28)=0
0160       IF(MSTU(12).GE.1) CALL LULIST(0)
0161       IPA=MAX(1,IABS(IP))
0162       IF(IPA.GT.MSTU(4)-2) CALL LUERRM(21,
0163      &'(LU3ENT:) writing outside LUJETS memory')
0164       KC1=LUCOMP(KF1)
0165       KC2=LUCOMP(KF2)
0166       KC3=LUCOMP(KF3)
0167       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LUERRM(12,
0168      &'(LU3ENT:) unknown flavour code')
0169
0170 C...Find masses. Reset K, P and V vectors.
0171       PM1=0.
0172       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
0173       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
0174       PM2=0.
0175       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
0176       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
0177       PM3=0.
0178       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
0179       IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
0180       DO 100 I=IPA,IPA+2
0181       DO 100 J=1,5
0182       K(I,J)=0
0183       P(I,J)=0.
0184   100 V(I,J)=0.
0185
0186 C...Check flavours.
0187       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
0188       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
0189       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
0190       IF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
0191       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.KQ1+KQ3.EQ.4))
0192      &THEN
0193       ELSE
0194         CALL LUERRM(2,'(LU3ENT:) unphysical flavour combination')
0195       ENDIF
0196       K(IPA,2)=KF1
0197       K(IPA+1,2)=KF2
0198       K(IPA+2,2)=KF3
0199
0200 C...Store partons/particles in K vectors for normal case.
0201       IF(IP.GE.0) THEN
0202         K(IPA,1)=1
0203         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
0204         K(IPA+1,1)=1
0205         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
0206         K(IPA+2,1)=1
0207
0208 C...Store partons in K vectors for parton shower evolution.
0209       ELSE
0210         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0) CALL LUERRM(2,
0211      &  '(LU3ENT:) requested flavours can not develop parton shower')
0212         K(IPA,1)=3
0213         K(IPA+1,1)=3
0214         K(IPA+2,1)=3
0215         KCS=4
0216         IF(KQ1.EQ.-1) KCS=5
0217         K(IPA,KCS)=MSTU(5)*(IPA+1)
0218         K(IPA,9-KCS)=MSTU(5)*(IPA+2)
0219         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
0220         K(IPA+1,9-KCS)=MSTU(5)*IPA
0221         K(IPA+2,KCS)=MSTU(5)*IPA
0222         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
0223       ENDIF
0224
0225 C...Check kinematics.
0226       MKERR=0
0227       IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.
0228      &0.5*X3*PECM.LE.PM3) MKERR=1
0229       PA1=SQRT(MAX(0.,(0.5*X1*PECM)**2-PM1**2))
0230       PA2=SQRT(MAX(0.,(0.5*(2.-X1-X3)*PECM)**2-PM2**2))
0231       PA3=SQRT(MAX(0.,(0.5*X3*PECM)**2-PM3**2))
0232       CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2)
0233       CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3)
0234       IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1
0235       CTHE3=MAX(-1.,MIN(1.,CTHE3))
0236       IF(MKERR.NE.0) CALL LUERRM(13,
0237      &'(LU3ENT:) unphysical kinematical variable setup')
0238
0239 C...Store partons/particles in P vectors.
0240       P(IPA,3)=PA1
0241       P(IPA,4)=SQRT(PA1**2+PM1**2)
0242       P(IPA,5)=PM1
0243       P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
0244       P(IPA+2,3)=PA3*CTHE3
0245       P(IPA+2,4)=SQRT(PA3**2+PM3**2)
0246       P(IPA+2,5)=PM3
0247       P(IPA+1,1)=-P(IPA+2,1)
0248       P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
0249       P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
0250       P(IPA+1,5)=PM2
0251
0252 C...Set N. Optionally fragment/decay.
0253       N=IPA+2
0254       IF(IP.EQ.0) CALL LUEXEC
0255
0256       RETURN
0257       END
0258
0259 C*********************************************************************
0260
0261       SUBROUTINE LU4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
0262
0263 C...Purpose: to store four partons or particles in their CM frame, with
0264 C...the first along the +z axis, the last in the xz plane with x > 0
0265 C...and the second having y < 0 and y > 0 with equal probability.
0266       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0267       SAVE /LUJETS/
0268       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0269       SAVE /LUDAT1/
0270       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0271       SAVE /LUDAT2/
0272
0273 C...Standard checks.
0274       MSTU(28)=0
0275       IF(MSTU(12).GE.1) CALL LULIST(0)
0276       IPA=MAX(1,IABS(IP))
0277       IF(IPA.GT.MSTU(4)-3) CALL LUERRM(21,
0278      &'(LU4ENT:) writing outside LUJETS momory')
0279       KC1=LUCOMP(KF1)
0280       KC2=LUCOMP(KF2)
0281       KC3=LUCOMP(KF3)
0282       KC4=LUCOMP(KF4)
0283       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LUERRM(12,
0284      &'(LU4ENT:) unknown flavour code')
0285
0286 C...Find masses. Reset K, P and V vectors.
0287       PM1=0.
0288       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
0289       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
0290       PM2=0.
0291       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
0292       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
0293       PM3=0.
0294       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
0295       IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
0296       PM4=0.
0297       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
0298       IF(MSTU(10).GE.2) PM4=ULMASS(KF4)
0299       DO 100 I=IPA,IPA+3
0300       DO 100 J=1,5
0301       K(I,J)=0
0302       P(I,J)=0.
0303   100 V(I,J)=0.
0304
0305 C...Check flavours.
0306       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
0307       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
0308       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
0309       KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
0310       IF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
0311       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
0312      &KQ1+KQ4.EQ.4)) THEN
0313       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
0314      &THEN
0315       ELSE
0316         CALL LUERRM(2,'(LU4ENT:) unphysical flavour combination')
0317       ENDIF
0318       K(IPA,2)=KF1
0319       K(IPA+1,2)=KF2
0320       K(IPA+2,2)=KF3
0321       K(IPA+3,2)=KF4
0322
0323 C...Store partons/particles in K vectors for normal case.
0324       IF(IP.GE.0) THEN
0325         K(IPA,1)=1
0326         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
0327         K(IPA+1,1)=1
0328         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
0329      &  K(IPA+1,1)=2
0330         K(IPA+2,1)=1
0331         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
0332         K(IPA+3,1)=1
0333
0334 C...Store partons for parton shower evolution from q-g-g-qbar or
0335 C...g-g-g-g event.
0336       ELSEIF(KQ1+KQ2.NE.0) THEN
0337         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0.OR.KQ4.EQ.0) CALL LUERRM(2,
0338      &  '(LU4ENT:) requested flavours can not develop parton shower')
0339         K(IPA,1)=3
0340         K(IPA+1,1)=3
0341         K(IPA+2,1)=3
0342         K(IPA+3,1)=3
0343         KCS=4
0344         IF(KQ1.EQ.-1) KCS=5
0345         K(IPA,KCS)=MSTU(5)*(IPA+1)
0346         K(IPA,9-KCS)=MSTU(5)*(IPA+3)
0347         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
0348         K(IPA+1,9-KCS)=MSTU(5)*IPA
0349         K(IPA+2,KCS)=MSTU(5)*(IPA+3)
0350         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
0351         K(IPA+3,KCS)=MSTU(5)*IPA
0352         K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
0353
0354 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
0355       ELSE
0356         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0.OR.KQ4.EQ.0) CALL LUERRM(2,
0357      &  '(LU4ENT:) requested flavours can not develop parton shower')
0358         K(IPA,1)=3
0359         K(IPA+1,1)=3
0360         K(IPA+2,1)=3
0361         K(IPA+3,1)=3
0362         K(IPA,4)=MSTU(5)*(IPA+1)
0363         K(IPA,5)=K(IPA,4)
0364         K(IPA+1,4)=MSTU(5)*IPA
0365         K(IPA+1,5)=K(IPA+1,4)
0366         K(IPA+2,4)=MSTU(5)*(IPA+3)
0367         K(IPA+2,5)=K(IPA+2,4)
0368         K(IPA+3,4)=MSTU(5)*(IPA+2)
0369         K(IPA+3,5)=K(IPA+3,4)
0370       ENDIF
0371
0372 C...Check kinematics.
0373       MKERR=0
0374       IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)*
0375      &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1
0376       PA1=SQRT(MAX(0.,(0.5*X1*PECM)**2-PM1**2))
0377       PA2=SQRT(MAX(0.,(0.5*X2*PECM)**2-PM2**2))
0378       PA3=SQRT(MAX(0.,(0.5*(2.-X1-X2-X4)*PECM)**2-PM3**2))
0379       PA4=SQRT(MAX(0.,(0.5*X4*PECM)**2-PM4**2))
0380       X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
0381       CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4)
0382       IF(ABS(CTHE4).GE.1.002) MKERR=1
0383       CTHE4=MAX(-1.,MIN(1.,CTHE4))
0384       STHE4=SQRT(1.-CTHE4**2)
0385       CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2)
0386       IF(ABS(CTHE2).GE.1.002) MKERR=1
0387       CTHE2=MAX(-1.,MIN(1.,CTHE2))
0388       STHE2=SQRT(1.-CTHE2**2)
0389       CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/
0390      &(4.*PA2*STHE2*PA4*STHE4)
0391       IF(ABS(CPHI2).GE.1.05) MKERR=1
0392       CPHI2=MAX(-1.,MIN(1.,CPHI2))
0393       IF(MKERR.EQ.1) CALL LUERRM(13,
0394      &'(LU4ENT:) unphysical kinematical variable setup')
0395
0396 C...Store partons/particles in P vectors.
0397       P(IPA,3)=PA1
0398       P(IPA,4)=SQRT(PA1**2+PM1**2)
0399       P(IPA,5)=PM1
0400       P(IPA+3,1)=PA4*STHE4
0401       P(IPA+3,3)=PA4*CTHE4
0402       P(IPA+3,4)=SQRT(PA4**2+PM4**2)
0403       P(IPA+3,5)=PM4
0404       P(IPA+1,1)=PA2*STHE2*CPHI2
0405       P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLU(0)+0.5)
0406       P(IPA+1,3)=PA2*CTHE2
0407       P(IPA+1,4)=SQRT(PA2**2+PM2**2)
0408       P(IPA+1,5)=PM2
0409       P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
0410       P(IPA+2,2)=-P(IPA+1,2)
0411       P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
0412       P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
0413       P(IPA+2,5)=PM3
0414
0415 C...Set N. Optionally fragment/decay.
0416       N=IPA+3
0417       IF(IP.EQ.0) CALL LUEXEC
0418
0419       RETURN
0420       END
0421
0422 C*********************************************************************
0423
0424       SUBROUTINE LUJOIN(NJOIN,IJOIN)
0425
0426 C...Purpose: to connect a sequence of partons with colour flow indices,
0427 C...as required for subsequent shower evolution (or other operations).
0428       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0429       SAVE /LUJETS/
0430       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0431       SAVE /LUDAT1/
0432       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0433       SAVE /LUDAT2/
0434       DIMENSION IJOIN(*)
0435
0436 C...Check that partons are of right types to be connected.
0437       IF(NJOIN.LT.2) GOTO 120
0438       KQSUM=0
0439       DO 100 IJN=1,NJOIN
0440       I=IJOIN(IJN)
0441       IF(I.LE.0.OR.I.GT.N) GOTO 120
0442       IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
0443       KC=LUCOMP(K(I,2))
0444       IF(KC.EQ.0) GOTO 120
0445       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
0446       IF(KQ.EQ.0) GOTO 120
0447       IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
0448       IF(KQ.NE.2) KQSUM=KQSUM+KQ
0449   100 IF(IJN.EQ.1) KQS=KQ
0450       IF(KQSUM.NE.0) GOTO 120
0451
0452 C...Connect the partons sequentially (closing for gluon loop).
0453       KCS=(9-KQS)/2
0454       IF(KQS.EQ.2) KCS=INT(4.5+RLU(0))
0455       DO 110 IJN=1,NJOIN
0456       I=IJOIN(IJN)
0457       K(I,1)=3
0458       IF(IJN.NE.1) IP=IJOIN(IJN-1)
0459       IF(IJN.EQ.1) IP=IJOIN(NJOIN)
0460       IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
0461       IF(IJN.EQ.NJOIN) IN=IJOIN(1)
0462       K(I,KCS)=MSTU(5)*IN
0463       K(I,9-KCS)=MSTU(5)*IP
0464       IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
0465   110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
0466
0467 C...Error exit: no action taken.
0468       RETURN
0469   120 CALL LUERRM(12,
0470      &'(LUJOIN:) given entries can not be joined by one string')
0471
0472       RETURN
0473       END
0474
0475 C*********************************************************************
0476
0477       SUBROUTINE LUGIVE(CHIN)
0478
0479 C...Purpose: to set values of commonblock variables.
0480       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0481       SAVE /LUJETS/
0482       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0483       SAVE /LUDAT1/
0484       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0485       SAVE /LUDAT2/
0486       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0487       SAVE /LUDAT3/
0488       COMMON/LUDAT4/CHAF(500)
0489       CHARACTER CHAF*8
0490       SAVE /LUDAT4/
0491       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,
0492      &CHNAM*4,CHVAR(17)*4,CHALP(2)*26,CHIND*8,CHINI*10,CHINR*16
0493       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
0494      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/
0495       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
0496      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
0497
0498 C...Length of character variable. Subdivide it into instructions.
0499       IF(MSTU(12).GE.1) CALL LULIST(0)
0500       CHBIT=CHIN//' '
0501       LBIT=101
0502   100 LBIT=LBIT-1
0503       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
0504       LTOT=0
0505       DO 110 LCOM=1,LBIT
0506       IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
0507       LTOT=LTOT+1
0508       CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
0509   110 CONTINUE
0510       LLOW=0
0511   120 LHIG=LLOW+1
0512   130 LHIG=LHIG+1
0513       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
0514       LBIT=LHIG-LLOW-1
0515       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
0516
0517 C...Identify commonblock variable.
0518       LNAM=1
0519   140 LNAM=LNAM+1
0520       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
0521      &LNAM.LE.4) GOTO 140
0522       CHNAM=CHBIT(1:LNAM-1)//' '
0523       DO 150 LCOM=1,LNAM-1
0524       DO 150 LALP=1,26
0525   150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
0526      &CHALP(2)(LALP:LALP)
0527       IVAR=0
0528       DO 160 IV=1,17
0529   160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
0530       IF(IVAR.EQ.0) THEN
0531         CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
0532         LLOW=LHIG
0533         IF(LLOW.LT.LTOT) GOTO 120
0534         RETURN
0535       ENDIF
0536
0537 C...Identify any indices.
0538       I=0
0539       J=0
0540       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
0541         LIND=LNAM
0542   170   LIND=LIND+1
0543         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
0544         CHIND=' '
0545         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
0546      &  AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
0547           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
0548           READ(CHIND,'(I8)') I1
0549           I=LUCOMP(I1)
0550         ELSE
0551           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
0552           READ(CHIND,'(I8)') I
0553         ENDIF
0554         LNAM=LIND
0555         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
0556       ENDIF
0557       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
0558         LIND=LNAM
0559   180   LIND=LIND+1
0560         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
0561         CHIND=' '
0562         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
0563         READ(CHIND,'(I8)') J
0564         LNAM=LIND+1
0565       ENDIF
0566
0567 C...Check that indices allowed and save old value.
0568       IERR=1
0569       IF(CHBIT(LNAM:LNAM).NE.'=') GOTO 190
0570       IF(IVAR.EQ.1) THEN
0571         IF(I.NE.0.OR.J.NE.0) GOTO 190
0572         IOLD=N
0573       ELSEIF(IVAR.EQ.2) THEN
0574         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0575         IOLD=K(I,J)
0576       ELSEIF(IVAR.EQ.3) THEN
0577         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0578         ROLD=P(I,J)
0579       ELSEIF(IVAR.EQ.4) THEN
0580         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0581         ROLD=V(I,J)
0582       ELSEIF(IVAR.EQ.5) THEN
0583         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0584         IOLD=MSTU(I)
0585       ELSEIF(IVAR.EQ.6) THEN
0586         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0587         ROLD=PARU(I)
0588       ELSEIF(IVAR.EQ.7) THEN
0589         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0590         IOLD=MSTJ(I)
0591       ELSEIF(IVAR.EQ.8) THEN
0592         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0593         ROLD=PARJ(I)
0594       ELSEIF(IVAR.EQ.9) THEN
0595         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
0596         IOLD=KCHG(I,J)
0597       ELSEIF(IVAR.EQ.10) THEN
0598         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.4) GOTO 190
0599         ROLD=PMAS(I,J)
0600       ELSEIF(IVAR.EQ.11) THEN
0601         IF(I.LT.1.OR.I.GT.2000.OR.J.NE.0) GOTO 190
0602         ROLD=PARF(I)
0603       ELSEIF(IVAR.EQ.12) THEN
0604         IF(I.LT.1.OR.I.GT.4.OR.J.LT.1.OR.J.GT.4) GOTO 190
0605         ROLD=VCKM(I,J)
0606       ELSEIF(IVAR.EQ.13) THEN
0607         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
0608         IOLD=MDCY(I,J)
0609       ELSEIF(IVAR.EQ.14) THEN
0610         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.2) GOTO 190
0611         IOLD=MDME(I,J)
0612       ELSEIF(IVAR.EQ.15) THEN
0613         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.NE.0) GOTO 190
0614         ROLD=BRAT(I)
0615       ELSEIF(IVAR.EQ.16) THEN
0616         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.5) GOTO 190
0617         IOLD=KFDP(I,J)
0618       ELSEIF(IVAR.EQ.17) THEN
0619         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.NE.0) GOTO 190
0620         CHOLD=CHAF(I)
0621       ENDIF
0622       IERR=0
0623   190 IF(IERR.EQ.1) THEN
0624         CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
0625      &  CHBIT(1:LNAM-1))
0626         LLOW=LHIG
0627         IF(LLOW.LT.LTOT) GOTO 120
0628         RETURN
0629       ENDIF
0630
0631 C...Print current value of variable. Loop back.
0632       IF(LNAM.GE.LBIT) THEN
0633         CHBIT(LNAM:14)=' '
0634         CHBIT(15:60)=' has the value                                '
0635         IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0636      &  IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0637           WRITE(CHBIT(51:60),'(I10)') IOLD
0638         ELSEIF(IVAR.NE.17) THEN
0639           WRITE(CHBIT(47:60),'(F14.5)') ROLD
0640         ELSE
0641           CHBIT(53:60)=CHOLD
0642         ENDIF
0643         IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
0644         LLOW=LHIG
0645         IF(LLOW.LT.LTOT) GOTO 120
0646         RETURN
0647       ENDIF
0648
0649 C...Read in new variable value.
0650       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0651      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0652         CHINI=' '
0653         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
0654         READ(CHINI,'(I10)') INEW
0655       ELSEIF(IVAR.NE.17) THEN
0656         CHINR=' '
0657         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
0658         READ(CHINR,'(F16.2)') RNEW
0659       ELSE
0660         CHNEW=CHBIT(LNAM+1:LBIT)//' '
0661       ENDIF
0662
0663 C...Store new variable value.
0664       IF(IVAR.EQ.1) THEN
0665         N=INEW
0666       ELSEIF(IVAR.EQ.2) THEN
0667         K(I,J)=INEW
0668       ELSEIF(IVAR.EQ.3) THEN
0669         P(I,J)=RNEW
0670       ELSEIF(IVAR.EQ.4) THEN
0671         V(I,J)=RNEW
0672       ELSEIF(IVAR.EQ.5) THEN
0673         MSTU(I)=INEW
0674       ELSEIF(IVAR.EQ.6) THEN
0675         PARU(I)=RNEW
0676       ELSEIF(IVAR.EQ.7) THEN
0677         MSTJ(I)=INEW
0678       ELSEIF(IVAR.EQ.8) THEN
0679         PARJ(I)=RNEW
0680       ELSEIF(IVAR.EQ.9) THEN
0681         KCHG(I,J)=INEW
0682       ELSEIF(IVAR.EQ.10) THEN
0683         PMAS(I,J)=RNEW
0684       ELSEIF(IVAR.EQ.11) THEN
0685         PARF(I)=RNEW
0686       ELSEIF(IVAR.EQ.12) THEN
0687         VCKM(I,J)=RNEW
0688       ELSEIF(IVAR.EQ.13) THEN
0689         MDCY(I,J)=INEW
0690       ELSEIF(IVAR.EQ.14) THEN
0691         MDME(I,J)=INEW
0692       ELSEIF(IVAR.EQ.15) THEN
0693         BRAT(I)=RNEW
0694       ELSEIF(IVAR.EQ.16) THEN
0695         KFDP(I,J)=INEW
0696       ELSEIF(IVAR.EQ.17) THEN
0697         CHAF(I)=CHNEW
0698       ENDIF
0699
0700 C...Write old and new value. Loop back.
0701       CHBIT(LNAM:14)=' '
0702       CHBIT(15:60)=' changed from                to               '
0703       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0704      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0705         WRITE(CHBIT(33:42),'(I10)') IOLD
0706         WRITE(CHBIT(51:60),'(I10)') INEW
0707       ELSEIF(IVAR.NE.17) THEN
0708         WRITE(CHBIT(29:42),'(F14.5)') ROLD
0709         WRITE(CHBIT(47:60),'(F14.5)') RNEW
0710       ELSE
0711         CHBIT(35:42)=CHOLD
0712         CHBIT(53:60)=CHNEW
0713       ENDIF
0714       IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
0715       LLOW=LHIG
0716       IF(LLOW.LT.LTOT) GOTO 120
0717
0718 C...Format statement for output on unit MSTU(11) (by default 6).
0719  1000 FORMAT(5X,A60)
0720
0721       RETURN
0722       END
0723
0724 C*********************************************************************
0725
0726       SUBROUTINE LUEXEC
0727
0728 C...Purpose: to administrate the fragmentation and decay chain.
0729       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0730       SAVE /LUJETS/
0731       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0732       SAVE /LUDAT1/
0733       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0734       SAVE /LUDAT2/
0735       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0736       SAVE /LUDAT3/
0737       DIMENSION PS(2,6)
0738
0739 C...Initialize and reset.
0740       MSTU(24)=0
0741       IF(MSTU(12).GE.1) CALL LULIST(0)
0742       MSTU(31)=MSTU(31)+1
0743       MSTU(1)=0
0744       MSTU(2)=0
0745       MSTU(3)=0
0746       MCONS=1
0747
0748 C...Sum up momentum, energy and charge for starting entries.
0749       NSAV=N
0750       DO 100 I=1,2
0751       DO 100 J=1,6
0752   100 PS(I,J)=0.
0753       DO 120 I=1,N
0754       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
0755       DO 110 J=1,4
0756   110 PS(1,J)=PS(1,J)+P(I,J)
0757       PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
0758   120 CONTINUE
0759       PARU(21)=PS(1,4)
0760
0761 C...Prepare system for subsequent fragmentation/decay.
0762       CALL LUPREP(0)
0763
0764 C...Loop through jet fragmentation and particle decays.
0765       MBE=0
0766   130 MBE=MBE+1
0767       IP=0
0768   140 IP=IP+1
0769       KC=0
0770       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
0771       IF(KC.EQ.0) THEN
0772
0773 C...Particle decay if unstable and allowed. Save long-lived particle
0774 C...decays until second pass after Bose-Einstein effects.
0775       ELSEIF(KCHG(KC,2).EQ.0) THEN
0776         IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.
0777      &  EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
0778      &  CALL LUDECY(IP)
0779
0780 C...Decay products may develop a shower.
0781         IF(MSTJ(92).GT.0) THEN
0782           IP1=MSTJ(92)
0783           QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
0784      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
0785           CALL LUSHOW(IP1,IP1+1,QMAX)
0786           CALL LUPREP(IP1)
0787           MSTJ(92)=0
0788         ELSEIF(MSTJ(92).LT.0) THEN
0789           IP1=-MSTJ(92)
0790           CALL LUSHOW(IP1,-3,P(IP,5))
0791           CALL LUPREP(IP1)
0792           MSTJ(92)=0
0793         ENDIF
0794
0795 C...Jet fragmentation: string or independent fragmentation.
0796       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
0797         MFRAG=MSTJ(1)
0798         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
0799         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
0800           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
0801      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
0802             IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
0803           ENDIF
0804         ENDIF
0805         IF(MFRAG.EQ.1) CALL LUSTRF(IP)
0806         IF(MFRAG.EQ.2) CALL LUINDF(IP)
0807         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
0808         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
0809       ENDIF
0810
0811 C...Loop back if enough space left in LUJETS and no error abort.
0812       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
0813       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
0814         GOTO 140
0815       ELSEIF(IP.LT.N) THEN
0816         CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')
0817       ENDIF
0818
0819 C...Include simple Bose-Einstein effect parametrization if desired.
0820       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
0821         CALL LUBOEI(NSAV)
0822         GOTO 130
0823       ENDIF
0824
0825 C...Check that momentum, energy and charge were conserved.
0826       DO 160 I=1,N
0827       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
0828       DO 150 J=1,4
0829   150 PS(2,J)=PS(2,J)+P(I,J)
0830       PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
0831   160 CONTINUE
0832       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
0833      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
0834       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
0835      &'(LUEXEC:) four-momentum was not conserved')
0836       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
0837      &'(LUEXEC:) charge was not conserved')
0838
0839       RETURN
0840       END
0841
0842 C*********************************************************************
0843
0844       SUBROUTINE LUPREP(IP)
0845
0846 C...Purpose: to rearrange partons along strings, to allow small systems
0847 C...to collapse into one or two particles and to check flavours.
0848       IMPLICIT DOUBLE PRECISION(D)
0849       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0850       SAVE /LUJETS/
0851       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0852       SAVE /LUDAT1/
0853       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0854       SAVE /LUDAT2/
0855       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0856       SAVE /LUDAT3/
0857       DIMENSION DPS(5),DPC(5),UE(3)
0858
0859 C...Rearrange parton shower product listing along strings: begin loop.
0860       I1=N
0861       DO 130 MQGST=1,2
0862       DO 120 I=MAX(1,IP),N
0863       IF(K(I,1).NE.3) GOTO 120
0864       KC=LUCOMP(K(I,2))
0865       IF(KC.EQ.0) GOTO 120
0866       KQ=KCHG(KC,2)
0867       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
0868
0869 C...Pick up loose string end.
0870       KCS=4
0871       IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
0872       IA=I
0873       NSTP=0
0874   100 NSTP=NSTP+1
0875       IF(NSTP.GT.4*N) THEN
0876         CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
0877         RETURN
0878       ENDIF
0879
0880 C...Copy undecayed parton.
0881       IF(K(IA,1).EQ.3) THEN
0882         IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
0883           CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS')
0884           RETURN
0885         ENDIF
0886         I1=I1+1
0887         K(I1,1)=2
0888         IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
0889         K(I1,2)=K(IA,2)
0890         K(I1,3)=IA
0891         K(I1,4)=0
0892         K(I1,5)=0
0893         DO 110 J=1,5
0894         P(I1,J)=P(IA,J)
0895   110   V(I1,J)=V(IA,J)
0896         K(IA,1)=K(IA,1)+10
0897         IF(K(I1,1).EQ.1) GOTO 120
0898       ENDIF
0899
0900 C...Go to next parton in colour space.
0901       IB=IA
0902       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
0903      &NE.0) THEN
0904         IA=MOD(K(IB,KCS),MSTU(5))
0905         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
0906         MREV=0
0907       ELSE
0908         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
0909      &  EQ.0) KCS=9-KCS
0910         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
0911         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
0912         MREV=1
0913       ENDIF
0914       IF(IA.LE.0.OR.IA.GT.N) THEN
0915         CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
0916         RETURN
0917       ENDIF
0918       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
0919      &MSTU(5)).EQ.IB) THEN
0920         IF(MREV.EQ.1) KCS=9-KCS
0921         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
0922         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
0923       ELSE
0924         IF(MREV.EQ.0) KCS=9-KCS
0925         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
0926         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
0927       ENDIF
0928       IF(IA.NE.I) GOTO 100
0929       K(I1,1)=1
0930   120 CONTINUE
0931   130 CONTINUE
0932       N=I1
0933
0934 C...Find lowest-mass colour singlet jet system, OK if above threshold.
0935       IF(MSTJ(14).LE.0) GOTO 320
0936       NS=N
0937   140 NSIN=N-NS
0938       PDM=1.+PARJ(32)
0939       IC=0
0940       DO 190 I=MAX(1,IP),NS
0941       IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
0942       ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
0943         NSIN=NSIN+1
0944         IC=I
0945         DO 150 J=1,4
0946   150   DPS(J)=P(I,J)
0947         MSTJ(93)=1
0948         DPS(5)=ULMASS(K(I,2))
0949       ELSEIF(K(I,1).EQ.2) THEN
0950         DO 160 J=1,4
0951   160   DPS(J)=DPS(J)+P(I,J)
0952       ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
0953         DO 170 J=1,4
0954   170   DPS(J)=DPS(J)+P(I,J)
0955         MSTJ(93)=1
0956         DPS(5)=DPS(5)+ULMASS(K(I,2))
0957         PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)
0958         IF(PD.LT.PDM) THEN
0959           PDM=PD
0960           DO 180 J=1,5
0961   180     DPC(J)=DPS(J)
0962           IC1=IC
0963           IC2=I
0964         ENDIF
0965         IC=0
0966       ELSE
0967         NSIN=NSIN+1
0968       ENDIF
0969   190 CONTINUE
0970       IF(PDM.GE.PARJ(32)) GOTO 320
0971
0972 C...Fill small-mass system as cluster.
0973       NSAV=N
0974       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
0975       K(N+1,1)=11
0976       K(N+1,2)=91
0977       K(N+1,3)=IC1
0978       K(N+1,4)=N+2
0979       K(N+1,5)=N+3
0980       P(N+1,1)=DPC(1)
0981       P(N+1,2)=DPC(2)
0982       P(N+1,3)=DPC(3)
0983       P(N+1,4)=DPC(4)
0984       P(N+1,5)=PECM
0985
0986 C...Form two particles from flavours of lowest-mass system, if feasible.
0987       K(N+2,1)=1
0988       K(N+3,1)=1
0989       IF(MSTU(16).NE.2) THEN
0990         K(N+2,3)=N+1
0991         K(N+3,3)=N+1
0992       ELSE
0993         K(N+2,3)=IC1
0994         K(N+3,3)=IC2
0995       ENDIF
0996       K(N+2,4)=0
0997       K(N+3,4)=0
0998       K(N+2,5)=0
0999       K(N+3,5)=0
1000       IF(IABS(K(IC1,2)).NE.21) THEN
1001         KC1=LUCOMP(K(IC1,2))
1002         KC2=LUCOMP(K(IC2,2))
1003         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
1004         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
1005         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
1006         IF(KQ1+KQ2.NE.0) GOTO 320
1007   200   CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
1008         CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
1009         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
1010       ELSE
1011         IF(IABS(K(IC2,2)).NE.21) GOTO 320
1012   210   CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
1013         CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
1014         CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
1015         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
1016       ENDIF
1017       P(N+2,5)=ULMASS(K(N+2,2))
1018       P(N+3,5)=ULMASS(K(N+3,2))
1019       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
1020       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
1021
1022 C...Perform two-particle decay of jet system, if possible.
1023       IF(PECM.GE.0.02*DPC(4)) THEN
1024         PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
1025      &  (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
1026         UE(3)=2.*RLU(0)-1.
1027         PHI=PARU(2)*RLU(0)
1028         UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1029         UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1030         DO 220 J=1,3
1031         P(N+2,J)=PA*UE(J)
1032   220   P(N+3,J)=-PA*UE(J)
1033         P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
1034         P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
1035         CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1036      &  DPC(3)/DPC(4))
1037       ELSE
1038         NP=0
1039         DO 230 I=IC1,IC2
1040   230   IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1041         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1042      &  P(IC1,3)*P(IC2,3)
1043         IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
1044         HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
1045         HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
1046         HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
1047      &  (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
1048         HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
1049         HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
1050         HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
1051         DO 240 J=1,4
1052         P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
1053   240   P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
1054       ENDIF
1055       DO 250 J=1,4
1056       V(N+1,J)=V(IC1,J)
1057       V(N+2,J)=V(IC1,J)
1058   250 V(N+3,J)=V(IC2,J)
1059       V(N+1,5)=0.
1060       V(N+2,5)=0.
1061       V(N+3,5)=0.
1062       N=N+3
1063       GOTO 300
1064
1065 C...Else form one particle from the flavours available, if possible.
1066   260 K(N+1,5)=N+2
1067       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1068         GOTO 320
1069       ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1070         CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1071       ELSE
1072         KFLN=1+INT((2.+PARJ(2))*RLU(0))
1073         CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1074       ENDIF
1075       IF(K(N+2,2).EQ.0) GOTO 260
1076       P(N+2,5)=ULMASS(K(N+2,2))
1077
1078 C...Find parton/particle which combines to largest extra mass.
1079       IR=0
1080       HA=0.
1081       DO 280 MCOMB=1,3
1082       IF(IR.NE.0) GOTO 280
1083       DO 270 I=MAX(1,IP),N
1084       IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
1085      &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
1086       IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
1087       IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
1088       IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
1089       IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
1090      &GOTO 270
1091       HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
1092       IF(HCR.GT.HA) THEN
1093         IR=I
1094         HA=HCR
1095       ENDIF
1096   270 CONTINUE
1097   280 CONTINUE
1098
1099 C...Shuffle energy and momentum to put new particle on mass shell.
1100       HB=PECM**2+HA
1101       HC=P(N+2,5)**2+HA
1102       HD=P(IR,5)**2+HA
1103 C******************CHANGES BY HIJING************
1104       HK2=0.0
1105       IF(HA**2-(PECM*P(IR,5))**2.EQ.0.0.OR.HB+HD.EQ.0.0) GO TO 285
1106 C******************
1107       HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
1108      &(HA**2-(PECM*P(IR,5))**2))-(HB+HC))/(HB+HD)
1109   285 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
1110       DO 290 J=1,4
1111       P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)
1112       P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)
1113       V(N+1,J)=V(IC1,J)
1114   290 V(N+2,J)=V(IC1,J)
1115       V(N+1,5)=0.
1116       V(N+2,5)=0.
1117       N=N+2
1118
1119 C...Mark collapsed system and store daughter pointers. Iterate.
1120   300 DO 310 I=IC1,IC2
1121       IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
1122      &THEN
1123         K(I,1)=K(I,1)+10
1124         IF(MSTU(16).NE.2) THEN
1125           K(I,4)=NSAV+1
1126           K(I,5)=NSAV+1
1127         ELSE
1128           K(I,4)=NSAV+2
1129           K(I,5)=N
1130         ENDIF
1131       ENDIF
1132   310 CONTINUE
1133       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1134
1135 C...Check flavours and invariant masses in parton systems.
1136   320 NP=0
1137       KFN=0
1138       KQS=0
1139       DO 330 J=1,5
1140   330 DPS(J)=0.
1141       DO 360 I=MAX(1,IP),N
1142       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
1143       KC=LUCOMP(K(I,2))
1144       IF(KC.EQ.0) GOTO 360
1145       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1146       IF(KQ.EQ.0) GOTO 360
1147       NP=NP+1
1148       IF(KQ.NE.2) THEN
1149         KFN=KFN+1
1150         KQS=KQS+KQ
1151         MSTJ(93)=1
1152         DPS(5)=DPS(5)+ULMASS(K(I,2))
1153       ENDIF
1154       DO 340 J=1,4
1155   340 DPS(J)=DPS(J)+P(I,J)
1156       IF(K(I,1).EQ.1) THEN
1157         IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
1158      &  LUERRM(2,'(LUPREP:) unphysical flavour combination')
1159         IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
1160      &  (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,
1161      &  '(LUPREP:) too small mass in jet system')
1162         NP=0
1163         KFN=0
1164         KQS=0
1165         DO 350 J=1,5
1166   350   DPS(J)=0.
1167       ENDIF
1168   360 CONTINUE
1169
1170       RETURN
1171       END
1172
1173 C*********************************************************************
1174
1175       SUBROUTINE LUSTRF(IP)
1176 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1177 C...jet system according to the Lund string fragmentation model.
1178       IMPLICIT DOUBLE PRECISION(D)
1179       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
1180       SAVE /LUJETS/
1181       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1182       SAVE /LUDAT1/
1183       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1184       SAVE /LUDAT2/
1185       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
1186      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
1187      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5)
1188
1189 C...Function: four-product of two vectors.
1190       FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
1191       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
1192      &DP(I,3)*DP(J,3)
1193
1194 C...Reset counters. Identify parton system.
1195       MSTJ(91)=0
1196       NSAV=N
1197       NP=0
1198       KQSUM=0
1199       DO 100 J=1,5
1200   100 DPS(J)=0.
1201       MJU(1)=0
1202       MJU(2)=0
1203       I=IP-1
1204   110 I=I+1
1205       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1206         CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
1207         IF(MSTU(21).GE.1) RETURN
1208       ENDIF
1209       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1210       KC=LUCOMP(K(I,2))
1211       IF(KC.EQ.0) GOTO 110
1212       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1213       IF(KQ.EQ.0) GOTO 110
1214       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
1215         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1216         IF(MSTU(21).GE.1) RETURN
1217       ENDIF
1218
1219 C...Take copy of partons to be considered. Check flavour sum.
1220       NP=NP+1
1221       DO 120 J=1,5
1222       K(N+NP,J)=K(I,J)
1223       P(N+NP,J)=P(I,J)
1224   120 DPS(J)=DPS(J)+P(I,J)
1225       K(N+NP,3)=I
1226       IF(P(N+NP,4)**2.LT.P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2) THEN
1227         P(N+NP,4)=SQRT(P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2+
1228      &  P(N+NP,5)**2)
1229         DPS(4)=DPS(4)+MAX(0.,P(N+NP,4)-P(I,4))
1230       ENDIF
1231       IF(KQ.NE.2) KQSUM=KQSUM+KQ
1232       IF(K(I,1).EQ.41) THEN
1233         KQSUM=KQSUM+2*KQ
1234         IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1235         IF(KQSUM.NE.KQ) MJU(2)=N+NP
1236       ENDIF
1237       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1238       IF(KQSUM.NE.0) THEN
1239         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1240         IF(MSTU(21).GE.1) RETURN
1241       ENDIF
1242
1243 C...Boost copied system to CM frame (for better numerical precision).
1244       CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1245      &-DPS(3)/DPS(4))
1246
1247 C...Search for very nearby partons that may be recombined.
1248       NTRYR=0
1249       PARU12=PARU(12)
1250       PARU13=PARU(13)
1251       MJU(3)=MJU(1)
1252       MJU(4)=MJU(2)
1253       NR=NP
1254   130 IF(NR.GE.3) THEN
1255         PDRMIN=2.*PARU12
1256         DO 140 I=N+1,N+NR
1257         IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 140
1258         I1=I+1
1259         IF(I.EQ.N+NR) I1=N+1
1260         IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 140
1261         IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
1262      &  GOTO 140
1263         IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 140
1264         PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
1265      &  P(I1,2)**2+P(I1,3)**2))
1266         PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
1267         PDR=4.*(PAP-PVP)**2/(PARU13**2*PAP+2.*(PAP-PVP))
1268         IF(PDR.LT.PDRMIN) THEN
1269           IR=I
1270           PDRMIN=PDR
1271         ENDIF
1272   140   CONTINUE
1273
1274 C...Recombine very nearby partons to avoid machine precision problems.
1275         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1276           DO 150 J=1,4
1277   150     P(N+1,J)=P(N+1,J)+P(N+NR,J)
1278           P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1279      &    P(N+1,3)**2))
1280           NR=NR-1
1281           GOTO 130
1282         ELSEIF(PDRMIN.LT.PARU12) THEN
1283           DO 160 J=1,4
1284   160     P(IR,J)=P(IR,J)+P(IR+1,J)
1285           P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1286      &    P(IR,3)**2))
1287           DO 170 I=IR+1,N+NR-1
1288           K(I,2)=K(I+1,2)
1289           DO 170 J=1,5
1290   170     P(I,J)=P(I+1,J)
1291           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1292           NR=NR-1
1293           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1294           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1295           GOTO 130
1296         ENDIF
1297       ENDIF
1298       NTRYR=NTRYR+1
1299
1300 C...Reset particle counter. Skip ahead if no junctions are present;
1301 C...this is usually the case!
1302       NRS=MAX(5*NR+11,NP)
1303       NTRY=0
1304   180 NTRY=NTRY+1
1305       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1306         PARU12=4.*PARU12
1307         PARU13=2.*PARU13
1308         GOTO 130
1309       ELSEIF(NTRY.GT.100) THEN
1310         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1311         IF(MSTU(21).GE.1) RETURN
1312       ENDIF
1313       I=N+NRS
1314       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 500
1315       DO 490 JT=1,2
1316       NJS(JT)=0
1317       IF(MJU(JT).EQ.0) GOTO 490
1318       JS=3-2*JT
1319
1320 C...Find and sum up momentum on three sides of junction. Check flavours.
1321       DO 190 IU=1,3
1322       IJU(IU)=0
1323       DO 190 J=1,5
1324   190 PJU(IU,J)=0.
1325       IU=0
1326       DO 200 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
1327       IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1328         IU=IU+1
1329         IJU(IU)=I1
1330       ENDIF
1331       DO 200 J=1,4
1332   200 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1333       DO 210 IU=1,3
1334   210 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1335       IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1336      &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1337         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1338         IF(MSTU(21).GE.1) RETURN
1339       ENDIF
1340
1341 C...Calculate (approximate) boost to rest frame of junction.
1342       T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1343      &(PJU(1,5)*PJU(2,5))
1344       T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1345      &(PJU(1,5)*PJU(3,5))
1346       T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1347      &(PJU(2,5)*PJU(3,5))
1348       T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1349       T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1350       TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1351       T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1352       T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1353       DO 220 J=1,3
1354   220 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1355       TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1356       DO 230 IU=1,3
1357   230 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1358      &TJU(3)*PJU(IU,3)
1359
1360 C...Put junction at rest if motion could give inconsistencies.
1361       IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1362         DO 240 J=1,3
1363   240   TJU(J)=0.
1364         TJU(4)=1.
1365         PJU(1,5)=PJU(1,4)
1366         PJU(2,5)=PJU(2,4)
1367         PJU(3,5)=PJU(3,4)
1368       ENDIF
1369
1370 C...Start preparing for fragmentation of two strings from junction.
1371       ISTA=I
1372       DO 470 IU=1,2
1373       NS=IJU(IU+1)-IJU(IU)
1374
1375 C...Junction strings: find longitudinal string directions.
1376       DO 260 IS=1,NS
1377       IS1=IJU(IU)+IS-1
1378       IS2=IJU(IU)+IS
1379       DO 250 J=1,5
1380       DP(1,J)=0.5*P(IS1,J)
1381       IF(IS.EQ.1) DP(1,J)=P(IS1,J)
1382       DP(2,J)=0.5*P(IS2,J)
1383   250 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
1384       IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1385       IF(IS.EQ.NS) DP(2,5)=0.
1386       DP(3,5)=DFOUR(1,1)
1387       DP(4,5)=DFOUR(2,2)
1388       DHKC=DFOUR(1,2)
1389       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1390         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1391         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1392         DP(3,5)=0D0
1393         DP(4,5)=0D0
1394         DHKC=DFOUR(1,2)
1395       ENDIF
1396       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1397       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1398       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1399       IN1=N+NR+4*IS-3
1400       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1401       DO 260 J=1,4
1402       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1403   260 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1404
1405 C...Junction strings: initialize flavour, momentum and starting pos.
1406       ISAV=I
1407   270 NTRY=NTRY+1
1408       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1409         PARU12=4.*PARU12
1410         PARU13=2.*PARU13
1411         GOTO 130
1412       ELSEIF(NTRY.GT.100) THEN
1413         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1414         IF(MSTU(21).GE.1) RETURN
1415       ENDIF
1416       I=ISAV
1417       IRANKJ=0
1418       IE(1)=K(N+1+(JT/2)*(NP-1),3)
1419       IN(4)=N+NR+1
1420       IN(5)=IN(4)+1
1421       IN(6)=N+NR+4*NS+1
1422       DO 280 JQ=1,2
1423       DO 280 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1424       P(IN1,1)=2-JQ
1425       P(IN1,2)=JQ-1
1426   280 P(IN1,3)=1.
1427       KFL(1)=K(IJU(IU),2)
1428       PX(1)=0.
1429       PY(1)=0.
1430       GAM(1)=0.
1431       DO 290 J=1,5
1432   290 PJU(IU+3,J)=0.
1433
1434 C...Junction strings: find initial transverse directions.
1435       DO 300 J=1,4
1436       DP(1,J)=P(IN(4),J)
1437       DP(2,J)=P(IN(4)+1,J)
1438       DP(3,J)=0.
1439   300 DP(4,J)=0.
1440       DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1441       DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1442       DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1443       DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1444       DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1445       IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1446       IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1447       IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1448       IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1449       DHC12=DFOUR(1,2)
1450       DHCX1=DFOUR(3,1)/DHC12
1451       DHCX2=DFOUR(3,2)/DHC12
1452       DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1453       DHCY1=DFOUR(4,1)/DHC12
1454       DHCY2=DFOUR(4,2)/DHC12
1455       DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1456       DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1457       DO 310 J=1,4
1458       DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1459       P(IN(6),J)=DP(3,J)
1460   310 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1461      &DHCYX*DP(3,J))
1462
1463 C...Junction strings: produce new particle, origin.
1464   320 I=I+1
1465       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1466         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1467         IF(MSTU(21).GE.1) RETURN
1468       ENDIF
1469       IRANKJ=IRANKJ+1
1470       K(I,1)=1
1471       K(I,3)=IE(1)
1472       K(I,4)=0
1473       K(I,5)=0
1474
1475 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1476   330 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1477       IF(K(I,2).EQ.0) GOTO 270
1478       IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1479      &IABS(KFL(3)).GT.10) THEN
1480         IF(RLU(0).GT.PARJ(19)) GOTO 330
1481       ENDIF
1482       P(I,5)=ULMASS(K(I,2))
1483       CALL LUPTDI(KFL(1),PX(3),PY(3))
1484       PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1485       CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1486       GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1487       DO 340 J=1,3
1488   340 IN(J)=IN(3+J)
1489
1490 C...Junction strings: stepping within or from 'low' string region easy.
1491       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1492      &P(IN(1),5)**2.GE.PR(1)) THEN
1493         P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1494         P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1495         DO 350 J=1,4
1496   350   P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1497         GOTO 420
1498       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1499         P(IN(2)+2,4)=P(IN(2)+2,3)
1500         P(IN(2)+2,1)=1.
1501         IN(2)=IN(2)+4
1502         IF(IN(2).GT.N+NR+4*NS) GOTO 270
1503         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1504           P(IN(1)+2,4)=P(IN(1)+2,3)
1505           P(IN(1)+2,1)=0.
1506           IN(1)=IN(1)+4
1507         ENDIF
1508       ENDIF
1509
1510 C...Junction strings: find new transverse directions.
1511   360 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1512      &IN(1).GT.IN(2)) GOTO 270
1513       IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1514         DO 370 J=1,4
1515         DP(1,J)=P(IN(1),J)
1516         DP(2,J)=P(IN(2),J)
1517         DP(3,J)=0.
1518   370   DP(4,J)=0.
1519         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1520         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1521         DHC12=DFOUR(1,2)
1522         IF(DHC12.LE.1E-2) THEN
1523           P(IN(1)+2,4)=P(IN(1)+2,3)
1524           P(IN(1)+2,1)=0.
1525           IN(1)=IN(1)+4
1526           GOTO 360
1527         ENDIF
1528         IN(3)=N+NR+4*NS+5
1529         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1530         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1531         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1532         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1533         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1534         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1535         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1536         DHCX1=DFOUR(3,1)/DHC12
1537         DHCX2=DFOUR(3,2)/DHC12
1538         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1539         DHCY1=DFOUR(4,1)/DHC12
1540         DHCY2=DFOUR(4,2)/DHC12
1541         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1542         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1543         DO 380 J=1,4
1544         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1545         P(IN(3),J)=DP(3,J)
1546   380   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1547      &  DHCYX*DP(3,J))
1548 C...Express pT with respect to new axes, if sensible.
1549         PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1550         PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1551         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1552           PX(3)=PXP
1553           PY(3)=PYP
1554         ENDIF
1555       ENDIF
1556
1557 C...Junction strings: sum up known four-momentum, coefficients for m2.
1558       DO 400 J=1,4
1559       DHG(J)=0.
1560       P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1561      &PY(3)*P(IN(3)+1,J)
1562       DO 390 IN1=IN(4),IN(1)-4,4
1563   390 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1564       DO 400 IN2=IN(5),IN(2)-4,4
1565   400 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1566       DHM(1)=FOUR(I,I)
1567       DHM(2)=2.*FOUR(I,IN(1))
1568       DHM(3)=2.*FOUR(I,IN(2))
1569       DHM(4)=2.*FOUR(IN(1),IN(2))
1570
1571 C...Junction strings: find coefficients for Gamma expression.
1572       DO 410 IN2=IN(1)+1,IN(2),4
1573       DO 410 IN1=IN(1),IN2-1,4
1574       DHC=2.*FOUR(IN1,IN2)
1575       DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
1576       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
1577       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
1578   410 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1579
1580 C...Junction strings: solve (m2, Gamma) equation system for energies.
1581       DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1582       IF(ABS(DHS1).LT.1E-4) GOTO 270
1583       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1584      &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
1585       DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
1586       P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1587      &DHS2/DHS1)
1588       IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 270
1589       P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
1590      &(DHM(2)+DHM(4)*P(IN(2)+2,4))
1591
1592 C...Junction strings: step to new region if necessary.
1593       IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1594         P(IN(2)+2,4)=P(IN(2)+2,3)
1595         P(IN(2)+2,1)=1.
1596         IN(2)=IN(2)+4
1597         IF(IN(2).GT.N+NR+4*NS) GOTO 270
1598         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1599           P(IN(1)+2,4)=P(IN(1)+2,3)
1600           P(IN(1)+2,1)=0.
1601           IN(1)=IN(1)+4
1602         ENDIF
1603         GOTO 360
1604       ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1605         P(IN(1)+2,4)=P(IN(1)+2,3)
1606         P(IN(1)+2,1)=0.
1607         IN(1)=IN(1)+JS
1608         GOTO 710
1609       ENDIF
1610
1611 C...Junction strings: particle four-momentum, remainder, loop back.
1612   420 DO 430 J=1,4
1613       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1614   430 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1615       IF(P(I,4).LE.0.) GOTO 270
1616       PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1617      &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1618       IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1619         KFL(1)=-KFL(3)
1620         PX(1)=-PX(3)
1621         PY(1)=-PY(3)
1622         GAM(1)=GAM(3)
1623         IF(IN(3).NE.IN(6)) THEN
1624           DO 440 J=1,4
1625           P(IN(6),J)=P(IN(3),J)
1626   440     P(IN(6)+1,J)=P(IN(3)+1,J)
1627         ENDIF
1628         DO 450 JQ=1,2
1629         IN(3+JQ)=IN(JQ)
1630         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1631   450   P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1632         GOTO 320
1633       ENDIF
1634
1635 C...Junction strings: save quantities left after each string.
1636       IF(IABS(KFL(1)).GT.10) GOTO 270
1637       I=I-1
1638       KFJH(IU)=KFL(1)
1639       DO 460 J=1,4
1640   460 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1641   470 CONTINUE
1642
1643 C...Junction strings: put together to new effective string endpoint.
1644       NJS(JT)=I-ISTA
1645       KFJS(JT)=K(K(MJU(JT+2),3),2)
1646       KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1647       IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1648       IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1649      &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1650      &KFLS,KFJH(1))
1651       DO 480 J=1,4
1652       PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1653   480 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1654       PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1655      &PJS(JT,3)**2))
1656   490 CONTINUE
1657
1658 C...Open versus closed strings. Choose breakup region for latter.
1659   500 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1660         NS=MJU(2)-MJU(1)
1661         NB=MJU(1)-N
1662       ELSEIF(MJU(1).NE.0) THEN
1663         NS=N+NR-MJU(1)
1664         NB=MJU(1)-N
1665       ELSEIF(MJU(2).NE.0) THEN
1666         NS=MJU(2)-N
1667         NB=1
1668       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1669         NS=NR-1
1670         NB=1
1671       ELSE
1672         NS=NR+1
1673         W2SUM=0.
1674         DO 510 IS=1,NR
1675         P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1676   510   W2SUM=W2SUM+P(N+NR+IS,1)
1677         W2RAN=RLU(0)*W2SUM
1678         NB=0
1679   520   NB=NB+1
1680         W2SUM=W2SUM-P(N+NR+NB,1)
1681         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 520
1682       ENDIF
1683
1684 C...Find longitudinal string directions (i.e. lightlike four-vectors).
1685       DO 540 IS=1,NS
1686       IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1687       IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1688       DO 530 J=1,5
1689       DP(1,J)=P(IS1,J)
1690       IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)
1691       IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
1692       DP(2,J)=P(IS2,J)
1693       IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)
1694   530 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
1695       DP(3,5)=DFOUR(1,1)
1696       DP(4,5)=DFOUR(2,2)
1697       DHKC=DFOUR(1,2)
1698       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1699         DP(3,5)=DP(1,5)**2
1700         DP(4,5)=DP(2,5)**2
1701         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1702         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1703         DHKC=DFOUR(1,2)
1704       ENDIF
1705       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1706       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1707       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1708       IN1=N+NR+4*IS-3
1709       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1710       DO 540 J=1,4
1711       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1712   540 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1713
1714 C...Begin initialization: sum up energy, set starting position.
1715       ISAV=I
1716   550 NTRY=NTRY+1
1717       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1718         PARU12=4.*PARU12
1719         PARU13=2.*PARU13
1720         GOTO 130
1721       ELSEIF(NTRY.GT.100) THEN
1722         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1723         IF(MSTU(21).GE.1) RETURN
1724       ENDIF
1725       I=ISAV
1726       DO 560 J=1,4
1727       P(N+NRS,J)=0.
1728       DO 560 IS=1,NR
1729   560 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1730       DO 570 JT=1,2
1731       IRANK(JT)=0
1732       IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1733       IF(NS.GT.NR) IRANK(JT)=1
1734       IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1735       IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1736       IN(3*JT+2)=IN(3*JT+1)+1
1737       IN(3*JT+3)=N+NR+4*NS+2*JT-1
1738       DO 570 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1739       P(IN1,1)=2-JT
1740       P(IN1,2)=JT-1
1741   570 P(IN1,3)=1.
1742
1743 C...Initialize flavour and pT variables for open string.
1744       IF(NS.LT.NR) THEN
1745         PX(1)=0.
1746         PY(1)=0.
1747         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1748         PX(2)=-PX(1)
1749         PY(2)=-PY(1)
1750         DO 580 JT=1,2
1751         KFL(JT)=K(IE(JT),2)
1752         IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1753         MSTJ(93)=1
1754         PMQ(JT)=ULMASS(KFL(JT))
1755   580   GAM(JT)=0.
1756
1757 C...Closed string: random initial breakup flavour, pT and vertex.
1758       ELSE
1759         KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1760         CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
1761         KFL(2)=-KFL(1)
1762         IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
1763           KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
1764         ELSEIF(IABS(KFL(1)).GT.10) THEN
1765           KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
1766         ENDIF
1767         CALL LUPTDI(KFL(1),PX(1),PY(1))
1768         PX(2)=-PX(1)
1769         PY(2)=-PY(1)
1770         PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
1771   590   CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
1772         ZR=PR3/(Z*P(N+NR+1,5)**2)
1773         IF(ZR.GE.1.) GOTO 590
1774         DO 600 JT=1,2
1775         MSTJ(93)=1
1776         PMQ(JT)=ULMASS(KFL(JT))
1777         GAM(JT)=PR3*(1.-Z)/Z
1778         IN1=N+NR+3+4*(JT/2)*(NS-1)
1779         P(IN1,JT)=1.-Z
1780         P(IN1,3-JT)=JT-1
1781         P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
1782         P(IN1+1,JT)=ZR
1783         P(IN1+1,3-JT)=2-JT
1784   600   P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
1785       ENDIF
1786
1787 C...Find initial transverse directions (i.e. spacelike four-vectors).
1788       DO 640 JT=1,2
1789       IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
1790         IN1=IN(3*JT+1)
1791         IN3=IN(3*JT+3)
1792         DO 610 J=1,4
1793         DP(1,J)=P(IN1,J)
1794         DP(2,J)=P(IN1+1,J)
1795         DP(3,J)=0.
1796   610   DP(4,J)=0.
1797         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1798         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1799         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1800         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1801         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1802         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1803         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1804         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1805         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1806         DHC12=DFOUR(1,2)
1807         DHCX1=DFOUR(3,1)/DHC12
1808         DHCX2=DFOUR(3,2)/DHC12
1809         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1810         DHCY1=DFOUR(4,1)/DHC12
1811         DHCY2=DFOUR(4,2)/DHC12
1812         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1813         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1814         DO 620 J=1,4
1815         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1816         P(IN3,J)=DP(3,J)
1817   620   P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1818      &  DHCYX*DP(3,J))
1819       ELSE
1820         DO 630 J=1,4
1821         P(IN3+2,J)=P(IN3,J)
1822   630   P(IN3+3,J)=P(IN3+1,J)
1823       ENDIF
1824   640 CONTINUE
1825
1826 C...Remove energy used up in junction string fragmentation.
1827       IF(MJU(1)+MJU(2).GT.0) THEN
1828         DO 660 JT=1,2
1829         IF(NJS(JT).EQ.0) GOTO 660
1830         DO 650 J=1,4
1831   650   P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
1832   660   CONTINUE
1833       ENDIF
1834
1835 C...Produce new particle: side, origin.
1836   670 I=I+1
1837       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1838         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1839         IF(MSTU(21).GE.1) RETURN
1840       ENDIF
1841       JT=1.5+RLU(0)
1842       IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
1843       JR=3-JT
1844       JS=3-2*JT
1845       IRANK(JT)=IRANK(JT)+1
1846       K(I,1)=1
1847       K(I,3)=IE(JT)
1848       K(I,4)=0
1849       K(I,5)=0
1850
1851 C...Generate flavour, hadron and pT.
1852   680 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
1853       IF(K(I,2).EQ.0) GOTO 550
1854       IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
1855      &IABS(KFL(3)).GT.10) THEN
1856         IF(RLU(0).GT.PARJ(19)) GOTO 680
1857       ENDIF
1858       P(I,5)=ULMASS(K(I,2))
1859       CALL LUPTDI(KFL(JT),PX(3),PY(3))
1860       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
1861
1862 C...Final hadrons for small invariant mass.
1863       MSTJ(93)=1
1864       PMQ(3)=ULMASS(KFL(3))
1865       WMIN=PARJ(32+MSTJ(11))+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
1866       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
1867      &WMIN-0.5*PARJ(36)*PMQ(3)
1868       WREM2=FOUR(N+NRS,N+NRS)
1869       IF(WREM2.LT.0.10) GOTO 550
1870       IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
1871      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 810
1872
1873 C...Choose z, which gives Gamma. Shift z for heavy flavours.
1874       CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
1875       KFL1A=IABS(KFL(1))
1876       KFL2A=IABS(KFL(2))
1877       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1878      &MOD(KFL2A/1000,10)).GE.4) THEN
1879         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1880         PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
1881         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
1882         PR(JR)=(PMQ(JR)+PARJ(32+MSTJ(11)))**2+(PX(JR)-PX(3))**2+
1883      &  (PY(JR)-PY(3))**2
1884         IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 810
1885       ENDIF
1886       GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
1887       DO 690 J=1,3
1888   690 IN(J)=IN(3*JT+J)
1889
1890 C...Stepping within or from 'low' string region easy.
1891       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1892      &P(IN(1),5)**2.GE.PR(JT)) THEN
1893         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
1894         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
1895         DO 700 J=1,4
1896   700   P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
1897         GOTO 770
1898       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1899         P(IN(JR)+2,4)=P(IN(JR)+2,3)
1900         P(IN(JR)+2,JT)=1.
1901         IN(JR)=IN(JR)+4*JS
1902         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1903         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1904           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1905           P(IN(JT)+2,JT)=0.
1906           IN(JT)=IN(JT)+4*JS
1907         ENDIF
1908       ENDIF
1909
1910 C...Find new transverse directions (i.e. spacelike string vectors).
1911   710 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
1912      &IN(1).GT.IN(2)) GOTO 550
1913       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
1914         DO 720 J=1,4
1915         DP(1,J)=P(IN(1),J)
1916         DP(2,J)=P(IN(2),J)
1917         DP(3,J)=0.
1918   720   DP(4,J)=0.
1919         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1920         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1921         DHC12=DFOUR(1,2)
1922         IF(DHC12.LE.1E-2) THEN
1923           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1924           P(IN(JT)+2,JT)=0.
1925           IN(JT)=IN(JT)+4*JS
1926           GOTO 710
1927         ENDIF
1928         IN(3)=N+NR+4*NS+5
1929         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1930         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1931         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1932         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1933         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1934         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1935         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1936         DHCX1=DFOUR(3,1)/DHC12
1937         DHCX2=DFOUR(3,2)/DHC12
1938         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1939         DHCY1=DFOUR(4,1)/DHC12
1940         DHCY2=DFOUR(4,2)/DHC12
1941         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1942         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1943         DO 730 J=1,4
1944         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1945         P(IN(3),J)=DP(3,J)
1946   730   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1947      &  DHCYX*DP(3,J))
1948 C...Express pT with respect to new axes, if sensible.
1949         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
1950      &  FOUR(IN(3*JT+3)+1,IN(3)))
1951         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
1952      &  FOUR(IN(3*JT+3)+1,IN(3)+1))
1953         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1954           PX(3)=PXP
1955           PY(3)=PYP
1956         ENDIF
1957       ENDIF
1958
1959 C...Sum up known four-momentum. Gives coefficients for m2 expression.
1960       DO 750 J=1,4
1961       DHG(J)=0.
1962       P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
1963      &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
1964       DO 740 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
1965   740 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1966       DO 750 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
1967   750 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1968       DHM(1)=FOUR(I,I)
1969       DHM(2)=2.*FOUR(I,IN(1))
1970       DHM(3)=2.*FOUR(I,IN(2))
1971       DHM(4)=2.*FOUR(IN(1),IN(2))
1972
1973 C...Find coefficients for Gamma expression.
1974       DO 760 IN2=IN(1)+1,IN(2),4
1975       DO 760 IN1=IN(1),IN2-1,4
1976       DHC=2.*FOUR(IN1,IN2)
1977       DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
1978       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
1979       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
1980   760 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1981
1982 C...Solve (m2, Gamma) equation system for energies taken.
1983       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
1984       IF(ABS(DHS1).LT.1E-4) GOTO 550
1985       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
1986      &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
1987       DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
1988       P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1989      &DHS2/DHS1)
1990       IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 550
1991       P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
1992      &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
1993
1994 C...Step to new region if necessary.
1995       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
1996         P(IN(JR)+2,4)=P(IN(JR)+2,3)
1997         P(IN(JR)+2,JT)=1.
1998         IN(JR)=IN(JR)+4*JS
1999         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
2000         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2001           P(IN(JT)+2,4)=P(IN(JT)+2,3)
2002           P(IN(JT)+2,JT)=0.
2003           IN(JT)=IN(JT)+4*JS
2004         ENDIF
2005         GOTO 710
2006       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
2007         P(IN(JT)+2,4)=P(IN(JT)+2,3)
2008         P(IN(JT)+2,JT)=0.
2009         IN(JT)=IN(JT)+4*JS
2010         GOTO 710
2011       ENDIF
2012
2013 C...Four-momentum of particle. Remaining quantities. Loop back.
2014   770 DO 780 J=1,4
2015       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
2016   780 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
2017       IF(P(I,4).LE.0.) GOTO 550
2018       KFL(JT)=-KFL(3)
2019       PMQ(JT)=PMQ(3)
2020       PX(JT)=-PX(3)
2021       PY(JT)=-PY(3)
2022       GAM(JT)=GAM(3)
2023       IF(IN(3).NE.IN(3*JT+3)) THEN
2024         DO 790 J=1,4
2025         P(IN(3*JT+3),J)=P(IN(3),J)
2026   790   P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2027       ENDIF
2028       DO 800 JQ=1,2
2029       IN(3*JT+JQ)=IN(JQ)
2030       P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
2031   800 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
2032       GOTO 670
2033
2034 C...Final hadron: side, flavour, hadron, mass.
2035   810 I=I+1
2036       K(I,1)=1
2037       K(I,3)=IE(JR)
2038       K(I,4)=0
2039       K(I,5)=0
2040       CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
2041       IF(K(I,2).EQ.0) GOTO 550
2042       P(I,5)=ULMASS(K(I,2))
2043       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2044
2045 C...Final two hadrons: find common setup of four-vectors.
2046       JQ=1
2047       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
2048      &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
2049       DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
2050       DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
2051       DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
2052       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
2053         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
2054         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
2055         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
2056      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
2057       ENDIF
2058
2059 C...Solve kinematics for final two hadrons, if possible.
2060       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
2061       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
2062       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 180
2063       IF(FD.GE.1.) GOTO 550
2064       FA=WREM2+PR(JT)-PR(JR)
2065       IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(37+MSTJ(11))
2066       IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-100.,LOG(FD)*
2067      &PARJ(37+MSTJ(11))*(PR(1)+PR(2))**2))
2068       FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
2069       KFL1A=IABS(KFL(1))
2070       KFL2A=IABS(KFL(2))
2071       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2072      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
2073      &4.*WREM2*PR(JT))),FLOAT(JS))
2074       DO 820 J=1,4
2075       P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
2076      &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
2077      &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
2078   820 P(I,J)=P(N+NRS,J)-P(I-1,J)
2079
2080 C...Mark jets as fragmented and give daughter pointers.
2081       N=I-NRS+1
2082       DO 830 I=NSAV+1,NSAV+NP
2083       IM=K(I,3)
2084       K(IM,1)=K(IM,1)+10
2085       IF(MSTU(16).NE.2) THEN
2086         K(IM,4)=NSAV+1
2087         K(IM,5)=NSAV+1
2088       ELSE
2089         K(IM,4)=NSAV+2
2090         K(IM,5)=N
2091       ENDIF
2092   830 CONTINUE
2093
2094 C...Document string system. Move up particles.
2095       NSAV=NSAV+1
2096       K(NSAV,1)=11
2097       K(NSAV,2)=92
2098       K(NSAV,3)=IP
2099       K(NSAV,4)=NSAV+1
2100       K(NSAV,5)=N
2101       DO 840 J=1,4
2102       P(NSAV,J)=DPS(J)
2103   840 V(NSAV,J)=V(IP,J)
2104       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2105       V(NSAV,5)=0.
2106       DO 850 I=NSAV+1,N
2107       DO 850 J=1,5
2108       K(I,J)=K(I+NRS-1,J)
2109       P(I,J)=P(I+NRS-1,J)
2110   850 V(I,J)=0.
2111
2112 C...Order particles in rank along the chain. Update mother pointer.
2113       DO 860 I=NSAV+1,N
2114       DO 860 J=1,5
2115       K(I-NSAV+N,J)=K(I,J)
2116   860 P(I-NSAV+N,J)=P(I,J)
2117       I1=NSAV
2118       DO 880 I=N+1,2*N-NSAV
2119       IF(K(I,3).NE.IE(1)) GOTO 880
2120       I1=I1+1
2121       DO 870 J=1,5
2122       K(I1,J)=K(I,J)
2123   870 P(I1,J)=P(I,J)
2124       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2125   880 CONTINUE
2126       DO 900 I=2*N-NSAV,N+1,-1
2127       IF(K(I,3).EQ.IE(1)) GOTO 900
2128       I1=I1+1
2129       DO 890 J=1,5
2130       K(I1,J)=K(I,J)
2131   890 P(I1,J)=P(I,J)
2132       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2133   900 CONTINUE
2134
2135 C...Boost back particle system. Set production vertices.
2136       CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2137      &DPS(3)/DPS(4))
2138       DO 910 I=NSAV+1,N
2139       DO 910 J=1,4
2140   910 V(I,J)=V(IP,J)
2141
2142       RETURN
2143       END
2144
2145 C*********************************************************************
2146
2147       SUBROUTINE LUINDF(IP)
2148
2149 C...Purpose: to handle the fragmentation of a jet system (or a single
2150 C...jet) according to independent fragmentation models.
2151       IMPLICIT DOUBLE PRECISION(D)
2152       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2153       SAVE /LUJETS/
2154       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2155       SAVE /LUDAT1/
2156       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2157       SAVE /LUDAT2/
2158       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
2159      &KFLO(2),PXO(2),PYO(2),WO(2)
2160
2161 C...Reset counters. Identify parton system and take copy. Check flavour.
2162       NSAV=N
2163       NJET=0
2164       KQSUM=0
2165       DO 100 J=1,5
2166   100 DPS(J)=0.
2167       I=IP-1
2168   110 I=I+1
2169       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
2170         CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
2171         IF(MSTU(21).GE.1) RETURN
2172       ENDIF
2173       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2174       KC=LUCOMP(K(I,2))
2175       IF(KC.EQ.0) GOTO 110
2176       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2177       IF(KQ.EQ.0) GOTO 110
2178       NJET=NJET+1
2179       IF(KQ.NE.2) KQSUM=KQSUM+KQ
2180       DO 120 J=1,5
2181       K(NSAV+NJET,J)=K(I,J)
2182       P(NSAV+NJET,J)=P(I,J)
2183   120 DPS(J)=DPS(J)+P(I,J)
2184       K(NSAV+NJET,3)=I
2185       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
2186      &K(I+1,1).EQ.2)) GOTO 110
2187       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
2188         CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
2189         IF(MSTU(21).GE.1) RETURN
2190       ENDIF
2191
2192 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2193       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2194      &-DPS(2)/DPS(4),-DPS(3)/DPS(4))
2195       PECM=0.
2196       DO 130 J=1,3
2197   130 NFI(J)=0
2198       DO 140 I=NSAV+1,NSAV+NJET
2199       PECM=PECM+P(I,4)
2200       KFA=IABS(K(I,2))
2201       IF(KFA.LE.3) THEN
2202         NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
2203       ELSEIF(KFA.GT.1000) THEN
2204         KFLA=MOD(KFA/1000,10)
2205         KFLB=MOD(KFA/100,10)
2206         IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
2207         IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
2208       ENDIF
2209   140 CONTINUE
2210
2211 C...Loop over attempts made. Reset counters.
2212       NTRY=0
2213   150 NTRY=NTRY+1
2214       N=NSAV+NJET
2215       IF(NTRY.GT.200) THEN
2216         CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
2217         IF(MSTU(21).GE.1) RETURN
2218       ENDIF
2219       DO 160 J=1,3
2220       NFL(J)=NFI(J)
2221       IFET(J)=0
2222   160 KFLF(J)=0
2223
2224 C...Loop over jets to be fragmented.
2225       DO 230 IP1=NSAV+1,NSAV+NJET
2226       MSTJ(91)=0
2227       NSAV1=N
2228
2229 C...Initial flavour and momentum values. Jet along +z axis.
2230       KFLH=IABS(K(IP1,2))
2231       IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2232       KFLO(2)=0
2233       WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2234
2235 C...Initial values for quark or diquark jet.
2236   170 IF(IABS(K(IP1,2)).NE.21) THEN
2237         NSTR=1
2238         KFLO(1)=K(IP1,2)
2239         CALL LUPTDI(0,PXO(1),PYO(1))
2240         WO(1)=WF
2241
2242 C...Initial values for gluon treated like random quark jet.
2243       ELSEIF(MSTJ(2).LE.2) THEN
2244         NSTR=1
2245         IF(MSTJ(2).EQ.2) MSTJ(91)=1
2246         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2247         CALL LUPTDI(0,PXO(1),PYO(1))
2248         WO(1)=WF
2249
2250 C...Initial values for gluon treated like quark-antiquark jet pair,
2251 C...sharing energy according to Altarelli-Parisi splitting function.
2252       ELSE
2253         NSTR=2
2254         IF(MSTJ(2).EQ.4) MSTJ(91)=1
2255         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2256         KFLO(2)=-KFLO(1)
2257         CALL LUPTDI(0,PXO(1),PYO(1))
2258         PXO(2)=-PXO(1)
2259         PYO(2)=-PYO(1)
2260         WO(1)=WF*RLU(0)**(1./3.)
2261         WO(2)=WF-WO(1)
2262       ENDIF
2263
2264 C...Initial values for rank, flavour, pT and W+.
2265       DO 220 ISTR=1,NSTR
2266   180 I=N
2267       IRANK=0
2268       KFL1=KFLO(ISTR)
2269       PX1=PXO(ISTR)
2270       PY1=PYO(ISTR)
2271       W=WO(ISTR)
2272
2273 C...New hadron. Generate flavour and hadron species.
2274   190 I=I+1
2275       IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
2276         CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')
2277         IF(MSTU(21).GE.1) RETURN
2278       ENDIF
2279       IRANK=IRANK+1
2280       K(I,1)=1
2281       K(I,3)=IP1
2282       K(I,4)=0
2283       K(I,5)=0
2284   200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
2285       IF(K(I,2).EQ.0) GOTO 180
2286       IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
2287      &IABS(KFL2).GT.10) THEN
2288         IF(RLU(0).GT.PARJ(19)) GOTO 200
2289       ENDIF
2290
2291 C...Find hadron mass. Generate four-momentum.
2292       P(I,5)=ULMASS(K(I,2))
2293       CALL LUPTDI(KFL1,PX2,PY2)
2294       P(I,1)=PX1+PX2
2295       P(I,2)=PY1+PY2
2296       PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2297       CALL LUZDIS(KFL1,KFL2,PR,Z)
2298       P(I,3)=0.5*(Z*W-PR/(Z*W))
2299       P(I,4)=0.5*(Z*W+PR/(Z*W))
2300       IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
2301      &P(I,3).LE.0.001) THEN
2302         IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
2303         P(I,3)=0.0001
2304         P(I,4)=SQRT(PR)
2305         Z=P(I,4)/W
2306       ENDIF
2307
2308 C...Remaining flavour and momentum.
2309       KFL1=-KFL2
2310       PX1=-PX2
2311       PY1=-PY2
2312       W=(1.-Z)*W
2313       DO 210 J=1,5
2314   210 V(I,J)=0.
2315
2316 C...Check if pL acceptable. Go back for new hadron if enough energy.
2317       IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) I=I-1
2318       IF(W.GT.PARJ(31)) GOTO 190
2319   220 N=I
2320       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2321       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2322
2323 C...Rotate jet to new direction.
2324       THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2325       PHI=ULANGL(P(IP1,1),P(IP1,2))
2326       CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2327       K(K(IP1,3),4)=NSAV1+1
2328       K(K(IP1,3),5)=N
2329
2330 C...End of jet generation loop. Skip conservation in some cases.
2331   230 CONTINUE
2332       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2333       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2334
2335 C...Subtract off produced hadron flavours, finished if zero.
2336       DO 240 I=NSAV+NJET+1,N
2337       KFA=IABS(K(I,2))
2338       KFLA=MOD(KFA/1000,10)
2339       KFLB=MOD(KFA/100,10)
2340       KFLC=MOD(KFA/10,10)
2341       IF(KFLA.EQ.0) THEN
2342         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2343         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2344       ELSE
2345         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2346         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2347         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2348       ENDIF
2349   240 CONTINUE
2350       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2351      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2352       IF(NREQ.EQ.0) GOTO 320
2353
2354 C...Take away flavour of low-momentum particles until enough freedom.
2355       NREM=0
2356   250 IREM=0
2357       P2MIN=PECM**2
2358       DO 260 I=NSAV+NJET+1,N
2359       P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2360       IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2361   260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2362       IF(IREM.EQ.0) GOTO 150
2363       K(IREM,1)=7
2364       KFA=IABS(K(IREM,2))
2365       KFLA=MOD(KFA/1000,10)
2366       KFLB=MOD(KFA/100,10)
2367       KFLC=MOD(KFA/10,10)
2368       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2369       IF(K(IREM,1).EQ.8) GOTO 250
2370       IF(KFLA.EQ.0) THEN
2371         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2372         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2373         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2374       ELSE
2375         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2376         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2377         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2378       ENDIF
2379       NREM=NREM+1
2380       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2381      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2382       IF(NREQ.GT.NREM) GOTO 250
2383       DO 270 I=NSAV+NJET+1,N
2384   270 IF(K(I,1).EQ.8) K(I,1)=1
2385
2386 C...Find combination of existing and new flavours for hadron.
2387   280 NFET=2
2388       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2389       IF(NREQ.LT.NREM) NFET=1
2390       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2391       DO 290 J=1,NFET
2392       IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0)
2393       KFLF(J)=ISIGN(1,NFL(1))
2394       IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2395   290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2396       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2397      &GOTO 280
2398       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2399      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2400      &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2401       IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2402       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2403       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2404       IF(NFET.LE.2) KFLF(3)=0
2405       IF(KFLF(3).NE.0) THEN
2406         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2407      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2408         IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2409      &  KFLFC=KFLFC+ISIGN(2,KFLFC)
2410       ELSE
2411         KFLFC=KFLF(1)
2412       ENDIF
2413       CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2414       IF(KF.EQ.0) GOTO 280
2415       DO 300 J=1,MAX(2,NFET)
2416   300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2417
2418 C...Store hadron at random among free positions.
2419       NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2420       DO 310 I=NSAV+NJET+1,N
2421       IF(K(I,1).EQ.7) NPOS=NPOS-1
2422       IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2423       K(I,1)=1
2424       K(I,2)=KF
2425       P(I,5)=ULMASS(K(I,2))
2426       P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2427   310 CONTINUE
2428       NREM=NREM-1
2429       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2430      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2431       IF(NREM.GT.0) GOTO 280
2432
2433 C...Compensate for missing momentum in global scheme (3 options).
2434   320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2435         DO 330 J=1,3
2436         PSI(J)=0.
2437         DO 330 I=NSAV+NJET+1,N
2438   330   PSI(J)=PSI(J)+P(I,J)
2439         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2440         PWS=0.
2441         DO 340 I=NSAV+NJET+1,N
2442         IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2443         IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2444      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2445   340   IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2446         DO 360 I=NSAV+NJET+1,N
2447         IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2448         IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2449      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2450         IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2451         DO 350 J=1,3
2452   350   P(I,J)=P(I,J)-PSI(J)*PW/PWS
2453   360   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2454
2455 C...Compensate for missing momentum withing each jet separately.
2456       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2457         DO 370 I=N+1,N+NJET
2458         K(I,1)=0
2459         DO 370 J=1,5
2460   370   P(I,J)=0.
2461         DO 390 I=NSAV+NJET+1,N
2462         IR1=K(I,3)
2463         IR2=N+IR1-NSAV
2464         K(IR2,1)=K(IR2,1)+1
2465         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2466      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2467         DO 380 J=1,3
2468   380   P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2469         P(IR2,4)=P(IR2,4)+P(I,4)
2470   390   P(IR2,5)=P(IR2,5)+PLS
2471         PSS=0.
2472         DO 400 I=N+1,N+NJET
2473   400   IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2474         DO 420 I=NSAV+NJET+1,N
2475         IR1=K(I,3)
2476         IR2=N+IR1-NSAV
2477         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2478      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2479         DO 410 J=1,3
2480   410   P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2481      &  P(IR1,J)
2482   420   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2483       ENDIF
2484
2485 C...Scale momenta for energy conservation.
2486       IF(MOD(MSTJ(3),5).NE.0) THEN
2487         PMS=0.
2488         PES=0.
2489         PQS=0.
2490         DO 430 I=NSAV+NJET+1,N
2491         PMS=PMS+P(I,5)
2492         PES=PES+P(I,4)
2493   430   PQS=PQS+P(I,5)**2/P(I,4)
2494         IF(PMS.GE.PECM) GOTO 150
2495         NECO=0
2496   440   NECO=NECO+1
2497         PFAC=(PECM-PQS)/(PES-PQS)
2498         PES=0.
2499         PQS=0.
2500         DO 460 I=NSAV+NJET+1,N
2501         DO 450 J=1,3
2502   450   P(I,J)=PFAC*P(I,J)
2503         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2504         PES=PES+P(I,4)
2505   460   PQS=PQS+P(I,5)**2/P(I,4)
2506         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2507       ENDIF
2508
2509 C...Origin of produced particles and parton daughter pointers.
2510   470 DO 480 I=NSAV+NJET+1,N
2511       IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2512   480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2513       DO 490 I=NSAV+1,NSAV+NJET
2514       I1=K(I,3)
2515       K(I1,1)=K(I1,1)+10
2516       IF(MSTU(16).NE.2) THEN
2517         K(I1,4)=NSAV+1
2518         K(I1,5)=NSAV+1
2519       ELSE
2520         K(I1,4)=K(I1,4)-NJET+1
2521         K(I1,5)=K(I1,5)-NJET+1
2522         IF(K(I1,5).LT.K(I1,4)) THEN
2523           K(I1,4)=0
2524           K(I1,5)=0
2525         ENDIF
2526       ENDIF
2527   490 CONTINUE
2528
2529 C...Document independent fragmentation system. Remove copy of jets.
2530       NSAV=NSAV+1
2531       K(NSAV,1)=11
2532       K(NSAV,2)=93
2533       K(NSAV,3)=IP
2534       K(NSAV,4)=NSAV+1
2535       K(NSAV,5)=N-NJET+1
2536       DO 500 J=1,4
2537       P(NSAV,J)=DPS(J)
2538   500 V(NSAV,J)=V(IP,J)
2539       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2540       V(NSAV,5)=0.
2541       DO 510 I=NSAV+NJET,N
2542       DO 510 J=1,5
2543       K(I-NJET+1,J)=K(I,J)
2544       P(I-NJET+1,J)=P(I,J)
2545   510 V(I-NJET+1,J)=V(I,J)
2546       N=N-NJET+1
2547
2548 C...Boost back particle system. Set production vertices.
2549       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2550      &DPS(2)/DPS(4),DPS(3)/DPS(4))
2551       DO 520 I=NSAV+1,N
2552       DO 520 J=1,4
2553   520 V(I,J)=V(IP,J)
2554
2555       RETURN
2556       END
2557
2558 C*********************************************************************
2559
2560       SUBROUTINE LUDECY(IP)
2561
2562 C...Purpose: to handle the decay of unstable particles.
2563       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2564       SAVE /LUJETS/
2565       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2566       SAVE /LUDAT1/
2567       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2568       SAVE /LUDAT2/
2569       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2570       SAVE /LUDAT3/
2571       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2572      &WTCOR(10)
2573       DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2574
2575 C...Functions: momentum in two-particle decays, four-product and
2576 C...matrix element times phase space in weak decays.
2577       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2578       FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
2579       HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2580      &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2581
2582 C...Initial values.
2583       NTRY=0
2584       NSAV=N
2585       KFA=IABS(K(IP,2))
2586       KFS=ISIGN(1,K(IP,2))
2587       KC=LUCOMP(KFA)
2588       MSTJ(92)=0
2589
2590 C...Choose lifetime and determine decay vertex.
2591       IF(K(IP,1).EQ.5) THEN
2592         V(IP,5)=0.
2593       ELSEIF(K(IP,1).NE.4) THEN
2594         V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2595       ENDIF
2596       DO 100 J=1,4
2597   100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2598
2599 C...Determine whether decay allowed or not.
2600       MOUT=0
2601       IF(MSTJ(22).EQ.2) THEN
2602         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2603       ELSEIF(MSTJ(22).EQ.3) THEN
2604         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2605       ELSEIF(MSTJ(22).EQ.4) THEN
2606         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2607         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2608       ENDIF
2609       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2610         K(IP,1)=4
2611         RETURN
2612       ENDIF
2613
2614 C...Check existence of decay channels. Particle/antiparticle rules.
2615       KCA=KC
2616       IF(MDCY(KC,2).GT.0) THEN
2617         MDMDCY=MDME(MDCY(KC,2),2)
2618         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2619       ENDIF
2620       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2621         CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2622         RETURN
2623       ENDIF
2624       IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2625       IF(KCHG(KC,3).EQ.0) THEN
2626         KFSP=1
2627         KFSN=0
2628         IF(RLU(0).GT.0.5) KFS=-KFS
2629       ELSEIF(KFS.GT.0) THEN
2630         KFSP=1
2631         KFSN=0
2632       ELSE
2633         KFSP=0
2634         KFSN=1
2635       ENDIF
2636
2637 C...Sum branching ratios of allowed decay channels.
2638   110 NOPE=0
2639       BRSU=0.
2640       DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2641       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2642      &KFSN*MDME(IDL,1).NE.3) GOTO 120
2643       IF(MDME(IDL,2).GT.100) GOTO 120
2644       NOPE=NOPE+1
2645       BRSU=BRSU+BRAT(IDL)
2646   120 CONTINUE
2647       IF(NOPE.EQ.0) THEN
2648         CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2649         RETURN
2650       ENDIF
2651
2652 C...Select decay channel among allowed ones.
2653   130 RBR=BRSU*RLU(0)
2654       IDL=MDCY(KCA,2)-1
2655   140 IDL=IDL+1
2656       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2657      &KFSN*MDME(IDL,1).NE.3) THEN
2658         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2659       ELSEIF(MDME(IDL,2).GT.100) THEN
2660         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2661       ELSE
2662         IDC=IDL
2663         RBR=RBR-BRAT(IDL)
2664         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2665       ENDIF
2666
2667 C...Start readout of decay channel: matrix element, reset counters.
2668       MMAT=MDME(IDC,2)
2669   150 NTRY=NTRY+1
2670       IF(NTRY.GT.1000) THEN
2671         CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2672         IF(MSTU(21).GE.1) RETURN
2673       ENDIF
2674       I=N
2675       NP=0
2676       NQ=0
2677       MBST=0
2678       IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2679       DO 160 J=1,4
2680       PV(1,J)=0.
2681   160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2682       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2683       PV(1,5)=P(IP,5)
2684       PS=0.
2685       PSQ=0.
2686       MREM=0
2687
2688 C...Read out decay products. Convert to standard flavour code.
2689       JTMAX=5
2690       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2691       DO 170 JT=1,JTMAX
2692       IF(JT.LE.5) KP=KFDP(IDC,JT)
2693       IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
2694       IF(KP.EQ.0) GOTO 170
2695       KPA=IABS(KP)
2696       KCP=LUCOMP(KPA)
2697       IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
2698         KFP=KP
2699       ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
2700         KFP=KFS*KP
2701       ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
2702         KFP=-KFS*MOD(KFA/10,10)
2703       ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
2704         KFP=KFS*(100*MOD(KFA/10,100)+3)
2705       ELSEIF(KPA.EQ.81) THEN
2706         KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
2707       ELSEIF(KP.EQ.82) THEN
2708         CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
2709         IF(KFP.EQ.0) GOTO 150
2710         MSTJ(93)=1
2711         IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
2712       ELSEIF(KP.EQ.-82) THEN
2713         KFP=-KFP
2714         IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
2715       ENDIF
2716       IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
2717
2718 C...Add decay product to event record or to quark flavour list.
2719       KFPA=IABS(KFP)
2720       KQP=KCHG(KCP,2)
2721       IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
2722         NQ=NQ+1
2723         KFLO(NQ)=KFP
2724         MSTJ(93)=2
2725         PSQ=PSQ+ULMASS(KFLO(NQ))
2726       ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
2727      &THEN
2728         NQ=NQ-1
2729         PS=PS-P(I,5)
2730         K(I,1)=1
2731         KFI=K(I,2)
2732         CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
2733         IF(K(I,2).EQ.0) GOTO 150
2734         MSTJ(93)=1
2735         P(I,5)=ULMASS(K(I,2))
2736         PS=PS+P(I,5)
2737       ELSE
2738         I=I+1
2739         NP=NP+1
2740         IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
2741         IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
2742         K(I,1)=1+MOD(NQ,2)
2743         IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
2744         IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
2745         K(I,2)=KFP
2746         K(I,3)=IP
2747         K(I,4)=0
2748         K(I,5)=0
2749         P(I,5)=ULMASS(KFP)
2750         IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
2751         PS=PS+P(I,5)
2752       ENDIF
2753   170 CONTINUE
2754
2755 C...Choose decay multiplicity in phase space model.
2756   180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
2757         PSP=PS
2758         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
2759         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
2760   190   NTRY=NTRY+1
2761         IF(NTRY.GT.1000) THEN
2762           CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2763           IF(MSTU(21).GE.1) RETURN
2764         ENDIF
2765         IF(MMAT.LE.20) THEN
2766           GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
2767      &    SIN(PARU(2)*RLU(0))
2768           ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS
2769           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
2770           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
2771           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
2772           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
2773         ELSE
2774           ND=MMAT-20
2775         ENDIF
2776
2777 C...Form hadrons from flavour content.
2778         DO 200 JT=1,4
2779   200   KFL1(JT)=KFLO(JT)
2780         IF(ND.EQ.NP+NQ/2) GOTO 220
2781         DO 210 I=N+NP+1,N+ND-NQ/2
2782         JT=1+INT((NQ-1)*RLU(0))
2783         CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
2784         IF(K(I,2).EQ.0) GOTO 190
2785   210   KFL1(JT)=-KFL2
2786   220   JT=2
2787         JT2=3
2788         JT3=4
2789         IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
2790         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
2791      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
2792         IF(JT.EQ.3) JT2=2
2793         IF(JT.EQ.4) JT3=2
2794         CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
2795         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
2796         IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
2797         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
2798
2799 C...Check that sum of decay product masses not too large.
2800         PS=PSP
2801         DO 230 I=N+NP+1,N+ND
2802         K(I,1)=1
2803         K(I,3)=IP
2804         K(I,4)=0
2805         K(I,5)=0
2806         P(I,5)=ULMASS(K(I,2))
2807   230   PS=PS+P(I,5)
2808         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
2809
2810 C...Rescale energy to subtract off spectator quark mass.
2811       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
2812      &AND.NP.GE.3) THEN
2813         PS=PS-P(N+NP,5)
2814         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
2815         DO 240 J=1,5
2816         P(N+NP,J)=PQT*PV(1,J)
2817   240   PV(1,J)=(1.-PQT)*PV(1,J)
2818         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
2819         ND=NP-1
2820         MREM=1
2821
2822 C...Phase space factors imposed in W decay.
2823       ELSEIF(MMAT.EQ.46) THEN
2824         MSTJ(93)=1
2825         PSMC=ULMASS(K(N+1,2))
2826         MSTJ(93)=1
2827         PSMC=PSMC+ULMASS(K(N+2,2))
2828         IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
2829         HR1=(P(N+1,5)/PV(1,5))**2
2830         HR2=(P(N+2,5)/PV(1,5))**2
2831         IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
2832      &  LT.2.*RLU(0)) GOTO 130
2833         ND=NP
2834
2835 C...Fully specified final state: check mass broadening effects.
2836       ELSE
2837         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
2838         ND=NP
2839       ENDIF
2840
2841 C...Select W mass in decay Q -> W + q, without W propagator.
2842       IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
2843         HLQ=(PARJ(32)/PV(1,5))**2
2844         HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
2845         HRQ=(P(N+2,5)/PV(1,5))**2
2846   250   HW=HLQ+RLU(0)*(HUQ-HLQ)
2847         IF(HMEPS(HW).LT.RLU(0)) GOTO 250
2848         P(N+1,5)=PV(1,5)*SQRT(HW)
2849
2850 C...Ditto, including W propagator. Divide mass range into three regions.
2851       ELSEIF(MMAT.EQ.45) THEN
2852         HQW=(PV(1,5)/PMAS(24,1))**2
2853         HLW=(PARJ(32)/PMAS(24,1))**2
2854         HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
2855         HRQ=(P(N+2,5)/PV(1,5))**2
2856         HG=PMAS(24,2)/PMAS(24,1)
2857         HATL=ATAN((HLW-1.)/HG)
2858         HM=MIN(1.,HUW-0.001)
2859         HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2860   260   HM=HM-HG
2861         HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2862         HSAV1=HMEPS(HM/HQW)
2863         HSAV2=1./((HM-1.)**2+HG**2)
2864         IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
2865           HMV1=HMV2
2866           GOTO 260
2867         ENDIF
2868         HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
2869         HM1=1.-SQRT(1./HMV-HG**2)
2870         IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
2871           HM=HM1
2872         ELSEIF(HMV2.LE.HMV1) THEN
2873           HM=MAX(HLW,HM-MIN(0.1,1.-HM))
2874         ENDIF
2875         HATM=ATAN((HM-1.)/HG)
2876         HWT1=(HATM-HATL)/HG
2877         HWT2=HMV*(MIN(1.,HUW)-HM)
2878         HWT3=0.
2879         IF(HUW.GT.1.) THEN
2880           HATU=ATAN((HUW-1.)/HG)
2881           HMP1=HMEPS(1./HQW)
2882           HWT3=HMP1*HATU/HG
2883         ENDIF
2884
2885 C...Select mass region and W mass there. Accept according to weight.
2886   270   HREG=RLU(0)*(HWT1+HWT2+HWT3)
2887         IF(HREG.LE.HWT1) THEN
2888           HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
2889           HACC=HMEPS(HW/HQW)
2890         ELSEIF(HREG.LE.HWT1+HWT2) THEN
2891           HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
2892           HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
2893         ELSE
2894           HW=1.+HG*TAN(RLU(0)*HATU)
2895           HACC=HMEPS(HW/HQW)/HMP1
2896         ENDIF
2897         IF(HACC.LT.RLU(0)) GOTO 270
2898         P(N+1,5)=PMAS(24,1)*SQRT(HW)
2899       ENDIF
2900
2901 C...Determine position of grandmother, number of sisters, Q -> W sign.
2902       NM=0
2903       MSGN=0
2904       IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
2905         IM=K(IP,3)
2906         IF(IM.LT.0.OR.IM.GE.IP) IM=0
2907         IF(IM.NE.0) KFAM=IABS(K(IM,2))
2908         IF(IM.NE.0.AND.MMAT.EQ.3) THEN
2909           DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
2910   280     IF(K(IL,3).EQ.IM) NM=NM+1
2911           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
2912      &    MOD(KFAM/1000,10).NE.0) NM=0
2913         ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
2914           MSGN=ISIGN(1,K(IM,2)*K(IP,2))
2915           IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
2916      &    MSGN*(-1)**MOD(KFAM/100,10)
2917         ENDIF
2918       ENDIF
2919
2920 C...Kinematics of one-particle decays.
2921       IF(ND.EQ.1) THEN
2922         DO 290 J=1,4
2923   290   P(N+1,J)=P(IP,J)
2924         GOTO 510
2925       ENDIF
2926
2927 C...Calculate maximum weight ND-particle decay.
2928       PV(ND,5)=P(N+ND,5)
2929       IF(ND.GE.3) THEN
2930         WTMAX=1./WTCOR(ND-2)
2931         PMAX=PV(1,5)-PS+P(N+ND,5)
2932         PMIN=0.
2933         DO 300 IL=ND-1,1,-1
2934         PMAX=PMAX+P(N+IL,5)
2935         PMIN=PMIN+P(N+IL+1,5)
2936   300   WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
2937       ENDIF
2938
2939 C...Find virtual gamma mass in Dalitz decay.
2940   310 IF(ND.EQ.2) THEN
2941       ELSEIF(MMAT.EQ.2) THEN
2942         PMES=4.*PMAS(11,1)**2
2943         PMRHO2=PMAS(131,1)**2
2944         PGRHO2=PMAS(131,2)**2
2945   320   PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
2946         WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
2947      &  (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
2948      &  ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
2949         IF(WT.LT.RLU(0)) GOTO 320
2950         PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
2951
2952 C...M-generator gives weight. If rejected, try again.
2953       ELSE
2954   330   RORD(1)=1.
2955         DO 350 IL1=2,ND-1
2956         RSAV=RLU(0)
2957         DO 340 IL2=IL1-1,1,-1
2958         IF(RSAV.LE.RORD(IL2)) GOTO 350
2959   340   RORD(IL2+1)=RORD(IL2)
2960   350   RORD(IL2+1)=RSAV
2961         RORD(ND)=0.
2962         WT=1.
2963         DO 360 IL=ND-1,1,-1
2964         PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
2965   360   WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2966         IF(WT.LT.RLU(0)*WTMAX) GOTO 330
2967       ENDIF
2968
2969 C...Perform two-particle decays in respective CM frame.
2970   370 DO 390 IL=1,ND-1
2971       PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2972       UE(3)=2.*RLU(0)-1.
2973       PHI=PARU(2)*RLU(0)
2974       UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
2975       UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
2976       DO 380 J=1,3
2977       P(N+IL,J)=PA*UE(J)
2978   380 PV(IL+1,J)=-PA*UE(J)
2979       P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
2980   390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
2981
2982 C...Lorentz transform decay products to lab frame.
2983       DO 400 J=1,4
2984   400 P(N+ND,J)=PV(ND,J)
2985       DO 430 IL=ND-1,1,-1
2986       DO 410 J=1,3
2987   410 BE(J)=PV(IL,J)/PV(IL,4)
2988       GA=PV(IL,4)/PV(IL,5)
2989       DO 430 I=N+IL,N+ND
2990       BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2991       DO 420 J=1,3
2992   420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2993   430 P(I,4)=GA*(P(I,4)+BEP)
2994
2995 C...Matrix elements for omega and phi decays.
2996       IF(MMAT.EQ.1) THEN
2997         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
2998      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
2999      &  +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
3000         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
3001
3002 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3003       ELSEIF(MMAT.EQ.2) THEN
3004         FOUR12=FOUR(N+1,N+2)
3005         FOUR13=FOUR(N+1,N+3)
3006         FOUR23=0.5*PMST-0.25*PMES
3007         WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
3008      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
3009         IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
3010
3011 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3012 C...V vector), of form cos**2(theta02) in V1 rest frame.
3013       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
3014         IF((P(IP,5)**2*FOUR(IM,N+1)-FOUR(IP,IM)*FOUR(IP,N+1))**2.LE.
3015      &  RLU(0)*(FOUR(IP,IM)**2-(P(IP,5)*P(IM,5))**2)*(FOUR(IP,N+1)**2-
3016      &  (P(IP,5)*P(N+1,5))**2)) GOTO 370
3017
3018 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3019       ELSEIF(MMAT.EQ.4) THEN
3020         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3021         HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
3022         HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
3023         WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
3024      &  ((1.-HX3)/(HX1*HX2))**2
3025         IF(WT.LT.2.*RLU(0)) GOTO 310
3026         IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
3027      &  GOTO 310
3028
3029 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3030       ELSEIF(MMAT.EQ.41) THEN
3031         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3032         IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
3033
3034 C...Matrix elements for weak decays (only semileptonic for c and b)
3035       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
3036         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
3037         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
3038         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3039       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
3040         DO 440 J=1,4
3041         P(N+NP+1,J)=0.
3042         DO 440 IS=N+3,N+NP
3043   440   P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3044         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
3045         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
3046         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3047
3048 C...Angular distribution in W decay.
3049       ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
3050         IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
3051         IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
3052         IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
3053       ENDIF
3054
3055 C...Scale back energy and reattach spectator.
3056       IF(MREM.EQ.1) THEN
3057         DO 450 J=1,5
3058   450   PV(1,J)=PV(1,J)/(1.-PQT)
3059         ND=ND+1
3060         MREM=0
3061       ENDIF
3062
3063 C...Low invariant mass for system with spectator quark gives particle,
3064 C...not two jets. Readjust momenta accordingly.
3065       IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
3066         MSTJ(93)=1
3067         PM2=ULMASS(K(N+2,2))
3068         MSTJ(93)=1
3069         PM3=ULMASS(K(N+3,2))
3070         IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
3071      &  (PARJ(32)+PM2+PM3)**2) GOTO 510
3072         K(N+2,1)=1
3073         KFTEMP=K(N+2,2)
3074         CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
3075         IF(K(N+2,2).EQ.0) GOTO 150
3076         P(N+2,5)=ULMASS(K(N+2,2))
3077         PS=P(N+1,5)+P(N+2,5)
3078         PV(2,5)=P(N+2,5)
3079         MMAT=0
3080         ND=2
3081         GOTO 370
3082       ELSEIF(MMAT.EQ.44) THEN
3083         MSTJ(93)=1
3084         PM3=ULMASS(K(N+3,2))
3085         MSTJ(93)=1
3086         PM4=ULMASS(K(N+4,2))
3087         IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
3088      &  (PARJ(32)+PM3+PM4)**2) GOTO 480
3089         K(N+3,1)=1
3090         KFTEMP=K(N+3,2)
3091         CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
3092         IF(K(N+3,2).EQ.0) GOTO 150
3093         P(N+3,5)=ULMASS(K(N+3,2))
3094         DO 460 J=1,3
3095   460   P(N+3,J)=P(N+3,J)+P(N+4,J)
3096         P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)
3097         HA=P(N+1,4)**2-P(N+2,4)**2
3098         HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
3099         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
3100      &  (P(N+1,3)-P(N+2,3))**2
3101         HD=(PV(1,4)-P(N+3,4))**2
3102         HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
3103         HF=HD*HC-HB**2
3104         HG=HD*HC-HA*HB
3105         HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3106         DO 470 J=1,3
3107         PCOR=HH*(P(N+1,J)-P(N+2,J))
3108         P(N+1,J)=P(N+1,J)+PCOR
3109   470   P(N+2,J)=P(N+2,J)-PCOR
3110         P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)
3111         P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)
3112         ND=ND-1
3113       ENDIF
3114
3115 C...Check invariant mass of W jets. May give one particle or start over.
3116   480 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
3117         PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
3118         MSTJ(93)=1
3119         PM1=ULMASS(K(N+1,2))
3120         MSTJ(93)=1
3121         PM2=ULMASS(K(N+2,2))
3122         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 490
3123         KFLDUM=INT(1.5+RLU(0))
3124         CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
3125         CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
3126         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
3127         PSM=ULMASS(KF1)+ULMASS(KF2)
3128         IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 490
3129         IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 490
3130         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
3131         K(N+1,1)=1
3132         KFTEMP=K(N+1,2)
3133         CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
3134         IF(K(N+1,2).EQ.0) GOTO 150
3135         P(N+1,5)=ULMASS(K(N+1,2))
3136         K(N+2,2)=K(N+3,2)
3137         P(N+2,5)=P(N+3,5)
3138         PS=P(N+1,5)+P(N+2,5)
3139         PV(2,5)=P(N+3,5)
3140         MMAT=0
3141         ND=2
3142         GOTO 370
3143       ENDIF
3144
3145 C...Phase space decay of partons from W decay.
3146   490 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
3147         KFLO(1)=K(N+1,2)
3148         KFLO(2)=K(N+2,2)
3149         K(N+1,1)=K(N+3,1)
3150         K(N+1,2)=K(N+3,2)
3151         DO 500 J=1,5
3152         PV(1,J)=P(N+1,J)+P(N+2,J)
3153   500   P(N+1,J)=P(N+3,J)
3154         PV(1,5)=PMR
3155         N=N+1
3156         NP=0
3157         NQ=2
3158         PS=0.
3159         MSTJ(93)=2
3160         PSQ=ULMASS(KFLO(1))
3161         MSTJ(93)=2
3162         PSQ=PSQ+ULMASS(KFLO(2))
3163         MMAT=11
3164         GOTO 180
3165       ENDIF
3166
3167 C...Boost back for rapidly moving particle.
3168   510 N=N+ND
3169       IF(MBST.EQ.1) THEN
3170         DO 520 J=1,3
3171   520   BE(J)=P(IP,J)/P(IP,4)
3172         GA=P(IP,4)/P(IP,5)
3173         DO 540 I=NSAV+1,N
3174         BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3175         DO 530 J=1,3
3176   530   P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3177   540   P(I,4)=GA*(P(I,4)+BEP)
3178       ENDIF
3179
3180 C...Fill in position of decay vertex.
3181       DO 560 I=NSAV+1,N
3182       DO 550 J=1,4
3183   550 V(I,J)=VDCY(J)
3184   560 V(I,5)=0.
3185
3186 C...Set up for parton shower evolution from jets.
3187       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
3188         K(NSAV+1,1)=3
3189         K(NSAV+2,1)=3
3190         K(NSAV+3,1)=3
3191         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3192         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3193         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3194         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3195         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3196         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3197         MSTJ(92)=-(NSAV+1)
3198       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3199         K(NSAV+2,1)=3
3200         K(NSAV+3,1)=3
3201         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3202         K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3203         K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3204         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3205         MSTJ(92)=NSAV+2
3206       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3207      &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
3208         K(NSAV+1,1)=3
3209         K(NSAV+2,1)=3
3210         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3211         K(NSAV+1,5)=MSTU(5)*(NSAV+2)
3212         K(NSAV+2,4)=MSTU(5)*(NSAV+1)
3213         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3214         MSTJ(92)=NSAV+1
3215       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3216      &THEN
3217         K(NSAV+1,1)=3
3218         K(NSAV+2,1)=3
3219         K(NSAV+3,1)=3
3220         KCP=LUCOMP(K(NSAV+1,2))
3221         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3222         JCON=4
3223         IF(KQP.LT.0) JCON=5
3224         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
3225         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
3226         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
3227         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
3228         MSTJ(92)=NSAV+1
3229       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3230         K(NSAV+1,1)=3
3231         K(NSAV+3,1)=3
3232         K(NSAV+1,4)=MSTU(5)*(NSAV+3)
3233         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3234         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3235         K(NSAV+3,5)=MSTU(5)*(NSAV+1)
3236         MSTJ(92)=NSAV+1
3237       ENDIF
3238
3239 C...Mark decayed particle.
3240       IF(K(IP,1).EQ.5) K(IP,1)=15
3241       IF(K(IP,1).LE.10) K(IP,1)=11
3242       K(IP,4)=NSAV+1
3243       K(IP,5)=N
3244
3245       RETURN
3246       END
3247
3248 C*********************************************************************
3249
3250       SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
3251
3252 C...Purpose: to generate a new flavour pair and combine off a hadron.
3253       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3254       SAVE /LUDAT1/
3255       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3256       SAVE /LUDAT2/
3257
3258 C...Default flavour values. Input consistency checks.
3259       KF1A=IABS(KFL1)
3260       KF2A=IABS(KFL2)
3261       KFL3=0
3262       KF=0
3263       IF(KF1A.EQ.0) RETURN
3264       IF(KF2A.NE.0) THEN
3265         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
3266         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
3267         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
3268       ENDIF
3269
3270 C...Check if tabulated flavour probabilities are to be used.
3271       IF(MSTJ(15).EQ.1) THEN
3272         KTAB1=-1
3273         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3274         KFL1A=MOD(KF1A/1000,10)
3275         KFL1B=MOD(KF1A/100,10)
3276         KFL1S=MOD(KF1A,10)
3277         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
3278      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
3279         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
3280         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
3281         KTAB2=0
3282         IF(KF2A.NE.0) THEN
3283           KTAB2=-1
3284           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3285           KFL2A=MOD(KF2A/1000,10)
3286           KFL2B=MOD(KF2A/100,10)
3287           KFL2S=MOD(KF2A,10)
3288           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
3289      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
3290           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
3291         ENDIF
3292         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3293       ENDIF
3294
3295 C...Parameters and breaking diquark parameter combinations.
3296   100 PAR2=PARJ(2)
3297       PAR3=PARJ(3)
3298       PAR4=3.*PARJ(4)
3299       IF(MSTJ(12).GE.2) THEN
3300         PAR3M=SQRT(PARJ(3))
3301         PAR4M=1./(3.*SQRT(PARJ(4)))
3302         PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3303         PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3304         PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3305      &  PAR2*PAR3M*PARJ(6)*PARJ(7))
3306         PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3307         PARSM=MAX(PARS0,PARS1,PARS2)
3308         PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3309       ENDIF
3310
3311 C...Choice of whether to generate meson or baryon.
3312       MBARY=0
3313       KFDA=0
3314       IF(KF1A.LE.10) THEN
3315         IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3316      &  MBARY=1
3317         IF(KF2A.GT.10) MBARY=2
3318         IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3319       ELSE
3320         MBARY=2
3321         IF(KF1A.LE.10000) KFDA=KF1A
3322       ENDIF
3323
3324 C...Possibility of process diquark -> meson + new diquark.
3325       IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3326         KFLDA=MOD(KFDA/1000,10)
3327         KFLDB=MOD(KFDA/100,10)
3328         KFLDS=MOD(KFDA,10)
3329         WTDQ=PARS0
3330         IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3331         IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3332         IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3333         IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3334         IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3335       ENDIF
3336
3337 C...Flavour for meson, possibly with new flavour.
3338       IF(MBARY.LE.0) THEN
3339         KFS=ISIGN(1,KFL1)
3340         IF(MBARY.EQ.0) THEN
3341           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3342           KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3343           KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3344           IF(KFLA.NE.KF1A) KFS=-KFS
3345
3346 C...Splitting of diquark into meson plus new diquark.
3347         ELSE
3348           KFL1A=MOD(KF1A/1000,10)
3349           KFL1B=MOD(KF1A/100,10)
3350   110     KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3351           KFL1E=KFL1A+KFL1B-KFL1D
3352           IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3353      &    RLU(0).LT.PARDM)) THEN
3354             KFL1D=KFL1A+KFL1B-KFL1D
3355             KFL1E=KFL1A+KFL1B-KFL1E
3356           ENDIF
3357           KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3358           IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3359      &    OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3360      &    GOTO 110
3361           KFLDS=3
3362           IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3363           KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3364      &    KFLDS,-KFL1)
3365           KFLA=MAX(KFL1D,KFL3A)
3366           KFLB=MIN(KFL1D,KFL3A)
3367           IF(KFLA.NE.KFL1D) KFS=-KFS
3368         ENDIF
3369
3370 C...Form meson, with spin and flavour mixing for diagonal states.
3371         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3372         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3373         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3374         IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3375           IF(RLU(0).LT.PARJ(14)) KMUL=2
3376         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3377           RMUL=RLU(0)
3378           IF(RMUL.LT.PARJ(15)) KMUL=3
3379           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3380           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3381         ENDIF
3382         KFLS=3
3383         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3384         IF(KMUL.EQ.5) KFLS=5
3385         IF(KFLA.NE.KFLB) THEN
3386           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3387         ELSE
3388           RMIX=RLU(0)
3389           IMIX=2*KFLA+10*KMUL
3390           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3391      &    INT(RMIX+PARF(IMIX)))+KFLS
3392           IF(KFLA.GE.4) KF=110*KFLA+KFLS
3393         ENDIF
3394         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3395         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3396
3397 C...Generate diquark flavour.
3398       ELSE
3399   120   IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3400           KFLA=KF1A
3401   130     KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3402           KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3403           KFLDS=1
3404           IF(KFLB.GE.KFLC) KFLDS=3
3405           IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3406           IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3407           KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3408
3409 C...Take diquark flavour from input.
3410         ELSEIF(KF1A.LE.10) THEN
3411           KFLA=KF1A
3412           KFLB=MOD(KF2A/1000,10)
3413           KFLC=MOD(KF2A/100,10)
3414           KFLDS=MOD(KF2A,10)
3415
3416 C...Generate (or take from input) quark to go with diquark.
3417         ELSE
3418           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3419           KFLA=KF2A+IABS(KFL3)
3420           KFLB=MOD(KF1A/1000,10)
3421           KFLC=MOD(KF1A/100,10)
3422           KFLDS=MOD(KF1A,10)
3423         ENDIF
3424
3425 C...SU(6) factors for formation of baryon. Try again if fails.
3426         KBARY=KFLDS
3427         IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3428         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3429         WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3430         IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3431           WTDQ=PARS0
3432           IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3433           IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3434           IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3435           IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3436           IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3437         ENDIF
3438         IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3439
3440 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3441         KFLD=MAX(KFLA,KFLB,KFLC)
3442         KFLF=MIN(KFLA,KFLB,KFLC)
3443         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3444         KFLS=2
3445         IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3446      &  PARF(60+KBARY)) KFLS=4
3447         KFLL=0
3448         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3449           IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3450           IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3451           IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3452         ENDIF
3453         IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3454         IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3455       ENDIF
3456       RETURN
3457
3458 C...Use tabulated probabilities to select new flavour and hadron.
3459   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3460         KT3L=1
3461         KT3U=6
3462       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3463         KT3L=1
3464         KT3U=6
3465       ELSEIF(KTAB2.EQ.0) THEN
3466         KT3L=1
3467         KT3U=22
3468       ELSE
3469         KT3L=KTAB2
3470         KT3U=KTAB2
3471       ENDIF
3472       RFL=0.
3473       DO 150 KTS=0,2
3474       DO 150 KT3=KT3L,KT3U
3475       RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3476   150 CONTINUE
3477       RFL=RLU(0)*RFL
3478       DO 160 KTS=0,2
3479       KTABS=KTS
3480       DO 160 KT3=KT3L,KT3U
3481       KTAB3=KT3
3482       RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3483   160 IF(RFL.LE.0.) GOTO 170
3484   170 CONTINUE
3485
3486 C...Reconstruct flavour of produced quark/diquark.
3487       IF(KTAB3.LE.6) THEN
3488         KFL3A=KTAB3
3489         KFL3B=0
3490         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3491       ELSE
3492         KFL3A=1
3493         IF(KTAB3.GE.8) KFL3A=2
3494         IF(KTAB3.GE.11) KFL3A=3
3495         IF(KTAB3.GE.16) KFL3A=4
3496         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3497         KFL3=1000*KFL3A+100*KFL3B+1
3498         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3499      &  KFL3+2
3500         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3501       ENDIF
3502
3503 C...Reconstruct meson code.
3504       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3505      &KFL3B.NE.0)) THEN
3506         RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3507      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3508         KF=110+2*KTABS+1
3509         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3510         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3511      &  25*KTABS)) KF=330+2*KTABS+1
3512       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3513         KFLA=MAX(KTAB1,KTAB3)
3514         KFLB=MIN(KTAB1,KTAB3)
3515         KFS=ISIGN(1,KFL1)
3516         IF(KFLA.NE.KF1A) KFS=-KFS
3517         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3518       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3519         KFS=ISIGN(1,KFL1)
3520         IF(KFL1A.EQ.KFL3A) THEN
3521           KFLA=MAX(KFL1B,KFL3B)
3522           KFLB=MIN(KFL1B,KFL3B)
3523           IF(KFLA.NE.KFL1B) KFS=-KFS
3524         ELSEIF(KFL1A.EQ.KFL3B) THEN
3525           KFLA=KFL3A
3526           KFLB=KFL1B
3527           KFS=-KFS
3528         ELSEIF(KFL1B.EQ.KFL3A) THEN
3529           KFLA=KFL1A
3530           KFLB=KFL3B
3531         ELSEIF(KFL1B.EQ.KFL3B) THEN
3532           KFLA=MAX(KFL1A,KFL3A)
3533           KFLB=MIN(KFL1A,KFL3A)
3534           IF(KFLA.NE.KFL1A) KFS=-KFS
3535         ELSE
3536           CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3537           GOTO 100
3538         ENDIF
3539         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3540
3541 C...Reconstruct baryon code.
3542       ELSE
3543         IF(KTAB1.GE.7) THEN
3544           KFLA=KFL3A
3545           KFLB=KFL1A
3546           KFLC=KFL1B
3547         ELSE
3548           KFLA=KFL1A
3549           KFLB=KFL3A
3550           KFLC=KFL3B
3551         ENDIF
3552         KFLD=MAX(KFLA,KFLB,KFLC)
3553         KFLF=MIN(KFLA,KFLB,KFLC)
3554         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3555         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3556         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3557       ENDIF
3558
3559 C...Check that constructed flavour code is an allowed one.
3560       IF(KFL2.NE.0) KFL3=0
3561       KC=LUCOMP(KF)
3562       IF(KC.EQ.0) THEN
3563         CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3564      &  'failed')
3565         GOTO 100
3566       ENDIF
3567
3568       RETURN
3569       END
3570
3571 C*********************************************************************
3572
3573       SUBROUTINE LUPTDI(KFL,PX,PY)
3574
3575 C...Purpose: to generate transverse momentum according to a Gaussian.
3576       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3577       SAVE /LUDAT1/
3578
3579 C...Generate p_T and azimuthal angle, gives p_x and p_y.
3580       KFLA=IABS(KFL)
3581       PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3582       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3583       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3584       PHI=PARU(2)*RLU(0)
3585       PX=PT*COS(PHI)
3586       PY=PT*SIN(PHI)
3587
3588       RETURN
3589       END
3590
3591 C*********************************************************************
3592
3593       SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3594
3595 C...Purpose: to generate the longitudinal splitting variable z.
3596       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3597       SAVE /LUDAT1/
3598
3599 C...Check if heavy flavour fragmentation.
3600       KFLA=IABS(KFL1)
3601       KFLB=IABS(KFL2)
3602       KFLH=KFLA
3603       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3604
3605 C...Lund symmetric scaling function: determine parameters of shape.
3606       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3)) THEN
3607         FA=PARJ(41)
3608         IF(MSTJ(91).EQ.1) FA=PARJ(43)
3609         IF(KFLB.GE.10) FA=FA+PARJ(45)
3610         FB=PARJ(42)*PR
3611         IF(MSTJ(91).EQ.1) FB=PARJ(44)*PR
3612         FC=1.
3613         IF(KFLA.GE.10) FC=FC-PARJ(45)
3614         IF(KFLB.GE.10) FC=FC+PARJ(45)
3615         MC=1
3616         IF(ABS(FC-1.).GT.0.01) MC=2
3617
3618 C...Determine position of maximum. Special cases for a = 0 or a = c.
3619         IF(FA.LT.0.02) THEN
3620           MA=1
3621           ZMAX=1.
3622           IF(FC.GT.FB) ZMAX=FB/FC
3623         ELSEIF(ABS(FC-FA).LT.0.01) THEN
3624           MA=2
3625           ZMAX=FB/(FB+FC)
3626         ELSE
3627           MA=3
3628           ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3629           IF(ZMAX.GT.0.99.AND.FB.GT.100.) ZMAX=1.-FA/FB
3630         ENDIF
3631
3632 C...Subdivide z range if distribution very peaked near endpoint.
3633         MMAX=2
3634         IF(ZMAX.LT.0.1) THEN
3635           MMAX=1
3636           ZDIV=2.75*ZMAX
3637           IF(MC.EQ.1) THEN
3638             FINT=1.-LOG(ZDIV)
3639           ELSE
3640             ZDIVC=ZDIV**(1.-FC)
3641             FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3642           ENDIF
3643         ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3644           MMAX=3
3645           FSCB=SQRT(4.+(FC/FB)**2)
3646           ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3647           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3648           ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3649           FINT=1.+FB*(1.-ZDIV)
3650         ENDIF
3651
3652 C...Choice of z, preweighted for peaks at low or high z.
3653   100   Z=RLU(0)
3654         FPRE=1.
3655         IF(MMAX.EQ.1) THEN
3656           IF(FINT*RLU(0).LE.1.) THEN
3657             Z=ZDIV*Z
3658           ELSEIF(MC.EQ.1) THEN
3659             Z=ZDIV**Z
3660             FPRE=ZDIV/Z
3661           ELSE
3662             Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
3663             FPRE=(ZDIV/Z)**FC
3664           ENDIF
3665         ELSEIF(MMAX.EQ.3) THEN
3666           IF(FINT*RLU(0).LE.1.) THEN
3667             Z=ZDIV+LOG(Z)/FB
3668             FPRE=EXP(FB*(Z-ZDIV))
3669           ELSE
3670             Z=ZDIV+Z*(1.-ZDIV)
3671           ENDIF
3672         ENDIF
3673
3674 C...Weighting according to correct formula.
3675         IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100
3676         FVAL=(ZMAX/Z)**FC*EXP(FB*(1./ZMAX-1./Z))
3677         IF(MA.GE.2) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL
3678         IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
3679
3680 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
3681       ELSE
3682         FC=PARJ(50+MAX(1,KFLH))
3683         IF(MSTJ(91).EQ.1) FC=PARJ(59)
3684   110   Z=RLU(0)
3685         IF(FC.GE.0..AND.FC.LE.1.) THEN
3686           IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
3687         ELSEIF(FC.GT.-1.) THEN
3688           IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
3689         ELSE
3690           IF(FC.GT.0.) Z=1.-Z**(1./FC)
3691           IF(FC.LT.0.) Z=Z**(-1./FC)
3692         ENDIF
3693       ENDIF
3694
3695       RETURN
3696       END
3697
3698 C*********************************************************************
3699
3700       SUBROUTINE LUSHOW(IP1,IP2,QMAX)
3701
3702 C...Purpose: to generate timelike parton showers from given partons.
3703       IMPLICIT DOUBLE PRECISION(D)
3704       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3705       SAVE /LUJETS/
3706       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3707       SAVE /LUDAT1/
3708       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3709       SAVE /LUDAT2/
3710       DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
3711      &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4)
3712
3713 C...Initialization of cutoff masses etc.
3714       IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
3715      &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
3716       PMTH(1,21)=ULMASS(21)
3717       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
3718       PMTH(3,21)=2.*PMTH(2,21)
3719       PMTH(4,21)=PMTH(3,21)
3720       PMTH(5,21)=PMTH(3,21)
3721       PMTH(1,22)=ULMASS(22)
3722       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
3723       PMTH(3,22)=2.*PMTH(2,22)
3724       PMTH(4,22)=PMTH(3,22)
3725       PMTH(5,22)=PMTH(3,22)
3726       PMQTH1=PARJ(82)
3727       IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
3728       PMQTH2=PMTH(2,21)
3729       IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
3730       DO 100 IF=1,8
3731       PMTH(1,IF)=ULMASS(IF)
3732       PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
3733       PMTH(3,IF)=PMTH(2,IF)+PMQTH2
3734       PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
3735   100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
3736       PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
3737       ALAMS=PARJ(81)**2
3738       ALFM=LOG(PT2MIN/ALAMS)
3739
3740 C...Store positions of shower initiating partons.
3741       M3JC=0
3742       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
3743         NPA=1
3744         IPA(1)=IP1
3745       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
3746      &MSTU(32))) THEN
3747         NPA=2
3748         IPA(1)=IP1
3749         IPA(2)=IP2
3750       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
3751      &AND.IP2.GE.-3) THEN
3752         NPA=IABS(IP2)
3753         DO 110 I=1,NPA
3754   110   IPA(I)=IP1+I-1
3755       ELSE
3756         CALL LUERRM(12,
3757      &  '(LUSHOW:) failed to reconstruct showering system')
3758         IF(MSTU(21).GE.1) RETURN
3759       ENDIF
3760
3761 C...Check on phase space available for emission.
3762       IREJ=0
3763       DO 120 J=1,5
3764   120 PS(J)=0.
3765       PM=0.
3766       DO 130 I=1,NPA
3767       KFLA(I)=IABS(K(IPA(I),2))
3768       PMA(I)=P(IPA(I),5)
3769       IF(KFLA(I).NE.0.AND.(KFLA(I).LE.8.OR.KFLA(I).EQ.21))
3770      &PMA(I)=PMTH(3,KFLA(I))
3771       PM=PM+PMA(I)
3772       IF(KFLA(I).EQ.0.OR.(KFLA(I).GT.8.AND.KFLA(I).NE.21).OR.
3773      &PMA(I).GT.QMAX) IREJ=IREJ+1
3774       DO 130 J=1,4
3775   130 PS(J)=PS(J)+P(IPA(I),J)
3776       IF(IREJ.EQ.NPA) RETURN
3777       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
3778       IF(NPA.EQ.1) PS(5)=PS(4)
3779       IF(PS(5).LE.PM+PMQTH1) RETURN
3780       IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
3781         IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
3782      &  KFLA(2).LE.8) M3JC=1
3783         IF(MSTJ(47).GE.2) M3JC=1
3784       ENDIF
3785
3786 C...Define imagined single initiator of shower for parton system.
3787       NS=N
3788       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
3789         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
3790         IF(MSTU(21).GE.1) RETURN
3791       ENDIF
3792       IF(NPA.GE.2) THEN
3793         K(N+1,1)=11
3794         K(N+1,2)=21
3795         K(N+1,3)=0
3796         K(N+1,4)=0
3797         K(N+1,5)=0
3798         P(N+1,1)=0.
3799         P(N+1,2)=0.
3800         P(N+1,3)=0.
3801         P(N+1,4)=PS(5)
3802         P(N+1,5)=PS(5)
3803         V(N+1,5)=PS(5)**2
3804         N=N+1
3805       ENDIF
3806
3807 C...Loop over partons that may branch.
3808       NEP=NPA
3809       IM=NS
3810       IF(NPA.EQ.1) IM=NS-1
3811   140 IM=IM+1
3812       IF(N.GT.NS) THEN
3813         IF(IM.GT.N) GOTO 380
3814         KFLM=IABS(K(IM,2))
3815         IF(KFLM.EQ.0.OR.(KFLM.GT.8.AND.KFLM.NE.21)) GOTO 140
3816         IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
3817         IGM=K(IM,3)
3818       ELSE
3819         IGM=-1
3820       ENDIF
3821       IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
3822         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
3823         IF(MSTU(21).GE.1) RETURN
3824       ENDIF
3825
3826 C...Position of aunt (sister to branching parton).
3827 C...Origin and flavour of daughters.
3828       IAU=0
3829       IF(IGM.GT.0) THEN
3830         IF(K(IM-1,3).EQ.IGM) IAU=IM-1
3831         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
3832       ENDIF
3833       IF(IGM.GE.0) THEN
3834         K(IM,4)=N+1
3835         DO 150 I=1,NEP
3836   150   K(N+I,3)=IM
3837       ELSE
3838         K(N+1,3)=IPA(1)
3839       ENDIF
3840       IF(IGM.LE.0) THEN
3841         DO 160 I=1,NEP
3842   160   K(N+I,2)=K(IPA(I),2)
3843       ELSEIF(KFLM.NE.21) THEN
3844         K(N+1,2)=K(IM,2)
3845         K(N+2,2)=K(IM,5)
3846       ELSEIF(K(IM,5).EQ.21) THEN
3847         K(N+1,2)=21
3848         K(N+2,2)=21
3849       ELSE
3850         K(N+1,2)=K(IM,5)
3851         K(N+2,2)=-K(IM,5)
3852       ENDIF
3853
3854 C...Reset flags on daughers and tries made.
3855       DO 170 IP=1,NEP
3856       K(N+IP,1)=3
3857       K(N+IP,4)=0
3858       K(N+IP,5)=0
3859       KFLD(IP)=IABS(K(N+IP,2))
3860       ITRY(IP)=0
3861       ISL(IP)=0
3862       ISI(IP)=0
3863   170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1
3864       ISLM=0
3865
3866 C...Maximum virtuality of daughters.
3867       IF(IGM.LE.0) THEN
3868         DO 180 I=1,NPA
3869         IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
3870      &  PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
3871         P(N+I,5)=MIN(QMAX,PS(5))
3872         IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
3873   180   IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
3874       ELSE
3875         IF(MSTJ(43).LE.2) PEM=V(IM,2)
3876         IF(MSTJ(43).GE.3) PEM=P(IM,4)
3877         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
3878         P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
3879         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
3880       ENDIF
3881       DO 190 I=1,NEP
3882       PMSD(I)=P(N+I,5)
3883       IF(ISI(I).EQ.1) THEN
3884         IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))
3885       ENDIF
3886   190 V(N+I,5)=P(N+I,5)**2
3887
3888 C...Choose one of the daughters for evolution.
3889   200 INUM=0
3890       IF(NEP.EQ.1) INUM=1
3891       DO 210 I=1,NEP
3892   210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
3893       DO 220 I=1,NEP
3894       IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
3895         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I
3896       ENDIF
3897   220 CONTINUE
3898       IF(INUM.EQ.0) THEN
3899         RMAX=0.
3900         DO 230 I=1,NEP
3901         IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
3902           RPM=P(N+I,5)/PMSD(I)
3903           IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN
3904             RMAX=RPM
3905             INUM=I
3906           ENDIF
3907         ENDIF
3908   230   CONTINUE
3909       ENDIF
3910
3911 C...Store information on choice of evolving daughter.
3912       INUM=MAX(1,INUM)
3913       IEP(1)=N+INUM
3914       DO 240 I=2,NEP
3915       IEP(I)=IEP(I-1)+1
3916   240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
3917       DO 250 I=1,NEP
3918   250 KFL(I)=IABS(K(IEP(I),2))
3919       ITRY(INUM)=ITRY(INUM)+1
3920       IF(ITRY(INUM).GT.200) THEN
3921         CALL LUERRM(14,'(LUSHOW:) caught in infinite loop')
3922         IF(MSTU(21).GE.1) RETURN
3923       ENDIF
3924       Z=0.5
3925       IF(KFL(1).EQ.0.OR.(KFL(1).GT.8.AND.KFL(1).NE.21)) GOTO 300
3926       IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300
3927
3928 C...Calculate allowed z range.
3929       IF(NEP.EQ.1) THEN
3930         PMED=PS(4)
3931       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3932         PMED=P(IM,5)
3933       ELSE
3934         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
3935         IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
3936       ENDIF
3937       IF(MOD(MSTJ(43),2).EQ.1) THEN
3938         ZC=PMTH(2,21)/PMED
3939         ZCE=PMTH(2,22)/PMED
3940       ELSE
3941         ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
3942         IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
3943         ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
3944         IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
3945       ENDIF
3946       ZC=MIN(ZC,0.491)
3947       ZCE=MIN(ZCE,0.491)
3948       IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
3949      &MIN(ZC,ZCE).GT.0.49)) THEN
3950         P(IEP(1),5)=PMTH(1,KFL(1))
3951         V(IEP(1),5)=P(IEP(1),5)**2
3952         GOTO 300
3953       ENDIF
3954
3955 C...Integral of Altarelli-Parisi z kernel for QCD.
3956       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
3957         FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
3958       ELSEIF(MSTJ(49).EQ.0) THEN
3959         FBR=(8./3.)*LOG((1.-ZC)/ZC)
3960
3961 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
3962       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
3963         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
3964       ELSEIF(MSTJ(49).EQ.1) THEN
3965         FBR=(1.-2.*ZC)/3.
3966         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
3967
3968 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
3969       ELSEIF(KFL(1).EQ.21) THEN
3970         FBR=6.*MSTJ(45)*(0.5-ZC)
3971       ELSE
3972         FBR=2.*LOG((1.-ZC)/ZC)
3973       ENDIF
3974
3975 C...Integral of Altarelli-Parisi kernel for photon emission.
3976       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8)
3977      &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
3978
3979 C...Inner veto algorithm starts. Find maximum mass for evolution.
3980   260 PMS=V(IEP(1),5)
3981       IF(IGM.GE.0) THEN
3982         PM2=0.
3983         DO 270 I=2,NEP
3984         PM=P(IEP(I),5)
3985         IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=
3986      &  PMTH(2,KFL(I))
3987   270   PM2=PM2+PM
3988         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
3989       ENDIF
3990
3991 C...Select mass for daughter in QCD evolution.
3992       B0=27./6.
3993       DO 280 IF=4,MSTJ(45)
3994   280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
3995       IF(MSTJ(44).LE.0) THEN
3996         PMSQCD=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
3997       ELSEIF(MSTJ(44).EQ.1) THEN
3998         PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
3999       ELSE
4000         PMSQCD=PMS*RLU(0)**(ALFM*B0/FBR)
4001       ENDIF
4002       IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
4003      &PMTH(2,KFL(1))**2
4004       V(IEP(1),5)=PMSQCD
4005       MCE=1
4006
4007 C...Select mass for daughter in QED evolution.
4008       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN
4009         PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
4010         IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
4011      &  PMTH(2,KFL(1))**2
4012         IF(PMSQED.GT.PMSQCD) THEN
4013           V(IEP(1),5)=PMSQED
4014           MCE=2
4015         ENDIF
4016       ENDIF
4017
4018 C...Check whether daughter mass below cutoff.
4019       P(IEP(1),5)=SQRT(V(IEP(1),5))
4020       IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
4021         P(IEP(1),5)=PMTH(1,KFL(1))
4022         V(IEP(1),5)=P(IEP(1),5)**2
4023         GOTO 300
4024       ENDIF
4025
4026 C...Select z value of branching: q -> qgamma.
4027       IF(MCE.EQ.2) THEN
4028         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
4029         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4030         K(IEP(1),5)=22
4031
4032 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4033       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
4034         Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4035         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4036         K(IEP(1),5)=21
4037       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
4038         Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4039         IF(RLU(0).GT.0.5) Z=1.-Z
4040         IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
4041         K(IEP(1),5)=21
4042       ELSEIF(MSTJ(49).NE.1) THEN
4043         Z=ZC+(1.-2.*ZC)*RLU(0)
4044         IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
4045         KFLB=1+INT(MSTJ(45)*RLU(0))
4046         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4047         IF(PMQ.GE.1.) GOTO 260
4048         PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
4049         IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
4050      &  RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
4051         K(IEP(1),5)=KFLB
4052
4053 C...Ditto for scalar gluon model.
4054       ELSEIF(KFL(1).NE.21) THEN
4055         Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
4056         K(IEP(1),5)=21
4057       ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4058         Z=ZC+(1.-2.*ZC)*RLU(0)
4059         K(IEP(1),5)=21
4060       ELSE
4061         Z=ZC+(1.-2.*ZC)*RLU(0)
4062         KFLB=1+INT(MSTJ(45)*RLU(0))
4063         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4064         IF(PMQ.GE.1.) GOTO 260
4065         K(IEP(1),5)=KFLB
4066       ENDIF
4067       IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
4068         IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
4069         IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
4070       ENDIF
4071
4072 C...Check if z consistent with chosen m.
4073       IF(KFL(1).EQ.21) THEN
4074         KFLGD1=IABS(K(IEP(1),5))
4075         KFLGD2=KFLGD1
4076       ELSE
4077         KFLGD1=KFL(1)
4078         KFLGD2=IABS(K(IEP(1),5))
4079       ENDIF
4080       IF(NEP.EQ.1) THEN
4081         PED=PS(4)
4082       ELSEIF(NEP.GE.3) THEN
4083         PED=P(IEP(1),4)
4084       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4085         PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
4086       ELSE
4087         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
4088         IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
4089       ENDIF
4090       IF(MOD(MSTJ(43),2).EQ.1) THEN
4091         PMQTH3=0.5*PARJ(82)
4092         IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4093         PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
4094         PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
4095         ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4096      &  4.*PMQ1*PMQ2)))
4097         ZH=1.+PMQ1-PMQ2
4098       ELSE
4099         ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4100         ZH=1.
4101       ENDIF
4102       ZL=0.5*(ZH-ZD)
4103       ZU=0.5*(ZH+ZD)
4104       IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
4105       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
4106      &(1.-ZU)))
4107       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4108
4109 C...Three-jet matrix element correction.
4110       IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
4111         X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
4112         X2=1.-V(IEP(1),5)/V(NS+1,5)
4113         X3=(1.-X1)+(1.-X2)
4114         IF(MCE.EQ.2) THEN
4115           KI1=K(IPA(INUM),2)
4116           KI2=K(IPA(3-INUM),2)
4117           QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
4118           QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
4119           WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
4120      &    QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
4121           WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
4122         ELSEIF(MSTJ(49).NE.1) THEN
4123           WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
4124      &    (1.-X2)/X3*(X2/(2.-X1))**2
4125           WME=X1**2+X2**2
4126         ELSE
4127           WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
4128           WME=X3**2
4129         ENDIF
4130         IF(WME.LT.RLU(0)*WSHOW) GOTO 260
4131
4132 C...Impose angular ordering by rejection of nonordered emission.
4133       ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
4134         MAOM=1
4135         ZM=V(IM,1)
4136         IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
4137         THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
4138         IAOM=IM
4139   290   IF(K(IAOM,5).EQ.22) THEN
4140           IAOM=K(IAOM,3)
4141           IF(K(IAOM,3).LE.NS) MAOM=0
4142           IF(MAOM.EQ.1) GOTO 290
4143         ENDIF
4144         IF(MAOM.EQ.1) THEN
4145           THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
4146           IF(THE2ID.LT.THE2IM) GOTO 260
4147         ENDIF
4148       ENDIF
4149
4150 C...Impose user-defined maximum angle at first branching.
4151       IF(MSTJ(48).EQ.1) THEN
4152         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
4153           THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
4154           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4155         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
4156           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4157           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4158         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
4159           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4160           IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
4161         ENDIF
4162       ENDIF
4163
4164 C...End of inner veto algorithm. Check if only one leg evolved so far.
4165   300 V(IEP(1),1)=Z
4166       ISL(1)=0
4167       ISL(2)=0
4168       IF(NEP.EQ.1) GOTO 330
4169       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
4170       DO 310 I=1,NEP
4171       IF(ITRY(I).EQ.0.AND.KFLD(I).GT.0.AND.(KFLD(I).LE.8.OR.KFLD(I).EQ.
4172      &21)) THEN
4173         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
4174       ENDIF
4175   310 CONTINUE
4176
4177 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4178       IF(NEP.EQ.3) THEN
4179         PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
4180         PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
4181         PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
4182         PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
4183      &  PA1S**2-PA2S**2-PA3S**2)/PA1S
4184         IF(PTS.LE.0.) GOTO 200
4185       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
4186         DO 320 I1=N+1,N+2
4187         KFLDA=IABS(K(I1,2))
4188         IF(KFLDA.EQ.0.OR.(KFLDA.GT.8.AND.KFLDA.NE.21)) GOTO 320
4189         IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
4190         IF(KFLDA.EQ.21) THEN
4191           KFLGD1=IABS(K(I1,5))
4192           KFLGD2=KFLGD1
4193         ELSE
4194           KFLGD1=KFLDA
4195           KFLGD2=IABS(K(I1,5))
4196         ENDIF
4197         I2=2*N+3-I1
4198         IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4199           PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
4200         ELSE
4201           IF(I1.EQ.N+1) ZM=V(IM,1)
4202           IF(I1.EQ.N+2) ZM=1.-V(IM,1)
4203           PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
4204      &    4.*V(N+1,5)*V(N+2,5))
4205           PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
4206         ENDIF
4207         IF(MOD(MSTJ(43),2).EQ.1) THEN
4208           PMQTH3=0.5*PARJ(82)
4209           IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4210           PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
4211           PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
4212           ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4213      &    4.*PMQ1*PMQ2)))
4214           ZH=1.+PMQ1-PMQ2
4215         ELSE
4216           ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
4217           ZH=1.
4218         ENDIF
4219         ZL=0.5*(ZH-ZD)
4220         ZU=0.5*(ZH+ZD)
4221         IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
4222         IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
4223         IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
4224         IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4225   320   CONTINUE
4226         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
4227           ISL(3-ISLM)=0
4228           ISLM=3-ISLM
4229         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
4230           ZDR1=MAX(0.,V(N+1,3)/V(N+1,4)-1.)
4231           ZDR2=MAX(0.,V(N+2,3)/V(N+2,4)-1.)
4232           IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
4233           IF(ISL(1).EQ.1) ISL(2)=0
4234           IF(ISL(1).EQ.0) ISLM=1
4235           IF(ISL(2).EQ.0) ISLM=2
4236         ENDIF
4237         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
4238       ENDIF
4239       IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
4240      &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
4241         PMQ1=V(N+1,5)/V(IM,5)
4242         PMQ2=V(N+2,5)/V(IM,5)
4243         ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
4244      &  4.*PMQ1*PMQ2)))
4245         ZH=1.+PMQ1-PMQ2
4246         ZL=0.5*(ZH-ZD)
4247         ZU=0.5*(ZH+ZD)
4248         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
4249       ENDIF
4250
4251 C...Accepted branch. Construct four-momentum for initial partons.
4252   330 MAZIP=0
4253       MAZIC=0
4254       IF(NEP.EQ.1) THEN
4255         P(N+1,1)=0.
4256         P(N+1,2)=0.
4257         P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
4258      &  P(N+1,5))))
4259         P(N+1,4)=P(IPA(1),4)
4260         V(N+1,2)=P(N+1,4)
4261       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
4262         PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
4263         P(N+1,1)=0.
4264         P(N+1,2)=0.
4265         P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
4266         P(N+1,4)=PED1
4267         P(N+2,1)=0.
4268         P(N+2,2)=0.
4269         P(N+2,3)=-P(N+1,3)
4270         P(N+2,4)=P(IM,5)-PED1
4271         V(N+1,2)=P(N+1,4)
4272         V(N+2,2)=P(N+2,4)
4273       ELSEIF(NEP.EQ.3) THEN
4274         P(N+1,1)=0.
4275         P(N+1,2)=0.
4276         P(N+1,3)=SQRT(MAX(0.,PA1S))
4277         P(N+2,1)=SQRT(PTS)
4278         P(N+2,2)=0.
4279         P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4280         P(N+3,1)=-P(N+2,1)
4281         P(N+3,2)=0.
4282         P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4283         V(N+1,2)=P(N+1,4)
4284         V(N+2,2)=P(N+2,4)
4285         V(N+3,2)=P(N+3,4)
4286
4287 C...Construct transverse momentum for ordinary branching in shower.
4288       ELSE
4289         ZM=V(IM,1)
4290         PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4291         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4292         IF(PZM.LE.0.) THEN
4293           PTS=0.
4294         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4295           PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4296      &    ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4297         ELSE
4298           PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4299         ENDIF
4300         PT=SQRT(MAX(0.,PTS))
4301
4302 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4303         HAZIP=0.
4304         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4305      &  AND.IAU.NE.0) THEN
4306           IF(K(IGM,3).NE.0) MAZIP=1
4307           ZAU=V(IGM,1)
4308           IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4309           IF(MAZIP.EQ.0) ZAU=0.
4310           IF(K(IGM,2).NE.21) THEN
4311             HAZIP=2.*ZAU/(1.+ZAU**2)
4312           ELSE
4313             HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4314           ENDIF
4315           IF(K(N+1,2).NE.21) THEN
4316             HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4317           ELSE
4318             HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4319           ENDIF
4320         ENDIF
4321
4322 C...Find coefficient of azimuthal asymmetry due to soft gluon
4323 C...interference.
4324         HAZIC=0.
4325         IF(MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.K(N+2,2).EQ.21).
4326      &  AND.IAU.NE.0) THEN
4327           IF(K(IGM,3).NE.0) MAZIC=N+1
4328           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4329           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4330      &    ZM.GT.0.5) MAZIC=N+2
4331           IF(K(IAU,2).EQ.22) MAZIC=0
4332           ZS=ZM
4333           IF(MAZIC.EQ.N+2) ZS=1.-ZM
4334           ZGM=V(IGM,1)
4335           IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4336           IF(MAZIC.EQ.0) ZGM=1.
4337           HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4338           HAZIC=MIN(0.95,HAZIC)
4339         ENDIF
4340       ENDIF
4341
4342 C...Construct kinematics for ordinary branching in shower.
4343   340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4344         IF(MOD(MSTJ(43),2).EQ.1) THEN
4345           P(N+1,4)=PEM*V(IM,1)
4346         ELSE
4347           P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4348      &    SQRT(PMLS)*ZM)/V(IM,5)
4349         ENDIF
4350         PHI=PARU(2)*RLU(0)
4351         P(N+1,1)=PT*COS(PHI)
4352         P(N+1,2)=PT*SIN(PHI)
4353         IF(PZM.GT.0.) THEN
4354           P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4355         ELSE
4356           P(N+1,3)=0.
4357         ENDIF
4358         P(N+2,1)=-P(N+1,1)
4359         P(N+2,2)=-P(N+1,2)
4360         P(N+2,3)=PZM-P(N+1,3)
4361         P(N+2,4)=PEM-P(N+1,4)
4362         IF(MSTJ(43).LE.2) THEN
4363           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4364           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4365         ENDIF
4366       ENDIF
4367
4368 C...Rotate and boost daughters.
4369       IF(IGM.GT.0) THEN
4370         IF(MSTJ(43).LE.2) THEN
4371           BEX=P(IGM,1)/P(IGM,4)
4372           BEY=P(IGM,2)/P(IGM,4)
4373           BEZ=P(IGM,3)/P(IGM,4)
4374           GA=P(IGM,4)/P(IGM,5)
4375           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4376      &    P(IM,4))
4377         ELSE
4378           BEX=0.
4379           BEY=0.
4380           BEZ=0.
4381           GA=1.
4382           GABEP=0.
4383         ENDIF
4384         THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4385      &  (P(IM,2)+GABEP*BEY)**2))
4386         PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4387         DO 350 I=N+1,N+2
4388         DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4389      &  SIN(THE)*COS(PHI)*P(I,3)
4390         DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4391      &  SIN(THE)*SIN(PHI)*P(I,3)
4392         DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
4393         DP(4)=P(I,4)
4394         DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
4395         DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
4396         P(I,1)=DP(1)+DGABP*BEX
4397         P(I,2)=DP(2)+DGABP*BEY
4398         P(I,3)=DP(3)+DGABP*BEZ
4399   350   P(I,4)=GA*(DP(4)+DBP)
4400       ENDIF
4401
4402 C...Weight with azimuthal distribution, if required.
4403       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4404         DO 360 J=1,3
4405         DPT(1,J)=P(IM,J)
4406         DPT(2,J)=P(IAU,J)
4407   360   DPT(3,J)=P(N+1,J)
4408         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4409         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4410         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4411         DO 370 J=1,3
4412         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4413   370   DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4414         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4415         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4416         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
4417           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4418      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
4419           IF(MAZIP.NE.0) THEN
4420             IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4421      &      GOTO 340
4422           ENDIF
4423           IF(MAZIC.NE.0) THEN
4424             IF(MAZIC.EQ.N+2) CAD=-CAD
4425             IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4426      &      LT.RLU(0)) GOTO 340
4427           ENDIF
4428         ENDIF
4429       ENDIF
4430
4431 C...Continue loop over partons that may branch, until none left.
4432       IF(IGM.GE.0) K(IM,1)=14
4433       N=N+NEP
4434       NEP=2
4435       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4436         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4437         IF(MSTU(21).GE.1) N=NS
4438         IF(MSTU(21).GE.1) RETURN
4439       ENDIF
4440       GOTO 140
4441
4442 C...Set information on imagined shower initiator.
4443   380 IF(NPA.GE.2) THEN
4444         K(NS+1,1)=11
4445         K(NS+1,2)=94
4446         K(NS+1,3)=IP1
4447         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4448         K(NS+1,4)=NS+2
4449         K(NS+1,5)=NS+1+NPA
4450         IIM=1
4451       ELSE
4452         IIM=0
4453       ENDIF
4454
4455 C...Reconstruct string drawing information.
4456       DO 390 I=NS+1+IIM,N
4457       IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4458         K(I,1)=1
4459       ELSEIF(K(I,1).LE.10) THEN
4460         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4461         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4462       ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4463         ID1=MOD(K(I,4),MSTU(5))
4464         IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4465         ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4466         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4467         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4468         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4469         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4470         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4471         K(ID2,5)=K(ID2,5)+MSTU(5)*I
4472       ELSE
4473         ID1=MOD(K(I,4),MSTU(5))
4474         ID2=ID1+1
4475         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4476         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4477         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4478         K(ID1,5)=K(ID1,5)+MSTU(5)*I
4479         K(ID2,4)=0
4480         K(ID2,5)=0
4481       ENDIF
4482   390 CONTINUE
4483
4484 C...Transformation from CM frame.
4485       IF(NPA.GE.2) THEN
4486         BEX=PS(1)/PS(4)
4487         BEY=PS(2)/PS(4)
4488         BEZ=PS(3)/PS(4)
4489         GA=PS(4)/PS(5)
4490         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4491      &  /(1.+GA)-P(IPA(1),4))
4492       ELSE
4493         BEX=0.
4494         BEY=0.
4495         BEZ=0.
4496         GABEP=0.
4497       ENDIF
4498       THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4499      &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4500       PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4501       IF(NPA.EQ.3) THEN
4502         CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4503      &  SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4504      &  BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4505      &  GABEP*BEY))
4506         CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4507       ENDIF
4508       DBEX=DBLE(BEX)
4509       DBEY=DBLE(BEY)
4510       DBEZ=DBLE(BEZ)
4511       CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4512
4513 C...Decay vertex of shower.
4514       DO 400 I=NS+1,N
4515       DO 400 J=1,5
4516   400 V(I,J)=V(IP1,J)
4517
4518 C...Delete trivial shower, else connect initiators.
4519       IF(N.EQ.NS+NPA+IIM) THEN
4520         N=NS
4521       ELSE
4522         DO 410 IP=1,NPA
4523         K(IPA(IP),1)=14
4524         K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4525         K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4526         K(NS+IIM+IP,3)=IPA(IP)
4527         IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4528         K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4529   410   K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4530       ENDIF
4531
4532       RETURN
4533       END
4534
4535 C*********************************************************************
4536
4537       SUBROUTINE LUBOEI(NSAV)
4538
4539 C...Purpose: to modify event so as to approximately take into account
4540 C...Bose-Einstein effects according to a simple phenomenological
4541 C...parametrization.
4542       IMPLICIT DOUBLE PRECISION(D)
4543       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4544       SAVE /LUJETS/
4545       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4546       SAVE /LUDAT1/
4547       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4548       DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4549
4550 C...Boost event to overall CM frame. Calculate CM energy.
4551       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4552       DO 100 J=1,4
4553   100 DPS(J)=0.
4554       DO 120 I=1,N
4555       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4556       DO 110 J=1,4
4557   110 DPS(J)=DPS(J)+P(I,J)
4558   120 CONTINUE
4559       CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4560      &-DPS(3)/DPS(4))
4561       PECM=0.
4562       DO 130 I=1,N
4563   130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4564
4565 C...Reserve copy of particles by species at end of record.
4566       NBE(0)=N+MSTU(3)
4567       DO 160 IBE=1,MIN(9,MSTJ(51))
4568       NBE(IBE)=NBE(IBE-1)
4569       DO 150 I=NSAV+1,N
4570       IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4571       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4572       IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4573         CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')
4574         RETURN
4575       ENDIF
4576       NBE(IBE)=NBE(IBE)+1
4577       K(NBE(IBE),1)=I
4578       DO 140 J=1,3
4579   140 P(NBE(IBE),J)=0.
4580   150 CONTINUE
4581   160 CONTINUE
4582
4583 C...Tabulate integral for subsequent momentum shift.
4584       DO 210 IBE=1,MIN(9,MSTJ(51))
4585       IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4586       IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4587      &LE.1) GOTO 180
4588       IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4589      &NBE(7)-NBE(6)).LE.1) GOTO 180
4590       IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4591       IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4592       IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4593       IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4594       IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4595       QDEL=0.1*MIN(PMHQ,PARJ(93))
4596       IF(MSTJ(51).EQ.1) THEN
4597         NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4598         BEEX=EXP(0.5*QDEL/PARJ(93))
4599         BERT=EXP(-QDEL/PARJ(93))
4600       ELSE
4601         NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4602       ENDIF
4603       DO 170 IBIN=1,NBIN
4604       QBIN=QDEL*(IBIN-0.5)
4605       BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4606       IF(MSTJ(51).EQ.1) THEN
4607         BEEX=BEEX*BERT
4608         BEI(IBIN)=BEI(IBIN)*BEEX
4609       ELSE
4610         BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4611       ENDIF
4612   170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4613
4614 C...Loop through particle pairs and find old relative momentum.
4615   180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4616       I1=K(I1M,1)
4617       DO 200 I2M=I1M+1,NBE(IBE)
4618       I2=K(I2M,1)
4619       Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
4620      &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
4621       QOLD=SQRT(Q2OLD)
4622
4623 C...Calculate new relative momentum.
4624       IF(QOLD.LT.0.5*QDEL) THEN
4625         QMOV=QOLD/3.
4626       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
4627         RBIN=QOLD/QDEL
4628         IBIN=RBIN
4629         RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
4630         QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
4631      &  SQRT(Q2OLD+PMHQ**2)/Q2OLD
4632       ELSE
4633         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
4634       ENDIF
4635       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
4636
4637 C...Calculate and save shift to be performed on three-momenta.
4638       HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
4639       HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
4640       HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
4641       DO 190 J=1,3
4642       PD=HA*(P(I2,J)-P(I1,J))
4643       P(I1M,J)=P(I1M,J)+PD
4644   190 P(I2M,J)=P(I2M,J)-PD
4645   200 CONTINUE
4646   210 CONTINUE
4647
4648 C...Shift momenta and recalculate energies.
4649       DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))
4650       I=K(IM,1)
4651       DO 220 J=1,3
4652   220 P(I,J)=P(I,J)+P(IM,J)
4653   230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4654
4655 C...Rescale all momenta for energy conservation.
4656       PES=0.
4657       PQS=0.
4658       DO 240 I=1,N
4659       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
4660       PES=PES+P(I,4)
4661       PQS=PQS+P(I,5)**2/P(I,4)
4662   240 CONTINUE
4663       FAC=(PECM-PQS)/(PES-PQS)
4664       DO 260 I=1,N
4665       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
4666       DO 250 J=1,3
4667   250 P(I,J)=FAC*P(I,J)
4668       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4669   260 CONTINUE
4670
4671 C...Boost back to correct reference frame.
4672       CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
4673
4674       RETURN
4675       END
4676
4677 C*********************************************************************
4678
4679       FUNCTION ULMASS(KF)
4680
4681 C...Purpose: to give the mass of a particle/parton.
4682       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4683       SAVE /LUDAT1/
4684       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4685       SAVE /LUDAT2/
4686
4687 C...Reset variables. Compressed code.
4688       ULMASS=0.
4689       KFA=IABS(KF)
4690       KC=LUCOMP(KF)
4691       IF(KC.EQ.0) RETURN
4692       PARF(106)=PMAS(6,1)
4693       PARF(107)=PMAS(7,1)
4694       PARF(108)=PMAS(8,1)
4695
4696 C...Guarantee use of constituent masses for internal checks.
4697       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
4698         ULMASS=PARF(100+KFA)
4699         IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
4700
4701 C...Masses that can be read directly off table.
4702       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4703         ULMASS=PMAS(KC,1)
4704
4705 C...Find constituent partons and their masses.
4706       ELSE
4707         KFLA=MOD(KFA/1000,10)
4708         KFLB=MOD(KFA/100,10)
4709         KFLC=MOD(KFA/10,10)
4710         KFLS=MOD(KFA,10)
4711         KFLR=MOD(KFA/10000,10)
4712         PMA=PARF(100+KFLA)
4713         PMB=PARF(100+KFLB)
4714         PMC=PARF(100+KFLC)
4715
4716 C...Construct masses for various meson, diquark and baryon cases.
4717         IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4718           IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
4719           IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
4720           ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
4721         ELSEIF(KFLA.EQ.0) THEN
4722           KMUL=2
4723           IF(KFLS.EQ.1) KMUL=3
4724           IF(KFLR.EQ.2) KMUL=4
4725           IF(KFLS.EQ.5) KMUL=5
4726           ULMASS=PARF(113+KMUL)+PMB+PMC
4727         ELSEIF(KFLC.EQ.0) THEN
4728           IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
4729           IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
4730           ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
4731           IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
4732           IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
4733      &    2.*PARF(112)/3.)
4734         ELSE
4735           IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
4736             PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
4737           ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
4738             PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
4739           ELSEIF(KFLS.EQ.2) THEN
4740             PMSPL=-3./(PMB*PMC)
4741           ELSE
4742             PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
4743           ENDIF
4744           ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
4745         ENDIF
4746       ENDIF
4747
4748 C...Optional mass broadening according to truncated Breit-Wigner
4749 C...(either in m or in m^2).
4750       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
4751         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
4752           ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
4753      &    ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
4754         ELSE
4755           PM0=ULMASS
4756           PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
4757      &    (PM0*PMAS(KC,2)))
4758           PMUPP=ATAN((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))
4759           ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
4760      &    (PMUPP-PMLOW)*RLU(0))))
4761         ENDIF
4762       ENDIF
4763       MSTJ(93)=0
4764
4765       RETURN
4766       END
4767
4768 C*********************************************************************
4769
4770       SUBROUTINE LUNAME(KF,CHAU)
4771
4772 C...Purpose: to give the particle/parton name as a character string.
4773       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4774       SAVE /LUDAT1/
4775       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4776       SAVE /LUDAT2/
4777       COMMON/LUDAT4/CHAF(500)
4778       CHARACTER CHAF*8
4779       SAVE /LUDAT4/
4780       CHARACTER CHAU*16
4781
4782 C...Initial values. Charge. Subdivide code.
4783       CHAU=' '
4784       KFA=IABS(KF)
4785       KC=LUCOMP(KF)
4786       IF(KC.EQ.0) RETURN
4787       KQ=LUCHGE(KF)
4788       KFLA=MOD(KFA/1000,10)
4789       KFLB=MOD(KFA/100,10)
4790       KFLC=MOD(KFA/10,10)
4791       KFLS=MOD(KFA,10)
4792       KFLR=MOD(KFA/10000,10)
4793
4794 C...Read out root name and spin for simple particle.
4795       IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
4796         CHAU=CHAF(KC)
4797         LEN=0
4798         DO 100 LEM=1,8
4799   100   IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
4800
4801 C...Construct root name for diquark. Add on spin.
4802       ELSEIF(KFLC.EQ.0) THEN
4803         CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
4804         IF(KFLS.EQ.1) CHAU(3:4)='_0'
4805         IF(KFLS.EQ.3) CHAU(3:4)='_1'
4806         LEN=4
4807
4808 C...Construct root name for heavy meson. Add on spin and heavy flavour.
4809       ELSEIF(KFLA.EQ.0) THEN
4810         IF(KFLB.EQ.5) CHAU(1:1)='B'
4811         IF(KFLB.EQ.6) CHAU(1:1)='T'
4812         IF(KFLB.EQ.7) CHAU(1:1)='L'
4813         IF(KFLB.EQ.8) CHAU(1:1)='H'
4814         LEN=1
4815         IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4816         ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4817           CHAU(2:2)='*'
4818           LEN=2
4819         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4820           CHAU(2:3)='_1'
4821           LEN=3
4822         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4823           CHAU(2:4)='*_0'
4824           LEN=4
4825         ELSEIF(KFLR.EQ.2) THEN
4826           CHAU(2:4)='*_1'
4827           LEN=4
4828         ELSEIF(KFLS.EQ.5) THEN
4829           CHAU(2:4)='*_2'
4830           LEN=4
4831         ENDIF
4832         IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4833           CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
4834           LEN=LEN+2
4835         ELSEIF(KFLC.GE.3) THEN
4836           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4837           LEN=LEN+1
4838         ENDIF
4839
4840 C...Construct root name and spin for heavy baryon.
4841       ELSE
4842         IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
4843           CHAU='Sigma '
4844           IF(KFLC.GT.KFLB) CHAU='Lambda'
4845           IF(KFLS.EQ.4) CHAU='Sigma*'
4846           LEN=5
4847           IF(CHAU(6:6).NE.' ') LEN=6
4848         ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
4849           CHAU='Xi '
4850           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
4851           IF(KFLS.EQ.4) CHAU='Xi*'
4852           LEN=2
4853           IF(CHAU(3:3).NE.' ') LEN=3
4854         ELSE
4855           CHAU='Omega '
4856           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
4857           IF(KFLS.EQ.4) CHAU='Omega*'
4858           LEN=5
4859           IF(CHAU(6:6).NE.' ') LEN=6
4860         ENDIF
4861
4862 C...Add on heavy flavour content for heavy baryon.
4863         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
4864         LEN=LEN+2
4865         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
4866           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
4867           LEN=LEN+2
4868         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
4869           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
4870           LEN=LEN+1
4871         ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
4872           CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
4873           LEN=LEN+2
4874         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
4875           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4876           LEN=LEN+1
4877         ENDIF
4878       ENDIF
4879
4880 C...Add on bar sign for antiparticle (where necessary).
4881       IF(KF.GT.0.OR.LEN.EQ.0) THEN
4882       ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN
4883       ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
4884       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
4885       ELSEIF(MSTU(15).LE.1) THEN
4886         CHAU(LEN+1:LEN+1)='~'
4887         LEN=LEN+1
4888       ELSE
4889         CHAU(LEN+1:LEN+3)='bar'
4890         LEN=LEN+3
4891       ENDIF
4892
4893 C...Add on charge where applicable (conventional cases skipped).
4894       IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
4895       IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
4896       IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
4897       IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
4898       IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
4899       ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
4900       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
4901      &KFLB.NE.1) THEN
4902       ELSEIF(KQ.EQ.0) THEN
4903         CHAU(LEN+1:LEN+1)='0'
4904       ENDIF
4905
4906       RETURN
4907       END
4908
4909 C*********************************************************************
4910
4911       FUNCTION LUCHGE(KF)
4912
4913 C...Purpose: to give three times the charge for a particle/parton.
4914       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4915       SAVE /LUDAT2/
4916
4917 C...Initial values. Simple case of direct readout.
4918       LUCHGE=0
4919       KFA=IABS(KF)
4920       KC=LUCOMP(KFA)
4921       IF(KC.EQ.0) THEN
4922       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4923         LUCHGE=KCHG(KC,1)
4924
4925 C...Construction from quark content for heavy meson, diquark, baryon.
4926       ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
4927         LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
4928      &  (-1)**MOD(KFA/100,10)
4929       ELSEIF(MOD(KFA/10,10).EQ.0) THEN
4930         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
4931       ELSE
4932         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
4933      &  KCHG(MOD(KFA/10,10),1)
4934       ENDIF
4935
4936 C...Add on correct sign.
4937       LUCHGE=LUCHGE*ISIGN(1,KF)
4938
4939       RETURN
4940       END
4941
4942 C*********************************************************************
4943
4944       FUNCTION LUCOMP(KF)
4945
4946 C...Purpose: to compress the standard KF codes for use in mass and decay
4947 C...arrays; also to check whether a given code actually is defined.
4948       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4949       SAVE /LUDAT2/
4950
4951 C...Subdivide KF code into constituent pieces.
4952       LUCOMP=0
4953       KFA=IABS(KF)
4954       KFLA=MOD(KFA/1000,10)
4955       KFLB=MOD(KFA/100,10)
4956       KFLC=MOD(KFA/10,10)
4957       KFLS=MOD(KFA,10)
4958       KFLR=MOD(KFA/10000,10)
4959
4960 C...Simple cases: direct translation or special codes.
4961       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
4962       ELSEIF(KFA.LE.100) THEN
4963         LUCOMP=KFA
4964         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
4965       ELSEIF(KFLS.EQ.0) THEN
4966         IF(KF.EQ.130) LUCOMP=221
4967         IF(KF.EQ.310) LUCOMP=222
4968         IF(KFA.EQ.210) LUCOMP=281
4969         IF(KFA.EQ.2110) LUCOMP=282
4970         IF(KFA.EQ.2210) LUCOMP=283
4971
4972 C...Mesons.
4973       ELSEIF(KFA-10000*KFLR.LT.1000) THEN
4974         IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
4975         ELSEIF(KFLB.LT.KFLC) THEN
4976         ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
4977         ELSEIF(KFLB.EQ.KFLC) THEN
4978           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4979             LUCOMP=110+KFLB
4980           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4981             LUCOMP=130+KFLB
4982           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4983             LUCOMP=150+KFLB
4984           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4985             LUCOMP=170+KFLB
4986           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4987             LUCOMP=190+KFLB
4988           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4989             LUCOMP=210+KFLB
4990           ENDIF
4991         ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
4992           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4993             LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
4994           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4995             LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
4996           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4997             LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
4998           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4999             LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
5000           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
5001             LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
5002           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
5003             LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
5004           ENDIF
5005         ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
5006      &  OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
5007           LUCOMP=80+KFLB
5008         ENDIF
5009
5010 C...Diquarks.
5011       ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
5012         IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
5013         ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
5014         ELSEIF(KFLA.LT.KFLB) THEN
5015         ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
5016         ELSE
5017           LUCOMP=90
5018         ENDIF
5019
5020 C...Spin 1/2 baryons.
5021       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
5022         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5023         ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
5024         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
5025           LUCOMP=80+KFLA
5026         ELSEIF(KFLB.LT.KFLC) THEN
5027           LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
5028         ELSE
5029           LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5030         ENDIF
5031
5032 C...Spin 3/2 baryons.
5033       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
5034         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5035         ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
5036         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
5037           LUCOMP=80+KFLA
5038         ELSE
5039           LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5040         ENDIF
5041       ENDIF
5042
5043       RETURN
5044       END
5045
5046 C*********************************************************************
5047
5048       SUBROUTINE LUERRM(MERR,CHMESS)
5049
5050 C...Purpose: to inform user of errors in program execution.
5051       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5052       SAVE /LUJETS/
5053       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5054       SAVE /LUDAT1/
5055       CHARACTER CHMESS*(*)
5056
5057 C...Write first few warnings, then be silent.
5058       IF(MERR.LE.10) THEN
5059         MSTU(27)=MSTU(27)+1
5060         MSTU(28)=MERR
5061         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000)
5062      &  MERR,MSTU(31),CHMESS
5063
5064 C...Write first few errors, then be silent or stop program.
5065       ELSEIF(MERR.LE.20) THEN
5066         MSTU(23)=MSTU(23)+1
5067         MSTU(24)=MERR-10
5068         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100)
5069      &  MERR-10,MSTU(31),CHMESS
5070         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
5071           WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS
5072           WRITE(MSTU(11),1200)
5073           IF(MERR.NE.17) CALL LULIST(2)
5074           STOP
5075         ENDIF
5076
5077 C...Stop program in case of irreparable error.
5078       ELSE
5079         WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS
5080         STOP
5081       ENDIF
5082
5083 C...Formats for output.
5084  1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
5085      &' LUEXEC calls:'/5X,A)
5086  1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
5087      &' LUEXEC calls:'/5X,A)
5088  1200 FORMAT(5X,'Execution will be stopped after listing of last ',
5089      &'event!')
5090  1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
5091      &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
5092
5093       RETURN
5094       END
5095
5096 C*********************************************************************
5097
5098       FUNCTION ULALPS(Q2)
5099
5100 C...Purpose: to give the value of alpha_strong.
5101       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5102       SAVE /LUDAT1/
5103       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5104       SAVE /LUDAT2/
5105
5106 C...Constant alpha_strong trivial.
5107       IF(MSTU(111).LE.0) THEN
5108         ULALPS=PARU(111)
5109         MSTU(118)=MSTU(112)
5110         PARU(117)=0.
5111         PARU(118)=PARU(111)
5112         RETURN
5113       ENDIF
5114
5115 C...Find effective Q2, number of flavours and Lambda.
5116       Q2EFF=Q2
5117       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
5118       NF=MSTU(112)
5119       ALAM2=PARU(112)**2
5120   100 IF(NF.GT.MAX(2,MSTU(113))) THEN
5121         Q2THR=PARU(113)*PMAS(NF,1)**2
5122         IF(Q2EFF.LT.Q2THR) THEN
5123           NF=NF-1
5124           ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
5125           GOTO 100
5126         ENDIF
5127       ENDIF
5128   110 IF(NF.LT.MIN(8,MSTU(114))) THEN
5129         Q2THR=PARU(113)*PMAS(NF+1,1)**2
5130         IF(Q2EFF.GT.Q2THR) THEN
5131           NF=NF+1
5132           ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
5133           GOTO 110
5134         ENDIF
5135       ENDIF
5136       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
5137       PARU(117)=SQRT(ALAM2)
5138
5139 C...Evaluate first or second order alpha_strong.
5140       B0=(33.-2.*NF)/6.
5141       ALGQ=LOG(Q2EFF/ALAM2)
5142       IF(MSTU(111).EQ.1) THEN
5143         ULALPS=PARU(2)/(B0*ALGQ)
5144       ELSE
5145         B1=(153.-19.*NF)/6.
5146         ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ))
5147       ENDIF
5148       MSTU(118)=NF
5149       PARU(118)=ULALPS
5150
5151       RETURN
5152       END
5153
5154 C*********************************************************************
5155
5156       FUNCTION ULANGL(X,Y)
5157
5158 C...Purpose: to reconstruct an angle from given x and y coordinates.
5159       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5160       SAVE /LUDAT1/
5161
5162       ULANGL=0.
5163       R=SQRT(X**2+Y**2)
5164       IF(R.LT.1E-20) RETURN
5165       IF(ABS(X)/R.LT.0.8) THEN
5166         ULANGL=SIGN(ACOS(X/R),Y)
5167       ELSE
5168         ULANGL=ASIN(Y/R)
5169         IF(X.LT.0..AND.ULANGL.GE.0.) THEN
5170           ULANGL=PARU(1)-ULANGL
5171         ELSEIF(X.LT.0.) THEN
5172           ULANGL=-PARU(1)-ULANGL
5173         ENDIF
5174       ENDIF
5175
5176       RETURN
5177       END
5178
5179 C*********************************************************************
5180
5181       FUNCTION RLU(IDUM)
5182
5183 C...Purpose: to generate random numbers uniformly distributed between
5184 C...0 and 1, excluding the endpoints.
5185       COMMON/LUDATR/MRLU(6),RRLU(100)
5186       SAVE /LUDATR/
5187       EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
5188      &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
5189      &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
5190
5191 C...Initialize generation from given seed.
5192       IF(MRLU2.EQ.0) THEN
5193         IJ=MOD(MRLU1/30082,31329)
5194         KL=MOD(MRLU1,30082)
5195         I=MOD(IJ/177,177)+2
5196         J=MOD(IJ,177)+2
5197         K=MOD(KL/169,178)+1
5198         L=MOD(KL,169)
5199         DO 110 II=1,97
5200         S=0.
5201         T=0.5
5202         DO 100 JJ=1,24
5203         M=MOD(MOD(I*J,179)*K,179)
5204         I=J
5205         J=K
5206         K=M
5207         L=MOD(53*L+1,169)
5208         IF(MOD(L*M,64).GE.32) S=S+T
5209   100   T=0.5*T
5210   110   RRLU(II)=S
5211         TWOM24=1.
5212         DO 120 I24=1,24
5213   120   TWOM24=0.5*TWOM24
5214         RRLU98=362436.*TWOM24
5215         RRLU99=7654321.*TWOM24
5216         RRLU00=16777213.*TWOM24
5217         MRLU2=1
5218         MRLU3=0
5219         MRLU4=97
5220         MRLU5=33
5221       ENDIF
5222
5223 C...Generate next random number.
5224   130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
5225       IF(RUNI.LT.0.) RUNI=RUNI+1.
5226       RRLU(MRLU4)=RUNI
5227       MRLU4=MRLU4-1
5228       IF(MRLU4.EQ.0) MRLU4=97
5229       MRLU5=MRLU5-1
5230       IF(MRLU5.EQ.0) MRLU5=97
5231       RRLU98=RRLU98-RRLU99
5232       IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
5233       RUNI=RUNI-RRLU98
5234       IF(RUNI.LT.0.) RUNI=RUNI+1.
5235       IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
5236
5237 C...Update counters. Random number to output.
5238       MRLU3=MRLU3+1
5239       IF(MRLU3.EQ.1000000000) THEN
5240         MRLU2=MRLU2+1
5241         MRLU3=0
5242       ENDIF
5243       RLU=RUNI
5244
5245       RETURN
5246       END
5247
5248 C*********************************************************************
5249
5250       SUBROUTINE RLUGET(LFN,MOVE)
5251
5252 C...Purpose: to dump the state of the random number generator on a file
5253 C...for subsequent startup from this state onwards.
5254       COMMON/LUDATR/MRLU(6),RRLU(100)
5255       SAVE /LUDATR/
5256       CHARACTER CHERR*8
5257
5258 C...Backspace required number of records (or as many as there are).
5259       IF(MOVE.LT.0) THEN
5260         NBCK=MIN(MRLU(6),-MOVE)
5261         DO 100 IBCK=1,NBCK
5262   100   BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
5263         MRLU(6)=MRLU(6)-NBCK
5264       ENDIF
5265
5266 C...Unformatted write on unit LFN.
5267       WRITE(LFN,ERR=110,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5268      &(RRLU(I2),I2=1,100)
5269       MRLU(6)=MRLU(6)+1
5270       RETURN
5271
5272 C...Write error.
5273   110 WRITE(CHERR,'(I8)') IERR
5274       CALL LUERRM(18,'(RLUGET:) error when accessing file, IOSTAT ='//
5275      &CHERR)
5276
5277       RETURN
5278       END
5279
5280 C*********************************************************************
5281
5282       SUBROUTINE RLUSET(LFN,MOVE)
5283
5284 C...Purpose: to read a state of the random number generator from a file
5285 C...for subsequent generation from this state onwards.
5286       COMMON/LUDATR/MRLU(6),RRLU(100)
5287       SAVE /LUDATR/
5288       CHARACTER CHERR*8
5289
5290 C...Backspace required number of records (or as many as there are).
5291       IF(MOVE.LT.0) THEN
5292         NBCK=MIN(MRLU(6),-MOVE)
5293         DO 100 IBCK=1,NBCK
5294   100   BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
5295         MRLU(6)=MRLU(6)-NBCK
5296       ENDIF
5297
5298 C...Unformatted read from unit LFN.
5299       NFOR=1+MAX(0,MOVE)
5300       DO 110 IFOR=1,NFOR
5301   110 READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5302      &(RRLU(I2),I2=1,100)
5303       MRLU(6)=MRLU(6)+NFOR
5304       RETURN
5305
5306 C...Write error.
5307   120 WRITE(CHERR,'(I8)') IERR
5308       CALL LUERRM(18,'(RLUSET:) error when accessing file, IOSTAT ='//
5309      &CHERR)
5310
5311       RETURN
5312       END
5313
5314 C*********************************************************************
5315
5316       SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
5317
5318 C...Purpose: to perform rotations and boosts.
5319       IMPLICIT DOUBLE PRECISION(D)
5320       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5321       SAVE /LUJETS/
5322       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5323       SAVE /LUDAT1/
5324       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5325
5326 C...Find range of rotation/boost. Convert boost to double precision.
5327       IMIN=1
5328       IF(MSTU(1).GT.0) IMIN=MSTU(1)
5329       IMAX=N
5330       IF(MSTU(2).GT.0) IMAX=MSTU(2)
5331       DBX=BEX
5332       DBY=BEY
5333       DBZ=BEZ
5334       GOTO 100
5335
5336 C...Entry for specific range and double precision boost.
5337       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5338       IMIN=IMI
5339       IF(IMIN.LE.0) IMIN=1
5340       IMAX=IMA
5341       IF(IMAX.LE.0) IMAX=N
5342       DBX=DBEX
5343       DBY=DBEY
5344       DBZ=DBEZ
5345
5346 C...Check range of rotation/boost.
5347   100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5348         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5349         RETURN
5350       ENDIF
5351
5352 C...Rotate, typically from z axis to direction (theta,phi).
5353       IF(THE**2+PHI**2.GT.1E-20) THEN
5354         ROT(1,1)=COS(THE)*COS(PHI)
5355         ROT(1,2)=-SIN(PHI)
5356         ROT(1,3)=SIN(THE)*COS(PHI)
5357         ROT(2,1)=COS(THE)*SIN(PHI)
5358         ROT(2,2)=COS(PHI)
5359         ROT(2,3)=SIN(THE)*SIN(PHI)
5360         ROT(3,1)=-SIN(THE)
5361         ROT(3,2)=0.
5362         ROT(3,3)=COS(THE)
5363         DO 130 I=IMIN,IMAX
5364         IF(K(I,1).LE.0) GOTO 130
5365         DO 110 J=1,3
5366         PR(J)=P(I,J)
5367   110   VR(J)=V(I,J)
5368         DO 120 J=1,3
5369         P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5370   120   V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5371   130   CONTINUE
5372       ENDIF
5373
5374 C...Boost, typically from rest to momentum/energy=beta.
5375       IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5376         DB=SQRT(DBX**2+DBY**2+DBZ**2)
5377         IF(DB.GT.0.99999999D0) THEN
5378 C...Rescale boost vector if too close to unity.
5379           CALL LUERRM(3,'(LUROBO:) boost vector too large')
5380           DBX=DBX*(0.99999999D0/DB)
5381           DBY=DBY*(0.99999999D0/DB)
5382           DBZ=DBZ*(0.99999999D0/DB)
5383           DB=0.99999999D0
5384         ENDIF
5385         DGA=1D0/SQRT(1D0-DB**2)
5386         DO 150 I=IMIN,IMAX
5387         IF(K(I,1).LE.0) GOTO 150
5388         DO 140 J=1,4
5389         DP(J)=P(I,J)
5390   140   DV(J)=V(I,J)
5391         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5392         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5393         P(I,1)=DP(1)+DGABP*DBX
5394         P(I,2)=DP(2)+DGABP*DBY
5395         P(I,3)=DP(3)+DGABP*DBZ
5396         P(I,4)=DGA*(DP(4)+DBP)
5397         DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5398         DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5399         V(I,1)=DV(1)+DGABV*DBX
5400         V(I,2)=DV(2)+DGABV*DBY
5401         V(I,3)=DV(3)+DGABV*DBZ
5402         V(I,4)=DGA*(DV(4)+DBV)
5403   150   CONTINUE
5404       ENDIF
5405
5406       RETURN
5407       END
5408
5409 C*********************************************************************
5410 C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST
5411 C       THE FOUR MOMENTUM ONLY
5412 C*********************************************************************
5413
5414       SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)
5415
5416 C...Purpose: to perform rotations and boosts.
5417       IMPLICIT DOUBLE PRECISION(D)
5418       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5419       SAVE /LUJETS/
5420       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5421       SAVE /LUDAT1/
5422       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5423
5424 C...Find range of rotation/boost. Convert boost to double precision.
5425       IMIN=1
5426       IF(MSTU(1).GT.0) IMIN=MSTU(1)
5427       IMAX=N
5428       IF(MSTU(2).GT.0) IMAX=MSTU(2)
5429       DBX=BEX
5430       DBY=BEY
5431       DBZ=BEZ
5432
5433 C...Check range of rotation/boost.
5434       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5435         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5436         RETURN
5437       ENDIF
5438
5439 C...Rotate, typically from z axis to direction (theta,phi).
5440       IF(THE**2+PHI**2.GT.1E-20) THEN
5441         ROT(1,1)=COS(THE)*COS(PHI)
5442         ROT(1,2)=-SIN(PHI)
5443         ROT(1,3)=SIN(THE)*COS(PHI)
5444         ROT(2,1)=COS(THE)*SIN(PHI)
5445         ROT(2,2)=COS(PHI)
5446         ROT(2,3)=SIN(THE)*SIN(PHI)
5447         ROT(3,1)=-SIN(THE)
5448         ROT(3,2)=0.
5449         ROT(3,3)=COS(THE)
5450         DO 130 I=IMIN,IMAX
5451         IF(K(I,1).LE.0) GOTO 130
5452         DO 110 J=1,3
5453   110   PR(J)=P(I,J)
5454         DO 120 J=1,3
5455   120   P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5456   130   CONTINUE
5457       ENDIF
5458
5459 C...Boost, typically from rest to momentum/energy=beta.
5460       IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5461         DB=SQRT(DBX**2+DBY**2+DBZ**2)
5462         IF(DB.GT.0.99999999D0) THEN
5463 C...Rescale boost vector if too close to unity.
5464           CALL LUERRM(3,'(LUROBO:) boost vector too large')
5465           DBX=DBX*(0.99999999D0/DB)
5466           DBY=DBY*(0.99999999D0/DB)
5467           DBZ=DBZ*(0.99999999D0/DB)
5468           DB=0.99999999D0
5469         ENDIF
5470         DGA=1D0/SQRT(1D0-DB**2)
5471         DO 150 I=IMIN,IMAX
5472         IF(K(I,1).LE.0) GOTO 150
5473         DO 140 J=1,4
5474   140   DP(J)=P(I,J)
5475         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5476         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5477         P(I,1)=DP(1)+DGABP*DBX
5478         P(I,2)=DP(2)+DGABP*DBY
5479         P(I,3)=DP(3)+DGABP*DBZ
5480         P(I,4)=DGA*(DP(4)+DBP)
5481   150   CONTINUE
5482       ENDIF
5483
5484       RETURN
5485       END
5486
5487 C*********************************************************************
5488
5489       SUBROUTINE LUEDIT(MEDIT)
5490
5491 C...Purpose: to perform global manipulations on the event record,
5492 C...in particular to exclude unstable or undetectable partons/particles.
5493       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5494       SAVE /LUJETS/
5495       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5496       SAVE /LUDAT1/
5497       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5498       SAVE /LUDAT2/
5499       DIMENSION NS(2),PTS(2),PLS(2)
5500
5501 C...Remove unwanted partons/particles.
5502       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5503         IMAX=N
5504         IF(MSTU(2).GT.0) IMAX=MSTU(2)
5505         I1=MAX(1,MSTU(1))-1
5506         DO 110 I=MAX(1,MSTU(1)),IMAX
5507         IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5508         IF(MEDIT.EQ.1) THEN
5509           IF(K(I,1).GT.10) GOTO 110
5510         ELSEIF(MEDIT.EQ.2) THEN
5511           IF(K(I,1).GT.10) GOTO 110
5512           KC=LUCOMP(K(I,2))
5513           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5514      &    GOTO 110
5515         ELSEIF(MEDIT.EQ.3) THEN
5516           IF(K(I,1).GT.10) GOTO 110
5517           KC=LUCOMP(K(I,2))
5518           IF(KC.EQ.0) GOTO 110
5519           IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5520         ELSEIF(MEDIT.EQ.5) THEN
5521           IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5522           KC=LUCOMP(K(I,2))
5523           IF(KC.EQ.0) GOTO 110
5524           IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5525         ENDIF
5526
5527 C...Pack remaining partons/particles. Origin no longer known.
5528         I1=I1+1
5529         DO 100 J=1,5
5530         K(I1,J)=K(I,J)
5531         P(I1,J)=P(I,J)
5532   100   V(I1,J)=V(I,J)
5533         K(I1,3)=0
5534   110   CONTINUE
5535         N=I1
5536
5537 C...Selective removal of class of entries. New position of retained.
5538       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5539         I1=0
5540         DO 120 I=1,N
5541         K(I,3)=MOD(K(I,3),MSTU(5))
5542         IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5543         IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5544         IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5545      &  K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5546         IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5547      &  K(I,2).EQ.94)) GOTO 120
5548         IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5549         I1=I1+1
5550         K(I,3)=K(I,3)+MSTU(5)*I1
5551   120   CONTINUE
5552
5553 C...Find new event history information and replace old.
5554         DO 140 I=1,N
5555         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5556         ID=I
5557   130   IM=MOD(K(ID,3),MSTU(5))
5558         IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5559           IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5560      &    K(IM,2).NE.94) THEN
5561             ID=IM
5562             GOTO 130
5563           ENDIF
5564         ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5565           IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5566             ID=IM
5567             GOTO 130
5568           ENDIF
5569         ENDIF
5570         K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5571         IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5572         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5573           IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5574      &    K(K(I,4),3)/MSTU(5)
5575           IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5576      &    K(K(I,5),3)/MSTU(5)
5577         ELSE
5578           KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5579           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5580           KCD=MOD(K(I,4),MSTU(5))
5581           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5582           K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5583           KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5584           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5585           KCD=MOD(K(I,5),MSTU(5))
5586           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5587           K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5588         ENDIF
5589   140   CONTINUE
5590
5591 C...Pack remaining entries.
5592         I1=0
5593         DO 160 I=1,N
5594         IF(K(I,3)/MSTU(5).EQ.0) GOTO 160
5595         I1=I1+1
5596         DO 150 J=1,5
5597         K(I1,J)=K(I,J)
5598         P(I1,J)=P(I,J)
5599   150   V(I1,J)=V(I,J)
5600         K(I1,3)=MOD(K(I1,3),MSTU(5))
5601   160   CONTINUE
5602         N=I1
5603
5604 C...Save top entries at bottom of LUJETS commonblock.
5605       ELSEIF(MEDIT.EQ.21) THEN
5606         IF(2*N.GE.MSTU(4)) THEN
5607           CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS')
5608           RETURN
5609         ENDIF
5610         DO 170 I=1,N
5611         DO 170 J=1,5
5612         K(MSTU(4)-I,J)=K(I,J)
5613         P(MSTU(4)-I,J)=P(I,J)
5614   170   V(MSTU(4)-I,J)=V(I,J)
5615         MSTU(32)=N
5616
5617 C...Restore bottom entries of commonblock LUJETS to top.
5618       ELSEIF(MEDIT.EQ.22) THEN
5619         DO 180 I=1,MSTU(32)
5620         DO 180 J=1,5
5621         K(I,J)=K(MSTU(4)-I,J)
5622         P(I,J)=P(MSTU(4)-I,J)
5623   180   V(I,J)=V(MSTU(4)-I,J)
5624         N=MSTU(32)
5625
5626 C...Mark primary entries at top of commonblock LUJETS as untreated.
5627       ELSEIF(MEDIT.EQ.23) THEN
5628         I1=0
5629         DO 190 I=1,N
5630         KH=K(I,3)
5631         IF(KH.GE.1) THEN
5632           IF(K(KH,1).GT.20) KH=0
5633         ENDIF
5634         IF(KH.NE.0) GOTO 200
5635         I1=I1+1
5636   190   IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5637   200   N=I1
5638
5639 C...Place largest axis along z axis and second largest in xy plane.
5640       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5641         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5642      &  P(MSTU(61),2)),0D0,0D0,0D0)
5643         CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5644      &  P(MSTU(61),1)),0.,0D0,0D0,0D0)
5645         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5646      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)
5647         IF(MEDIT.EQ.31) RETURN
5648
5649 C...Rotate to put slim jet along +z axis.
5650         DO 210 IS=1,2
5651         NS(IS)=0
5652         PTS(IS)=0.
5653   210   PLS(IS)=0.
5654         DO 220 I=1,N
5655         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 220
5656         IF(MSTU(41).GE.2) THEN
5657           KC=LUCOMP(K(I,2))
5658           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5659      &    KC.EQ.18) GOTO 220
5660           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5661      &    GOTO 220
5662         ENDIF
5663         IS=2.-SIGN(0.5,P(I,3))
5664         NS(IS)=NS(IS)+1
5665         PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
5666   220   CONTINUE
5667         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
5668      &  CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
5669
5670 C...Rotate to put second largest jet into -z,+x quadrant.
5671         DO 230 I=1,N
5672         IF(P(I,3).GE.0.) GOTO 230
5673         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
5674         IF(MSTU(41).GE.2) THEN
5675           KC=LUCOMP(K(I,2))
5676           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5677      &    KC.EQ.18) GOTO 230
5678           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5679      &    GOTO 230
5680         ENDIF
5681         IS=2.-SIGN(0.5,P(I,1))
5682         PLS(IS)=PLS(IS)-P(I,3)
5683   230   CONTINUE
5684         IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
5685      &  0D0,0D0,0D0)
5686       ENDIF
5687
5688       RETURN
5689       END
5690
5691 C*********************************************************************
5692
5693       SUBROUTINE LULIST(MLIST)
5694
5695 C...Purpose: to give program heading, or list an event, or particle
5696 C...data, or current parameter values.
5697       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5698       SAVE /LUJETS/
5699       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5700       SAVE /LUDAT1/
5701       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5702       SAVE /LUDAT2/
5703       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5704       SAVE /LUDAT3/
5705       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
5706       DIMENSION PS(6)
5707       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
5708      &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
5709
5710 C...Initialization printout: version number and date of last change.
5711 C      IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
5712 C        WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185),
5713 C     &  CHMO(MSTU(184)),MSTU(183)
5714 C        MSTU(12)=0
5715 C        IF(MLIST.EQ.0) RETURN
5716 C      ENDIF
5717
5718 C...List event data, including additional lines after N.
5719       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
5720         IF(MLIST.EQ.1) WRITE(MSTU(11),1100)
5721         IF(MLIST.EQ.2) WRITE(MSTU(11),1200)
5722         IF(MLIST.EQ.3) WRITE(MSTU(11),1300)
5723         LMX=12
5724         IF(MLIST.GE.2) LMX=16
5725         ISTR=0
5726         IMAX=N
5727         IF(MSTU(2).GT.0) IMAX=MSTU(2)
5728         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
5729         IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
5730
5731 C...Get particle name, pad it and check it is not too long.
5732         CALL LUNAME(K(I,2),CHAP)
5733         LEN=0
5734         DO 100 LEM=1,16
5735   100   IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
5736         MDL=(K(I,1)+19)/10
5737         LDL=0
5738         IF(MDL.EQ.2.OR.MDL.GE.8) THEN
5739           CHAC=CHAP
5740           IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
5741         ELSE
5742           LDL=1
5743           IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
5744           IF(LEN.EQ.0) THEN
5745             CHAC=CHDL(MDL)(1:2*LDL)//' '
5746           ELSE
5747             CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
5748      &      CHDL(MDL)(LDL+1:2*LDL)//' '
5749             IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
5750           ENDIF
5751         ENDIF
5752
5753 C...Add information on string connection.
5754         IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
5755      &  THEN
5756           KC=LUCOMP(K(I,2))
5757           KCC=0
5758           IF(KC.NE.0) KCC=KCHG(KC,2)
5759           IF(KCC.NE.0.AND.ISTR.EQ.0) THEN
5760             ISTR=1
5761             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
5762           ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
5763             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
5764           ELSEIF(KCC.NE.0) THEN
5765             ISTR=0
5766             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
5767           ENDIF
5768         ENDIF
5769
5770 C...Write data for particle/jet.
5771         IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
5772           WRITE(MSTU(11),1400) I,CHAC(1:12),(K(I,J1),J1=1,3),
5773      &    (P(I,J2),J2=1,5)
5774         ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
5775           WRITE(MSTU(11),1500) I,CHAC(1:12),(K(I,J1),J1=1,3),
5776      &    (P(I,J2),J2=1,5)
5777         ELSEIF(MLIST.EQ.1) THEN
5778           WRITE(MSTU(11),1600) I,CHAC(1:12),(K(I,J1),J1=1,3),
5779      &    (P(I,J2),J2=1,5)
5780         ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
5781      &  K(I,1).EQ.14)) THEN
5782           WRITE(MSTU(11),1700) I,CHAC,(K(I,J1),J1=1,3),
5783      &    K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
5784      &    K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
5785      &    (P(I,J2),J2=1,5)
5786         ELSE
5787           WRITE(MSTU(11),1800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
5788         ENDIF
5789         IF(MLIST.EQ.3) WRITE(MSTU(11),1900) (V(I,J),J=1,5)
5790
5791 C...Insert extra separator lines specified by user.
5792         IF(MSTU(70).GE.1) THEN
5793           ISEP=0
5794           DO 110 J=1,MIN(10,MSTU(70))
5795   110     IF(I.EQ.MSTU(70+J)) ISEP=1
5796           IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000)
5797           IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100)
5798         ENDIF
5799   120   CONTINUE
5800
5801 C...Sum of charges and momenta.
5802         DO 130 J=1,6
5803   130   PS(J)=PLU(0,J)
5804         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
5805           WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)
5806         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
5807           WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)
5808         ELSEIF(MLIST.EQ.1) THEN
5809           WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)
5810         ELSE
5811           WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)
5812         ENDIF
5813
5814 C...Give simple list of KF codes defined in program.
5815       ELSEIF(MLIST.EQ.11) THEN
5816         WRITE(MSTU(11),2600)
5817         DO 140 KF=1,40
5818         CALL LUNAME(KF,CHAP)
5819         CALL LUNAME(-KF,CHAN)
5820         IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),2700) KF,CHAP
5821   140   IF(CHAN.NE.' ') WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5822         DO 150 KFLS=1,3,2
5823         DO 150 KFLA=1,8
5824         DO 150 KFLB=1,KFLA-(3-KFLS)/2
5825         KF=1000*KFLA+100*KFLB+KFLS
5826         CALL LUNAME(KF,CHAP)
5827         CALL LUNAME(-KF,CHAN)
5828   150   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5829         DO 170 KMUL=0,5
5830         KFLS=3
5831         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
5832         IF(KMUL.EQ.5) KFLS=5
5833         KFLR=0
5834         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
5835         IF(KMUL.EQ.4) KFLR=2
5836         DO 170 KFLB=1,8
5837         DO 160 KFLC=1,KFLB-1
5838         KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
5839         CALL LUNAME(KF,CHAP)
5840         CALL LUNAME(-KF,CHAN)
5841   160   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5842         KF=10000*KFLR+110*KFLB+KFLS
5843         CALL LUNAME(KF,CHAP)
5844   170   WRITE(MSTU(11),2700) KF,CHAP
5845         KF=130
5846         CALL LUNAME(KF,CHAP)
5847         WRITE(MSTU(11),2700) KF,CHAP
5848         KF=310
5849         CALL LUNAME(KF,CHAP)
5850         WRITE(MSTU(11),2700) KF,CHAP
5851         DO 190 KFLSP=1,3
5852         KFLS=2+2*(KFLSP/3)
5853         DO 190 KFLA=1,8
5854         DO 190 KFLB=1,KFLA
5855         DO 180 KFLC=1,KFLB
5856         IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
5857         IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
5858         IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
5859         IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
5860         CALL LUNAME(KF,CHAP)
5861         CALL LUNAME(-KF,CHAN)
5862         WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5863   180   CONTINUE
5864   190   CONTINUE
5865
5866 C...List parton/particle data table. Check whether to be listed.
5867       ELSEIF(MLIST.EQ.12) THEN
5868         WRITE(MSTU(11),2800)
5869         MSTJ24=MSTJ(24)
5870         MSTJ(24)=0
5871         KFMAX=20883
5872         IF(MSTU(2).NE.0) KFMAX=MSTU(2)
5873         DO 220 KF=MAX(1,MSTU(1)),KFMAX
5874         KC=LUCOMP(KF)
5875         IF(KC.EQ.0) GOTO 220
5876         IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
5877         IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
5878      &  MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
5879
5880 C...Find particle name and mass. Print information.
5881         CALL LUNAME(KF,CHAP)
5882         IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
5883         CALL LUNAME(-KF,CHAN)
5884         PM=ULMASS(KF)
5885         WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
5886      &  KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
5887
5888 C...Particle decay: channel number, branching ration, matrix element,
5889 C...decay products.
5890         IF(KF.GT.100.AND.KC.LE.100) GOTO 220
5891         DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5892         DO 200 J=1,5
5893   200   CALL LUNAME(KFDP(IDC,J),CHAD(J))
5894   210   WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5895      &  (CHAD(J),J=1,5)
5896   220   CONTINUE
5897         MSTJ(24)=MSTJ24
5898
5899 C...List parameter value table.
5900       ELSEIF(MLIST.EQ.13) THEN
5901         WRITE(MSTU(11),3100)
5902         DO 230 I=1,200
5903   230   WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
5904       ENDIF
5905
5906 C...Format statements for output on unit MSTU(11) (by default 6).
5907  1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/
5908      &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)
5909  1100 FORMAT(///28X,'Event listing (summary)'//4X,'I  particle/jet KS',
5910      &5X,'KF orig    p_x      p_y      p_z       E        m'/)
5911  1200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',
5912      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
5913      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)
5914  1300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',
5915      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
5916      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,
5917      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)
5918  1400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
5919  1500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
5920  1600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
5921  1700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
5922  1800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
5923  1900 FORMAT(66X,5(1X,F12.3))
5924  2000 FORMAT(1X,78('='))
5925  2100 FORMAT(1X,130('='))
5926  2200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
5927  2300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
5928  2400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
5929  2500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
5930      &5F13.5)
5931  2600 FORMAT(///20X,'List of KF codes in program'/)
5932  2700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
5933  2800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
5934      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,
5935      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
5936      &1X,'ME',3X,'Br.rat.',4X,'decay products')
5937  2900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
5938      &2X,F12.5,3X,I2)
5939  3000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
5940  3100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
5941      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
5942  3200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
5943
5944       RETURN
5945       END
5946
5947 C*********************************************************************
5948
5949       SUBROUTINE LUUPDA(MUPDA,LFN)
5950
5951 C...Purpose: to facilitate the updating of particle and decay data.
5952       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5953       SAVE /LUDAT1/
5954       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5955       SAVE /LUDAT2/
5956       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5957       SAVE /LUDAT3/
5958       COMMON/LUDAT4/CHAF(500)
5959       CHARACTER CHAF*8
5960       SAVE /LUDAT4/
5961       CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
5962      &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
5963       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
5964      &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
5965      &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',
5966      &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/
5967
5968 C...Write information on file for editing.
5969       IF(MSTU(12).GE.1) CALL LULIST(0)
5970       IF(MUPDA.EQ.1) THEN
5971         DO 110 KC=1,MSTU(6)
5972         WRITE(LFN,1000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
5973      &  (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
5974         DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5975   100   WRITE(LFN,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5976      &  (KFDP(IDC,J),J=1,5)
5977   110   CONTINUE
5978
5979 C...Reset variables and read information from edited file.
5980       ELSEIF(MUPDA.EQ.2) THEN
5981         DO 120 I=1,MSTU(7)
5982         MDME(I,1)=1
5983         MDME(I,2)=0
5984         BRAT(I)=0.
5985         DO 120 J=1,5
5986   120   KFDP(I,J)=0
5987         KC=0
5988         IDC=0
5989         NDC=0
5990   130   READ(LFN,1200,END=140) CHINL
5991         IF(CHINL(2:5).NE.'    ') THEN
5992           CHKC=CHINL(2:5)
5993           IF(KC.NE.0) THEN
5994             MDCY(KC,2)=0
5995             IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
5996             MDCY(KC,3)=NDC
5997           ENDIF
5998           READ(CHKC,1300) KC
5999           IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,
6000      &    '(LUUPDA:) Read KC code illegal, KC ='//CHKC)
6001           READ(CHINL,1000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
6002      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
6003           NDC=0
6004         ELSE
6005           IDC=IDC+1
6006           NDC=NDC+1
6007           IF(IDC.GE.MSTU(7)) CALL LUERRM(27,
6008      &    '(LUUPDA:) Decay data arrays full by KC ='//CHKC)
6009           READ(CHINL,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6010      &    (KFDP(IDC,J),J=1,5)
6011         ENDIF
6012         GOTO 130
6013   140   MDCY(KC,2)=0
6014         IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
6015         MDCY(KC,3)=NDC
6016
6017 C...Perform possible tests that new information is consistent.
6018         MSTJ24=MSTJ(24)
6019         MSTJ(24)=0
6020         DO 170 KC=1,MSTU(6)
6021         WRITE(CHKC,1300) KC
6022         IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
6023      &  PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,
6024      &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
6025         BRSUM=0.
6026         DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6027         IF(MDME(IDC,2).GT.80) GOTO 160
6028         KQ=KCHG(KC,1)
6029         PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
6030         MERR=0
6031         DO 150 J=1,5
6032         KP=KFDP(IDC,J)
6033         IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
6034         ELSEIF(LUCOMP(KP).EQ.0) THEN
6035           MERR=3
6036         ELSE
6037           KQ=KQ-LUCHGE(KP)
6038           PMS=PMS-ULMASS(KP)
6039         ENDIF
6040   150   CONTINUE
6041         IF(KQ.NE.0) MERR=MAX(2,MERR)
6042         IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
6043      &  (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
6044      &  MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
6045         IF(MERR.EQ.3) CALL LUERRM(17,
6046      &  '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)
6047         IF(MERR.EQ.2) CALL LUERRM(17,
6048      &  '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)
6049         IF(MERR.EQ.1) CALL LUERRM(7,
6050      &  '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)
6051         BRSUM=BRSUM+BRAT(IDC)
6052   160   CONTINUE
6053         WRITE(CHTMP,1500) BRSUM
6054         IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
6055      &  LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
6056      &  ' for KC ='//CHKC)
6057   170   CONTINUE
6058         MSTJ(24)=MSTJ24
6059
6060 C...Initialize writing of DATA statements for inclusion in program.
6061       ELSEIF(MUPDA.EQ.3) THEN
6062         DO 240 IVAR=1,19
6063         NDIM=MSTU(6)
6064         IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
6065         NLIN=1
6066         CHLIN=' '
6067         CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
6068         LLIN=35
6069         CHOLD='START'
6070
6071 C...Loop through variables for conversion to characters.
6072         DO 220 IDIM=1,NDIM
6073         IF(IVAR.EQ.1) WRITE(CHTMP,1400) KCHG(IDIM,1)
6074         IF(IVAR.EQ.2) WRITE(CHTMP,1400) KCHG(IDIM,2)
6075         IF(IVAR.EQ.3) WRITE(CHTMP,1400) KCHG(IDIM,3)
6076         IF(IVAR.EQ.4) WRITE(CHTMP,1500) PMAS(IDIM,1)
6077         IF(IVAR.EQ.5) WRITE(CHTMP,1500) PMAS(IDIM,2)
6078         IF(IVAR.EQ.6) WRITE(CHTMP,1500) PMAS(IDIM,3)
6079         IF(IVAR.EQ.7) WRITE(CHTMP,1500) PMAS(IDIM,4)
6080         IF(IVAR.EQ.8) WRITE(CHTMP,1400) MDCY(IDIM,1)
6081         IF(IVAR.EQ.9) WRITE(CHTMP,1400) MDCY(IDIM,2)
6082         IF(IVAR.EQ.10) WRITE(CHTMP,1400) MDCY(IDIM,3)
6083         IF(IVAR.EQ.11) WRITE(CHTMP,1400) MDME(IDIM,1)
6084         IF(IVAR.EQ.12) WRITE(CHTMP,1400) MDME(IDIM,2)
6085         IF(IVAR.EQ.13) WRITE(CHTMP,1500) BRAT(IDIM)
6086         IF(IVAR.EQ.14) WRITE(CHTMP,1400) KFDP(IDIM,1)
6087         IF(IVAR.EQ.15) WRITE(CHTMP,1400) KFDP(IDIM,2)
6088         IF(IVAR.EQ.16) WRITE(CHTMP,1400) KFDP(IDIM,3)
6089         IF(IVAR.EQ.17) WRITE(CHTMP,1400) KFDP(IDIM,4)
6090         IF(IVAR.EQ.18) WRITE(CHTMP,1400) KFDP(IDIM,5)
6091         IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
6092
6093 C...Length of variable, trailing decimal zeros, quotation marks.
6094         LLOW=1
6095         LHIG=1
6096         DO 180 LL=1,12
6097         IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
6098   180   IF(CHTMP(LL:LL).NE.' ') LHIG=LL
6099         CHNEW=CHTMP(LLOW:LHIG)//' '
6100         LNEW=1+LHIG-LLOW
6101         IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
6102           LNEW=LNEW+1
6103   190     LNEW=LNEW-1
6104           IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190
6105           IF(LNEW.EQ.1) CHNEW(1:2)='0.'
6106           IF(LNEW.EQ.1) LNEW=2
6107         ELSEIF(IVAR.EQ.19) THEN
6108           DO 200 LL=LNEW,1,-1
6109           IF(CHNEW(LL:LL).EQ.'''') THEN
6110             CHTMP=CHNEW
6111             CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
6112             LNEW=LNEW+1
6113           ENDIF
6114   200     CONTINUE
6115           CHTMP=CHNEW
6116           CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
6117           LNEW=LNEW+2
6118         ENDIF
6119
6120 C...Form composite character string, often including repetition counter.
6121         IF(CHNEW.NE.CHOLD) THEN
6122           NRPT=1
6123           CHOLD=CHNEW
6124           CHCOM=CHNEW
6125           LCOM=LNEW
6126         ELSE
6127           LRPT=LNEW+1
6128           IF(NRPT.GE.2) LRPT=LNEW+3
6129           IF(NRPT.GE.10) LRPT=LNEW+4
6130           IF(NRPT.GE.100) LRPT=LNEW+5
6131           IF(NRPT.GE.1000) LRPT=LNEW+6
6132           LLIN=LLIN-LRPT
6133           NRPT=NRPT+1
6134           WRITE(CHTMP,1400) NRPT
6135           LRPT=1
6136           IF(NRPT.GE.10) LRPT=2
6137           IF(NRPT.GE.100) LRPT=3
6138           IF(NRPT.GE.1000) LRPT=4
6139           CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
6140           LCOM=LRPT+1+LNEW
6141         ENDIF
6142
6143 C...Add characters to end of line, to new line (after storing old line),
6144 C...or to new block of lines (after writing old block).
6145         IF(LLIN+LCOM.LE.70) THEN
6146           CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
6147           LLIN=LLIN+LCOM+1
6148         ELSEIF(NLIN.LE.19) THEN
6149           CHLIN(LLIN+1:72)=' '
6150           CHBLK(NLIN)=CHLIN
6151           NLIN=NLIN+1
6152           CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
6153           LLIN=6+LCOM+1
6154         ELSE
6155           CHLIN(LLIN:72)='/'//' '
6156           CHBLK(NLIN)=CHLIN
6157           WRITE(CHTMP,1400) IDIM-NRPT
6158           CHBLK(1)(30:33)=CHTMP(9:12)
6159           DO 210 ILIN=1,NLIN
6160   210     WRITE(LFN,1600) CHBLK(ILIN)
6161           NLIN=1
6162           CHLIN=' '
6163           CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I=    ,    )/'//
6164      &    CHCOM(1:LCOM)//','
6165           WRITE(CHTMP,1400) IDIM-NRPT+1
6166           CHLIN(25:28)=CHTMP(9:12)
6167           LLIN=35+LCOM+1
6168         ENDIF
6169   220   CONTINUE
6170
6171 C...Write final block of lines.
6172         CHLIN(LLIN:72)='/'//' '
6173         CHBLK(NLIN)=CHLIN
6174         WRITE(CHTMP,1400) NDIM
6175         CHBLK(1)(30:33)=CHTMP(9:12)
6176         DO 230 ILIN=1,NLIN
6177   230   WRITE(LFN,1600) CHBLK(ILIN)
6178   240   CONTINUE
6179       ENDIF
6180
6181 C...Formats for reading and writing particle data.
6182  1000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
6183  1100 FORMAT(5X,2I5,F12.5,5I8)
6184  1200 FORMAT(A80)
6185  1300 FORMAT(I4)
6186  1400 FORMAT(I12)
6187  1500 FORMAT(F12.5)
6188  1600 FORMAT(A72)
6189
6190       RETURN
6191       END
6192
6193 C*********************************************************************
6194
6195       FUNCTION KLU(I,J)
6196
6197 C...Purpose: to provide various integer-valued event related data.
6198       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6199       SAVE /LUJETS/
6200       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6201       SAVE /LUDAT1/
6202       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6203       SAVE /LUDAT2/
6204
6205 C...Default value. For I=0 number of entries, number of stable entries
6206 C...or 3 times total charge.
6207       KLU=0
6208       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6209       ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
6210         KLU=N
6211       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
6212         DO 100 I1=1,N
6213         IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+1
6214         IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+
6215      &  LUCHGE(K(I1,2))
6216   100   CONTINUE
6217       ELSEIF(I.EQ.0) THEN
6218
6219 C...For I > 0 direct readout of K matrix or charge.
6220       ELSEIF(J.LE.5) THEN
6221         KLU=K(I,J)
6222       ELSEIF(J.EQ.6) THEN
6223         KLU=LUCHGE(K(I,2))
6224
6225 C...Status (existing/fragmented/decayed), parton/hadron separation.
6226       ELSEIF(J.LE.8) THEN
6227         IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLU=1
6228         IF(J.EQ.8) KLU=KLU*K(I,2)
6229       ELSEIF(J.LE.12) THEN
6230         KFA=IABS(K(I,2))
6231         KC=LUCOMP(KFA)
6232         KQ=0
6233         IF(KC.NE.0) KQ=KCHG(KC,2)
6234         IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLU=K(I,2)
6235         IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLU=K(I,2)
6236         IF(J.EQ.11) KLU=KC
6237         IF(J.EQ.12) KLU=KQ*ISIGN(1,K(I,2))
6238
6239 C...Heaviest flavour in hadron/diquark.
6240       ELSEIF(J.EQ.13) THEN
6241         KFA=IABS(K(I,2))
6242         KLU=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
6243         IF(KFA.LT.10) KLU=KFA
6244         IF(MOD(KFA/1000,10).NE.0) KLU=MOD(KFA/1000,10)
6245         KLU=KLU*ISIGN(1,K(I,2))
6246
6247 C...Particle history: generation, ancestor, rank.
6248       ELSEIF(J.LE.16) THEN
6249         I2=I
6250         I1=I
6251   110   KLU=KLU+1
6252         I3=I2
6253         I2=I1
6254         I1=K(I1,3)
6255         IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
6256         IF(J.EQ.15) KLU=I2
6257         IF(J.EQ.16) THEN
6258           KLU=0
6259           DO 120 I1=I2+1,I3
6260   120     IF(K(I1,3).EQ.I2.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) KLU=KLU+1
6261         ENDIF
6262
6263 C...Particle coming from collapsing jet system or not.
6264       ELSEIF(J.EQ.17) THEN
6265         I1=I
6266   130   KLU=KLU+1
6267         I3=I1
6268         I1=K(I1,3)
6269         I0=MAX(1,I1)
6270         KC=LUCOMP(K(I0,2))
6271         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
6272           IF(KLU.EQ.1) KLU=-1
6273           IF(KLU.GT.1) KLU=0
6274           RETURN
6275         ENDIF
6276         IF(KCHG(KC,2).EQ.0) GOTO 130
6277         IF(K(I1,1).NE.12) KLU=0
6278         IF(K(I1,1).NE.12) RETURN
6279         I2=I1
6280   140   I2=I2+1
6281         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 140
6282         K3M=K(I3-1,3)
6283         IF(K3M.GE.I1.AND.K3M.LE.I2) KLU=0
6284         K3P=K(I3+1,3)
6285         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLU=0
6286
6287 C...Number of decay products. Colour flow.
6288       ELSEIF(J.EQ.18) THEN
6289         IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLU=MAX(0,K(I,5)-K(I,4)+1)
6290         IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLU=0
6291       ELSEIF(J.LE.22) THEN
6292         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
6293         IF(J.EQ.19) KLU=MOD(K(I,4)/MSTU(5),MSTU(5))
6294         IF(J.EQ.20) KLU=MOD(K(I,5)/MSTU(5),MSTU(5))
6295         IF(J.EQ.21) KLU=MOD(K(I,4),MSTU(5))
6296         IF(J.EQ.22) KLU=MOD(K(I,5),MSTU(5))
6297       ELSE
6298       ENDIF
6299
6300       RETURN
6301       END
6302
6303 C*********************************************************************
6304
6305       FUNCTION PLU(I,J)
6306
6307 C...Purpose: to provide various real-valued event related data.
6308       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6309       SAVE /LUJETS/
6310       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6311       SAVE /LUDAT1/
6312       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6313       SAVE /LUDAT2/
6314       DIMENSION PSUM(4)
6315
6316 C...Set default value. For I = 0 sum of momenta or charges,
6317 C...or invariant mass of system.
6318       PLU=0.
6319       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6320       ELSEIF(I.EQ.0.AND.J.LE.4) THEN
6321         DO 100 I1=1,N
6322   100   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
6323       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
6324         DO 110 J1=1,4
6325         PSUM(J1)=0.
6326         DO 110 I1=1,N
6327   110   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
6328         PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
6329       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
6330         DO 120 I1=1,N
6331   120   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
6332       ELSEIF(I.EQ.0) THEN
6333
6334 C...Direct readout of P matrix.
6335       ELSEIF(J.LE.5) THEN
6336         PLU=P(I,J)
6337
6338 C...Charge, total momentum, transverse momentum, transverse mass.
6339       ELSEIF(J.LE.12) THEN
6340         IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
6341         IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
6342         IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
6343         IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
6344         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
6345
6346 C...Theta and phi angle in radians or degrees.
6347       ELSEIF(J.LE.16) THEN
6348         IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
6349         IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
6350         IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
6351
6352 C...True rapidity, rapidity with pion mass, pseudorapidity.
6353       ELSEIF(J.LE.19) THEN
6354         PMR=0.
6355         IF(J.EQ.17) PMR=P(I,5)
6356         IF(J.EQ.18) PMR=ULMASS(211)
6357         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
6358         PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
6359      &  1E20)),P(I,3))
6360
6361 C...Energy and momentum fractions (only to be used in CM frame).
6362       ELSEIF(J.LE.25) THEN
6363         IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
6364         IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
6365         IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
6366         IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
6367         IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
6368         IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
6369       ENDIF
6370
6371       RETURN
6372       END
6373
6374 C*********************************************************************
6375
6376       SUBROUTINE LUSPHE(SPH,APL)
6377
6378 C...Purpose: to perform sphericity tensor analysis to give sphericity,
6379 C...aplanarity and the related event axes.
6380       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6381       SAVE /LUJETS/
6382       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6383       SAVE /LUDAT1/
6384       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6385       SAVE /LUDAT2/
6386       DIMENSION SM(3,3),SV(3,3)
6387
6388 C...Calculate matrix to be diagonalized.
6389       NP=0
6390       DO 100 J1=1,3
6391       DO 100 J2=J1,3
6392   100 SM(J1,J2)=0.
6393       PS=0.
6394       DO 120 I=1,N
6395       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
6396       IF(MSTU(41).GE.2) THEN
6397         KC=LUCOMP(K(I,2))
6398         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6399      &  KC.EQ.18) GOTO 120
6400         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6401      &  GOTO 120
6402       ENDIF
6403       NP=NP+1
6404       PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6405       PWT=1.
6406       IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
6407       DO 110 J1=1,3
6408       DO 110 J2=J1,3
6409   110 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
6410       PS=PS+PWT*PA**2
6411   120 CONTINUE
6412
6413 C...Very low multiplicities (0 or 1) not considered.
6414       IF(NP.LE.1) THEN
6415         CALL LUERRM(8,'(LUSPHE:) too few particles for analysis')
6416         SPH=-1.
6417         APL=-1.
6418         RETURN
6419       ENDIF
6420       DO 130 J1=1,3
6421       DO 130 J2=J1,3
6422   130 SM(J1,J2)=SM(J1,J2)/PS
6423
6424 C...Find eigenvalues to matrix (third degree equation).
6425       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
6426      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
6427       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
6428      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
6429       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
6430       P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
6431       P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)
6432       P(N+2,4)=1.-P(N+1,4)-P(N+3,4)
6433       IF(P(N+2,4).LT.1E-5) THEN
6434         CALL LUERRM(8,'(LUSPHE:) all particles back-to-back')
6435         SPH=-1.
6436         APL=-1.
6437         RETURN
6438       ENDIF
6439
6440 C...Find first and last eigenvector by solving equation system.
6441       DO 170 I=1,3,2
6442       DO 140 J1=1,3
6443       SV(J1,J1)=SM(J1,J1)-P(N+I,4)
6444       DO 140 J2=J1+1,3
6445       SV(J1,J2)=SM(J1,J2)
6446   140 SV(J2,J1)=SM(J1,J2)
6447       SMAX=0.
6448       DO 150 J1=1,3
6449       DO 150 J2=1,3
6450       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 150
6451       JA=J1
6452       JB=J2
6453       SMAX=ABS(SV(J1,J2))
6454   150 CONTINUE
6455       SMAX=0.
6456       DO 160 J3=JA+1,JA+2
6457       J1=J3-3*((J3-1)/3)
6458       RL=SV(J1,JB)/SV(JA,JB)
6459       DO 160 J2=1,3
6460       SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
6461       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 160
6462       JC=J1
6463       SMAX=ABS(SV(J1,J2))
6464   160 CONTINUE
6465       JB1=JB+1-3*(JB/3)
6466       JB2=JB+2-3*((JB+1)/3)
6467       P(N+I,JB1)=-SV(JC,JB2)
6468       P(N+I,JB2)=SV(JC,JB1)
6469       P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
6470      &SV(JA,JB)
6471       PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
6472       SGN=(-1.)**INT(RLU(0)+0.5)
6473       DO 170 J=1,3
6474   170 P(N+I,J)=SGN*P(N+I,J)/PA
6475
6476 C...Middle axis orthogonal to other two. Fill other codes.
6477       SGN=(-1.)**INT(RLU(0)+0.5)
6478       P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
6479       P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
6480       P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
6481       DO 180 I=1,3
6482       K(N+I,1)=31
6483       K(N+I,2)=95
6484       K(N+I,3)=I
6485       K(N+I,4)=0
6486       K(N+I,5)=0
6487       P(N+I,5)=0.
6488       DO 180 J=1,5
6489   180 V(I,J)=0.
6490
6491 C...Select storing option. Calculate sphericity and aplanarity.
6492       MSTU(61)=N+1
6493       MSTU(62)=NP
6494       IF(MSTU(43).LE.1) MSTU(3)=3
6495       IF(MSTU(43).GE.2) N=N+3
6496       SPH=1.5*(P(N+2,4)+P(N+3,4))
6497       APL=1.5*P(N+3,4)
6498
6499       RETURN
6500       END
6501
6502 C*********************************************************************
6503
6504       SUBROUTINE LUTHRU(THR,OBL)
6505
6506 C...Purpose: to perform thrust analysis to give thrust, oblateness
6507 C...and the related event axes.
6508       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6509       SAVE /LUJETS/
6510       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6511       SAVE /LUDAT1/
6512       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6513       SAVE /LUDAT2/
6514       DIMENSION TDI(3),TPR(3)
6515
6516 C...Take copy of particles that are to be considered in thrust analysis.
6517       NP=0
6518       PS=0.
6519       DO 100 I=1,N
6520       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
6521       IF(MSTU(41).GE.2) THEN
6522         KC=LUCOMP(K(I,2))
6523         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6524      &  KC.EQ.18) GOTO 100
6525         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6526      &  GOTO 100
6527       ENDIF
6528       IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
6529         CALL LUERRM(11,'(LUTHRU:) no more memory left in LUJETS')
6530         THR=-2.
6531         OBL=-2.
6532         RETURN
6533       ENDIF
6534       NP=NP+1
6535       K(N+NP,1)=23
6536       P(N+NP,1)=P(I,1)
6537       P(N+NP,2)=P(I,2)
6538       P(N+NP,3)=P(I,3)
6539       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6540       P(N+NP,5)=1.
6541       IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)
6542       PS=PS+P(N+NP,4)*P(N+NP,5)
6543   100 CONTINUE
6544
6545 C...Very low multiplicities (0 or 1) not considered.
6546       IF(NP.LE.1) THEN
6547         CALL LUERRM(8,'(LUTHRU:) too few particles for analysis')
6548         THR=-1.
6549         OBL=-1.
6550         RETURN
6551       ENDIF
6552
6553 C...Loop over thrust and major. T axis along z direction in latter case.
6554       DO 280 ILD=1,2
6555       IF(ILD.EQ.2) THEN
6556         K(N+NP+1,1)=31
6557         PHI=ULANGL(P(N+NP+1,1),P(N+NP+1,2))
6558         CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0)
6559         THE=ULANGL(P(N+NP+1,3),P(N+NP+1,1))
6560         CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0)
6561       ENDIF
6562
6563 C...Find and order particles with highest p (pT for major).
6564       DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
6565   110 P(ILF,4)=0.
6566       DO 150 I=N+1,N+NP
6567       IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
6568       DO 120 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
6569       IF(P(I,4).LE.P(ILF,4)) GOTO 130
6570       DO 120 J=1,5
6571   120 P(ILF+1,J)=P(ILF,J)
6572       ILF=N+NP+3
6573   130 DO 140 J=1,5
6574   140 P(ILF+1,J)=P(I,J)
6575   150 CONTINUE
6576
6577 C...Find and order initial axes with highest thrust (major).
6578       DO 160 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
6579   160 P(ILG,4)=0.
6580       NC=2**(MIN(MSTU(44),NP)-1)
6581       DO 220 ILC=1,NC
6582       DO 170 J=1,3
6583   170 TDI(J)=0.
6584       DO 180 ILF=1,MIN(MSTU(44),NP)
6585       SGN=P(N+NP+ILF+3,5)
6586       IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
6587       DO 180 J=1,4-ILD
6588   180 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
6589       TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
6590       DO 190 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
6591       IF(TDS.LE.P(ILG,4)) GOTO 200
6592       DO 190 J=1,4
6593   190 P(ILG+1,J)=P(ILG,J)
6594       ILG=N+NP+MSTU(44)+4
6595   200 DO 210 J=1,3
6596   210 P(ILG+1,J)=TDI(J)
6597       P(ILG+1,4)=TDS
6598   220 CONTINUE
6599
6600 C...Iterate direction of axis until stable maximum.
6601       P(N+NP+ILD,4)=0.
6602       ILG=0
6603   230 ILG=ILG+1
6604       THP=0.
6605   240 THPS=THP
6606       DO 250 J=1,3
6607       IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
6608       IF(THP.GT.1E-10) TDI(J)=TPR(J)
6609   250 TPR(J)=0.
6610       DO 260 I=N+1,N+NP
6611       SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
6612       DO 260 J=1,4-ILD
6613   260 TPR(J)=TPR(J)+SGN*P(I,J)
6614       THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
6615       IF(THP.GE.THPS+PARU(48)) GOTO 240
6616
6617 C...Save good axis. Try new initial axis until a number of tries agree.
6618       IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 230
6619       IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
6620         IAGR=0
6621         SGN=(-1.)**INT(RLU(0)+0.5)
6622         DO 270 J=1,3
6623   270   P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
6624         P(N+NP+ILD,4)=THP
6625         P(N+NP+ILD,5)=0.
6626       ENDIF
6627       IAGR=IAGR+1
6628   280 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 230
6629
6630 C...Find minor axis and value by orthogonality.
6631       SGN=(-1.)**INT(RLU(0)+0.5)
6632       P(N+NP+3,1)=-SGN*P(N+NP+2,2)
6633       P(N+NP+3,2)=SGN*P(N+NP+2,1)
6634       P(N+NP+3,3)=0.
6635       THP=0.
6636       DO 290 I=N+1,N+NP
6637   290 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
6638       P(N+NP+3,4)=THP/PS
6639       P(N+NP+3,5)=0.
6640
6641 C...Fill axis information. Rotate back to original coordinate system.
6642       DO 300 ILD=1,3
6643       K(N+ILD,1)=31
6644       K(N+ILD,2)=96
6645       K(N+ILD,3)=ILD
6646       K(N+ILD,4)=0
6647       K(N+ILD,5)=0
6648       DO 300 J=1,5
6649       P(N+ILD,J)=P(N+NP+ILD,J)
6650   300 V(N+ILD,J)=0.
6651       CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
6652
6653 C...Select storing option. Calculate thurst and oblateness.
6654       MSTU(61)=N+1
6655       MSTU(62)=NP
6656       IF(MSTU(43).LE.1) MSTU(3)=3
6657       IF(MSTU(43).GE.2) N=N+3
6658       THR=P(N+1,4)
6659       OBL=P(N+2,4)-P(N+3,4)
6660
6661       RETURN
6662       END
6663
6664 C*********************************************************************
6665
6666       SUBROUTINE LUCLUS(NJET)
6667
6668 C...Purpose: to subdivide the particle content of an event into
6669 C...jets/clusters.
6670       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6671       SAVE /LUJETS/
6672       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6673       SAVE /LUDAT1/
6674       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6675       SAVE /LUDAT2/
6676       DIMENSION PS(5)
6677       SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
6678
6679 C...Functions: distance measure in pT or (pseudo)mass.
6680       R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
6681      &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2
6682       R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*
6683      &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
6684
6685 C...If first time, reset. If reentering, skip preliminaries.
6686       IF(MSTU(48).LE.0) THEN
6687         NP=0
6688         DO 100 J=1,5
6689   100   PS(J)=0.
6690         PSS=0.
6691       ELSE
6692         NJET=NSAV
6693         IF(MSTU(43).GE.2) N=N-NJET
6694         DO 110 I=N+1,N+NJET
6695   110   P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6696         IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
6697         IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
6698         NLOOP=0
6699         GOTO 290
6700       ENDIF
6701
6702 C...Find which particles are to be considered in cluster search.
6703       DO 140 I=1,N
6704       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
6705       IF(MSTU(41).GE.2) THEN
6706         KC=LUCOMP(K(I,2))
6707         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6708      &  KC.EQ.18) GOTO 140
6709         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6710      &  GOTO 140
6711       ENDIF
6712       IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
6713         CALL LUERRM(11,'(LUCLUS:) no more memory left in LUJETS')
6714         NJET=-1
6715         RETURN
6716       ENDIF
6717
6718 C...Take copy of these particles, with space left for jets later on.
6719       NP=NP+1
6720       K(N+NP,3)=I
6721       DO 120 J=1,5
6722   120 P(N+NP,J)=P(I,J)
6723       IF(MSTU(42).EQ.0) P(N+NP,5)=0.
6724       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
6725       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
6726       P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6727       DO 130 J=1,4
6728   130 PS(J)=PS(J)+P(N+NP,J)
6729       PSS=PSS+P(N+NP,5)
6730   140 CONTINUE
6731       DO 150 I=N+1,N+NP
6732       K(I+NP,3)=K(I,3)
6733       DO 150 J=1,5
6734   150 P(I+NP,J)=P(I,J)
6735       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
6736
6737 C...Very low multiplicities not considered.
6738       IF(NP.LT.MSTU(47)) THEN
6739         CALL LUERRM(8,'(LUCLUS:) too few particles for analysis')
6740         NJET=-1
6741         RETURN
6742       ENDIF
6743
6744 C...Find precluster configuration. If too few jets, make harder cuts.
6745       NLOOP=0
6746       IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
6747       IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
6748       RINIT=1.25*PARU(43)
6749       IF(NP.LE.MSTU(47)+2) RINIT=0.
6750   160 RINIT=0.8*RINIT
6751       NPRE=0
6752       NREM=NP
6753       DO 170 I=N+NP+1,N+2*NP
6754   170 K(I,4)=0
6755
6756 C...Sum up small momentum region. Jet if enough absolute momentum.
6757       IF(MSTU(46).LE.2) THEN
6758         DO 180 J=1,4
6759   180   P(N+1,J)=0.
6760         DO 200 I=N+NP+1,N+2*NP
6761         IF(P(I,5).GT.2.*RINIT) GOTO 200
6762         NREM=NREM-1
6763         K(I,4)=1
6764         DO 190 J=1,4
6765   190   P(N+1,J)=P(N+1,J)+P(I,J)
6766   200   CONTINUE
6767         P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
6768         IF(P(N+1,5).GT.2.*RINIT) NPRE=1
6769         IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
6770       ENDIF
6771
6772 C...Find fastest remaining particle.
6773   210 NPRE=NPRE+1
6774       PMAX=0.
6775       DO 220 I=N+NP+1,N+2*NP
6776       IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 220
6777       IMAX=I
6778       PMAX=P(I,5)
6779   220 CONTINUE
6780       DO 230 J=1,5
6781   230 P(N+NPRE,J)=P(IMAX,J)
6782       NREM=NREM-1
6783       K(IMAX,4)=NPRE
6784
6785 C...Sum up precluster around it according to pT separation.
6786       IF(MSTU(46).LE.2) THEN
6787         DO 250 I=N+NP+1,N+2*NP
6788         IF(K(I,4).NE.0) GOTO 250
6789         R2=R2T(I,IMAX)
6790         IF(R2.GT.RINIT**2) GOTO 250
6791         NREM=NREM-1
6792         K(I,4)=NPRE
6793         DO 240 J=1,4
6794   240   P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
6795   250   CONTINUE
6796         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
6797
6798 C...Sum up precluster around it according to mass separation.
6799       ELSE
6800   260   IMIN=0
6801         R2MIN=RINIT**2
6802         DO 270 I=N+NP+1,N+2*NP
6803         IF(K(I,4).NE.0) GOTO 270
6804         R2=R2M(I,N+NPRE)
6805         IF(R2.GE.R2MIN) GOTO 270
6806         IMIN=I
6807         R2MIN=R2
6808   270   CONTINUE
6809         IF(IMIN.NE.0) THEN
6810           DO 280 J=1,4
6811   280     P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
6812           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
6813           NREM=NREM-1
6814           K(IMIN,4)=NPRE
6815           GOTO 260
6816         ENDIF
6817       ENDIF
6818
6819 C...Check if more preclusters to be found. Start over if too few.
6820       IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
6821       IF(NREM.GT.0) GOTO 210
6822       NJET=NPRE
6823
6824 C...Reassign all particles to nearest jet. Sum up new jet momenta.
6825   290 TSAV=0.
6826       PSJT=0.
6827   300 IF(MSTU(46).LE.1) THEN
6828         DO 310 I=N+1,N+NJET
6829         DO 310 J=1,4
6830   310   V(I,J)=0.
6831         DO 340 I=N+NP+1,N+2*NP
6832         R2MIN=PSS**2
6833         DO 320 IJET=N+1,N+NJET
6834         IF(P(IJET,5).LT.RINIT) GOTO 320
6835         R2=R2T(I,IJET)
6836         IF(R2.GE.R2MIN) GOTO 320
6837         IMIN=IJET
6838         R2MIN=R2
6839   320   CONTINUE
6840         K(I,4)=IMIN-N
6841         DO 330 J=1,4
6842   330   V(IMIN,J)=V(IMIN,J)+P(I,J)
6843   340   CONTINUE
6844         PSJT=0.
6845         DO 360 I=N+1,N+NJET
6846         DO 350 J=1,4
6847   350   P(I,J)=V(I,J)
6848         P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6849   360   PSJT=PSJT+P(I,5)
6850       ENDIF
6851
6852 C...Find two closest jets.
6853       R2MIN=2.*R2ACC
6854       DO 370 ITRY1=N+1,N+NJET-1
6855       DO 370 ITRY2=ITRY1+1,N+NJET
6856       IF(MSTU(46).LE.2) R2=R2T(ITRY1,ITRY2)
6857       IF(MSTU(46).GE.3) R2=R2M(ITRY1,ITRY2)
6858       IF(R2.GE.R2MIN) GOTO 370
6859       IMIN1=ITRY1
6860       IMIN2=ITRY2
6861       R2MIN=R2
6862   370 CONTINUE
6863
6864 C...If allowed, join two closest jets and start over.
6865       IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
6866         IREC=MIN(IMIN1,IMIN2)
6867         IDEL=MAX(IMIN1,IMIN2)
6868         DO 380 J=1,4
6869   380   P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
6870         P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
6871         DO 390 I=IDEL+1,N+NJET
6872         DO 390 J=1,5
6873   390   P(I-1,J)=P(I,J)
6874         IF(MSTU(46).GE.2) THEN
6875           DO 400 I=N+NP+1,N+2*NP
6876           IORI=N+K(I,4)
6877           IF(IORI.EQ.IDEL) K(I,4)=IREC-N
6878   400     IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
6879         ENDIF
6880         NJET=NJET-1
6881         GOTO 290
6882
6883 C...Divide up broad jet if empty cluster in list of final ones.
6884       ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
6885         DO 410 I=N+1,N+NJET
6886   410   K(I,5)=0
6887         DO 420 I=N+NP+1,N+2*NP
6888   420   K(N+K(I,4),5)=K(N+K(I,4),5)+1
6889         IEMP=0
6890         DO 430 I=N+1,N+NJET
6891   430   IF(K(I,5).EQ.0) IEMP=I
6892         IF(IEMP.NE.0) THEN
6893           NLOOP=NLOOP+1
6894           ISPL=0
6895           R2MAX=0.
6896           DO 440 I=N+NP+1,N+2*NP
6897           IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 440
6898           IJET=N+K(I,4)
6899           R2=R2T(I,IJET)
6900           IF(R2.LE.R2MAX) GOTO 440
6901           ISPL=I
6902           R2MAX=R2
6903   440     CONTINUE
6904           IF(ISPL.NE.0) THEN
6905             IJET=N+K(ISPL,4)
6906             DO 450 J=1,4
6907             P(IEMP,J)=P(ISPL,J)
6908   450       P(IJET,J)=P(IJET,J)-P(ISPL,J)
6909             P(IEMP,5)=P(ISPL,5)
6910             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
6911             IF(NLOOP.LE.2) GOTO 290
6912           ENDIF
6913         ENDIF
6914       ENDIF
6915
6916 C...If generalized thrust has not yet converged, continue iteration.
6917       IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
6918      &THEN
6919         TSAV=PSJT/PSS
6920         GOTO 300
6921       ENDIF
6922
6923 C...Reorder jets according to energy.
6924       DO 460 I=N+1,N+NJET
6925       DO 460 J=1,5
6926   460 V(I,J)=P(I,J)
6927       DO 490 INEW=N+1,N+NJET
6928       PEMAX=0.
6929       DO 470 ITRY=N+1,N+NJET
6930       IF(V(ITRY,4).LE.PEMAX) GOTO 470
6931       IMAX=ITRY
6932       PEMAX=V(ITRY,4)
6933   470 CONTINUE
6934       K(INEW,1)=31
6935       K(INEW,2)=97
6936       K(INEW,3)=INEW-N
6937       K(INEW,4)=0
6938       DO 480 J=1,5
6939   480 P(INEW,J)=V(IMAX,J)
6940       V(IMAX,4)=-1.
6941   490 K(IMAX,5)=INEW
6942
6943 C...Clean up particle-jet assignments and jet information.
6944       DO 500 I=N+NP+1,N+2*NP
6945       IORI=K(N+K(I,4),5)
6946       K(I,4)=IORI-N
6947       IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
6948       K(IORI,4)=K(IORI,4)+1
6949   500 CONTINUE
6950       IEMP=0
6951       PSJT=0.
6952       DO 520 I=N+1,N+NJET
6953       K(I,5)=0
6954       PSJT=PSJT+P(I,5)
6955       P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
6956       DO 510 J=1,5
6957   510 V(I,J)=0.
6958   520 IF(K(I,4).EQ.0) IEMP=I
6959
6960 C...Select storing option. Output variables. Check for failure.
6961       MSTU(61)=N+1
6962       MSTU(62)=NP
6963       MSTU(63)=NPRE
6964       PARU(61)=PS(5)
6965       PARU(62)=PSJT/PSS
6966       PARU(63)=SQRT(R2MIN)
6967       IF(NJET.LE.1) PARU(63)=0.
6968       IF(IEMP.NE.0) THEN
6969         CALL LUERRM(8,'(LUCLUS:) failed to reconstruct as requested')
6970         NJET=-1
6971       ENDIF
6972       IF(MSTU(43).LE.1) MSTU(3)=NJET
6973       IF(MSTU(43).GE.2) N=N+NJET
6974       NSAV=NJET
6975
6976       RETURN
6977       END
6978
6979 C*********************************************************************
6980
6981       SUBROUTINE LUCELL(NJET)
6982
6983 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
6984 C...coordinate frame, as used for calorimeters at hadron colliders.
6985       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6986       SAVE /LUJETS/
6987       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6988       SAVE /LUDAT1/
6989       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6990       SAVE /LUDAT2/
6991
6992 C...Loop over all particles. Find cell that was hit by given particle.
6993       NCE2=2*MSTU(51)*MSTU(52)
6994       PTLRAT=1./SINH(PARU(51))**2
6995       NP=0
6996       NC=N
6997       DO 110 I=1,N
6998       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
6999       IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
7000       IF(MSTU(41).GE.2) THEN
7001         KC=LUCOMP(K(I,2))
7002         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7003      &  KC.EQ.18) GOTO 110
7004         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7005      &  GOTO 110
7006       ENDIF
7007       NP=NP+1
7008       PT=SQRT(P(I,1)**2+P(I,2)**2)
7009       ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
7010       IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))
7011       PHI=ULANGL(P(I,1),P(I,2))
7012       IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))
7013       IETPH=MSTU(52)*IETA+IPHI
7014
7015 C...Add to cell already hit, or book new cell.
7016       DO 100 IC=N+1,NC
7017       IF(IETPH.EQ.K(IC,3)) THEN
7018         K(IC,4)=K(IC,4)+1
7019         P(IC,5)=P(IC,5)+PT
7020         GOTO 110
7021       ENDIF
7022   100 CONTINUE
7023       IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
7024         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7025         NJET=-2
7026         RETURN
7027       ENDIF
7028       NC=NC+1
7029       K(NC,3)=IETPH
7030       K(NC,4)=1
7031       K(NC,5)=2
7032       P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
7033       P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
7034       P(NC,5)=PT
7035   110 CONTINUE
7036
7037 C...Smear true bin content by calorimeter resolution.
7038       IF(MSTU(53).GE.1) THEN
7039         DO 130 IC=N+1,NC
7040         PEI=P(IC,5)
7041         IF(MSTU(53).EQ.2) PEI=P(IC,5)/COSH(P(IC,1))
7042   120   PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLU(0)))*PEI)*
7043      &  COS(PARU(2)*RLU(0))
7044         IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120
7045         P(IC,5)=PEF
7046   130   IF(MSTU(53).EQ.2) P(IC,5)=PEF*COSH(P(IC,1))
7047       ENDIF
7048
7049 C...Find initiator cell: the one with highest pT of not yet used ones.
7050       NJ=NC
7051   140 ETMAX=0.
7052       DO 150 IC=N+1,NC
7053       IF(K(IC,5).NE.2) GOTO 150
7054       IF(P(IC,5).LE.ETMAX) GOTO 150
7055       ICMAX=IC
7056       ETA=P(IC,1)
7057       PHI=P(IC,2)
7058       ETMAX=P(IC,5)
7059   150 CONTINUE
7060       IF(ETMAX.LT.PARU(52)) GOTO 210
7061       IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
7062         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7063         NJET=-2
7064         RETURN
7065       ENDIF
7066       K(ICMAX,5)=1
7067       NJ=NJ+1
7068       K(NJ,4)=0
7069       K(NJ,5)=1
7070       P(NJ,1)=ETA
7071       P(NJ,2)=PHI
7072       P(NJ,3)=0.
7073       P(NJ,4)=0.
7074       P(NJ,5)=0.
7075
7076 C...Sum up unused cells within required distance of initiator.
7077       DO 160 IC=N+1,NC
7078       IF(K(IC,5).EQ.0) GOTO 160
7079       IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 160
7080       DPHIA=ABS(P(IC,2)-PHI)
7081       IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 160
7082       PHIC=P(IC,2)
7083       IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
7084       IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 160
7085       K(IC,5)=-K(IC,5)
7086       K(NJ,4)=K(NJ,4)+K(IC,4)
7087       P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
7088       P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
7089       P(NJ,5)=P(NJ,5)+P(IC,5)
7090   160 CONTINUE
7091
7092 C...Reject cluster below minimum ET, else accept.
7093       IF(P(NJ,5).LT.PARU(53)) THEN
7094         NJ=NJ-1
7095         DO 170 IC=N+1,NC
7096   170   IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
7097       ELSEIF(MSTU(54).LE.2) THEN
7098         P(NJ,3)=P(NJ,3)/P(NJ,5)
7099         P(NJ,4)=P(NJ,4)/P(NJ,5)
7100         IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
7101      &  P(NJ,4))
7102         DO 180 IC=N+1,NC
7103   180   IF(K(IC,1).LT.0) K(IC,1)=0
7104       ELSE
7105         DO 190 J=1,4
7106   190   P(NJ,J)=0.
7107         DO 200 IC=N+1,NC
7108         IF(K(IC,5).GE.0) GOTO 200
7109         P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
7110         P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
7111         P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
7112         P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
7113         K(IC,5)=0
7114   200   CONTINUE
7115       ENDIF
7116       GOTO 140
7117
7118 C...Arrange clusters in falling ET sequence.
7119   210 DO 230 I=1,NJ-NC
7120       ETMAX=0.
7121       DO 220 IJ=NC+1,NJ
7122       IF(K(IJ,5).EQ.0) GOTO 220
7123       IF(P(IJ,5).LT.ETMAX) GOTO 220
7124       IJMAX=IJ
7125       ETMAX=P(IJ,5)
7126   220 CONTINUE
7127       K(IJMAX,5)=0
7128       K(N+I,1)=31
7129       K(N+I,2)=98
7130       K(N+I,3)=I
7131       K(N+I,4)=K(IJMAX,4)
7132       K(N+I,5)=0
7133       DO 230 J=1,5
7134       P(N+I,J)=P(IJMAX,J)
7135   230 V(N+I,J)=0.
7136       NJET=NJ-NC
7137
7138 C...Convert to massless or massive four-vectors.
7139       IF(MSTU(54).EQ.2) THEN
7140         DO 240 I=N+1,N+NJET
7141         ETA=P(I,3)
7142         P(I,1)=P(I,5)*COS(P(I,4))
7143         P(I,2)=P(I,5)*SIN(P(I,4))
7144         P(I,3)=P(I,5)*SINH(ETA)
7145         P(I,4)=P(I,5)*COSH(ETA)
7146   240   P(I,5)=0.
7147       ELSEIF(MSTU(54).GE.3) THEN
7148         DO 250 I=N+1,N+NJET
7149   250   P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
7150       ENDIF
7151
7152 C...Information about storage.
7153       MSTU(61)=N+1
7154       MSTU(62)=NP
7155       MSTU(63)=NC-N
7156       IF(MSTU(43).LE.1) MSTU(3)=NJET
7157       IF(MSTU(43).GE.2) N=N+NJET
7158
7159       RETURN
7160       END
7161
7162 C*********************************************************************
7163
7164       SUBROUTINE LUJMAS(PMH,PML)
7165
7166 C...Purpose: to determine, approximately, the two jet masses that
7167 C...minimize the sum m_H|2 + m_L|2, a la Clavelli and Wyler.
7168       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7169       SAVE /LUJETS/
7170       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7171       SAVE /LUDAT1/
7172       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7173       SAVE /LUDAT2/
7174       DIMENSION SM(3,3),SAX(3),PS(3,5)
7175
7176 C...Reset.
7177       NP=0
7178       DO 110 J1=1,3
7179       DO 100 J2=J1,3
7180   100 SM(J1,J2)=0.
7181       DO 110 J2=1,4
7182   110 PS(J1,J2)=0.
7183       PSS=0.
7184
7185 C...Take copy of particles that are to be considered in mass analysis.
7186       DO 150 I=1,N
7187       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
7188       IF(MSTU(41).GE.2) THEN
7189         KC=LUCOMP(K(I,2))
7190         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7191      &  KC.EQ.18) GOTO 150
7192         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7193      &  GOTO 150
7194       ENDIF
7195       IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
7196         CALL LUERRM(11,'(LUJMAS:) no more memory left in LUJETS')
7197         PMH=-2.
7198         PML=-2.
7199         RETURN
7200       ENDIF
7201       NP=NP+1
7202       DO 120 J=1,5
7203   120 P(N+NP,J)=P(I,J)
7204       IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7205       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7206       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7207
7208 C...Fill information in sphericity tensor and total momentum vector.
7209       DO 130 J1=1,3
7210       DO 130 J2=J1,3
7211   130 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
7212       PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7213       DO 140 J=1,4
7214   140 PS(3,J)=PS(3,J)+P(N+NP,J)
7215   150 CONTINUE
7216
7217 C...Very low multiplicities (0 or 1) not considered.
7218       IF(NP.LE.1) THEN
7219         CALL LUERRM(8,'(LUJMAS:) too few particles for analysis')
7220         PMH=-1.
7221         PML=-1.
7222         RETURN
7223       ENDIF
7224       PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
7225
7226 C...Find largest eigenvalue to matrix (third degree equation).
7227       DO 160 J1=1,3
7228       DO 160 J2=J1,3
7229   160 SM(J1,J2)=SM(J1,J2)/PSS
7230       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
7231      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
7232       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
7233      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
7234       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
7235       SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
7236
7237 C...Find largest eigenvector by solving equation system.
7238       DO 170 J1=1,3
7239       SM(J1,J1)=SM(J1,J1)-SMA
7240       DO 170 J2=J1+1,3
7241   170 SM(J2,J1)=SM(J1,J2)
7242       SMAX=0.
7243       DO 180 J1=1,3
7244       DO 180 J2=1,3
7245       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 180
7246       JA=J1
7247       JB=J2
7248       SMAX=ABS(SM(J1,J2))
7249   180 CONTINUE
7250       SMAX=0.
7251       DO 190 J3=JA+1,JA+2
7252       J1=J3-3*((J3-1)/3)
7253       RL=SM(J1,JB)/SM(JA,JB)
7254       DO 190 J2=1,3
7255       SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
7256       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 190
7257       JC=J1
7258       SMAX=ABS(SM(J1,J2))
7259   190 CONTINUE
7260       JB1=JB+1-3*(JB/3)
7261       JB2=JB+2-3*((JB+1)/3)
7262       SAX(JB1)=-SM(JC,JB2)
7263       SAX(JB2)=SM(JC,JB1)
7264       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
7265
7266 C...Divide particles into two initial clusters by hemisphere.
7267       DO 200 I=N+1,N+NP
7268       PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
7269       IS=1
7270       IF(PSAX.LT.0.) IS=2
7271       K(I,3)=IS
7272       DO 200 J=1,4
7273   200 PS(IS,J)=PS(IS,J)+P(I,J)
7274       PMS=(PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
7275      &(PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
7276
7277 C...Reassign one particle at a time; find maximum decrease of m|2 sum.
7278   210 PMD=0.
7279       IM=0
7280       DO 220 J=1,4
7281   220 PS(3,J)=PS(1,J)-PS(2,J)
7282       DO 230 I=N+1,N+NP
7283       PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
7284       IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)
7285       IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)
7286       IF(PMDI.LT.PMD) THEN
7287         PMD=PMDI
7288         IM=I
7289       ENDIF
7290   230 CONTINUE
7291
7292 C...Loop back if significant reduction in sum of m|2.
7293       IF(PMD.LT.-PARU(48)*PMS) THEN
7294         PMS=PMS+PMD
7295         IS=K(IM,3)
7296         DO 240 J=1,4
7297         PS(IS,J)=PS(IS,J)-P(IM,J)
7298   240   PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
7299         K(IM,3)=3-IS
7300         GOTO 210
7301       ENDIF
7302
7303 C...Final masses and output.
7304       MSTU(61)=N+1
7305       MSTU(62)=NP
7306       PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
7307       PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
7308       PMH=MAX(PS(1,5),PS(2,5))
7309       PML=MIN(PS(1,5),PS(2,5))
7310
7311       RETURN
7312       END
7313
7314 C*********************************************************************
7315
7316       SUBROUTINE LUFOWO(H10,H20,H30,H40)
7317
7318 C...Purpose: to calculate the first few Fox-Wolfram moments.
7319       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7320       SAVE /LUJETS/
7321       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7322       SAVE /LUDAT1/
7323       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7324       SAVE /LUDAT2/
7325
7326 C...Copy momenta for particles and calculate H0.
7327       NP=0
7328       H0=0.
7329       HD=0.
7330       DO 110 I=1,N
7331       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7332       IF(MSTU(41).GE.2) THEN
7333         KC=LUCOMP(K(I,2))
7334         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7335      &  KC.EQ.18) GOTO 110
7336         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7337      &  GOTO 110
7338       ENDIF
7339       IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
7340         CALL LUERRM(11,'(LUFOWO:) no more memory left in LUJETS')
7341         H10=-1.
7342         H20=-1.
7343         H30=-1.
7344         H40=-1.
7345         RETURN
7346       ENDIF
7347       NP=NP+1
7348       DO 100 J=1,3
7349   100 P(N+NP,J)=P(I,J)
7350       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7351       H0=H0+P(N+NP,4)
7352       HD=HD+P(N+NP,4)**2
7353   110 CONTINUE
7354       H0=H0**2
7355
7356 C...Very low multiplicities (0 or 1) not considered.
7357       IF(NP.LE.1) THEN
7358         CALL LUERRM(8,'(LUFOWO:) too few particles for analysis')
7359         H10=-1.
7360         H20=-1.
7361         H30=-1.
7362         H40=-1.
7363         RETURN
7364       ENDIF
7365
7366 C...Calculate H1 - H4.
7367       H10=0.
7368       H20=0.
7369       H30=0.
7370       H40=0.
7371       DO 120 I1=N+1,N+NP
7372       DO 120 I2=I1+1,N+NP
7373       CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
7374      &(P(I1,4)*P(I2,4))
7375       H10=H10+P(I1,4)*P(I2,4)*CTHE
7376       H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5)
7377       H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)
7378       H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)
7379   120 CONTINUE
7380
7381 C...Calculate H1/H0 - H4/H0. Output.
7382       MSTU(61)=N+1
7383       MSTU(62)=NP
7384       H10=(HD+2.*H10)/H0
7385       H20=(HD+2.*H20)/H0
7386       H30=(HD+2.*H30)/H0
7387       H40=(HD+2.*H40)/H0
7388
7389       RETURN
7390       END
7391
7392 C*********************************************************************
7393
7394       SUBROUTINE LUTABU(MTABU)
7395
7396 C...Purpose: to evaluate various properties of an event, with
7397 C...statistics accumulated during the course of the run and
7398 C...printed at the end.
7399       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7400       SAVE /LUJETS/
7401       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7402       SAVE /LUDAT1/
7403       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7404       SAVE /LUDAT2/
7405       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
7406       SAVE /LUDAT3/
7407       DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
7408      &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
7409      &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
7410      &KFDM(8),KFDC(200,0:8),NPDC(200)
7411       SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
7412      &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
7413      &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
7414       CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
7415       DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
7416      &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,
7417      &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./,
7418      &NEVDC/0/,NKFDC/0/,NREDC/0/
7419
7420 C...Reset statistics on initial parton state.
7421       IF(MTABU.EQ.10) THEN
7422         NEVIS=0
7423         NKFIS=0
7424
7425 C...Identify and order flavour content of initial state.
7426       ELSEIF(MTABU.EQ.11) THEN
7427         NEVIS=NEVIS+1
7428         KFM1=2*IABS(MSTU(161))
7429         IF(MSTU(161).GT.0) KFM1=KFM1-1
7430         KFM2=2*IABS(MSTU(162))
7431         IF(MSTU(162).GT.0) KFM2=KFM2-1
7432         KFMN=MIN(KFM1,KFM2)
7433         KFMX=MAX(KFM1,KFM2)
7434         DO 100 I=1,NKFIS
7435         IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
7436           IKFIS=-I
7437           GOTO 110
7438         ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
7439      &  KFMX.LT.KFIS(I,2))) THEN
7440           IKFIS=I
7441           GOTO 110
7442         ENDIF
7443   100   CONTINUE
7444         IKFIS=NKFIS+1
7445   110   IF(IKFIS.LT.0) THEN
7446           IKFIS=-IKFIS
7447         ELSE
7448           IF(NKFIS.GE.100) RETURN
7449           DO 120 I=NKFIS,IKFIS,-1
7450           KFIS(I+1,1)=KFIS(I,1)
7451           KFIS(I+1,2)=KFIS(I,2)
7452           DO 120 J=0,10
7453   120     NPIS(I+1,J)=NPIS(I,J)
7454           NKFIS=NKFIS+1
7455           KFIS(IKFIS,1)=KFMN
7456           KFIS(IKFIS,2)=KFMX
7457           DO 130 J=0,10
7458   130     NPIS(IKFIS,J)=0
7459         ENDIF
7460         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
7461
7462 C...Count number of partons in initial state.
7463         NP=0
7464         DO 150 I=1,N
7465         IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
7466         ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
7467         ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
7468      &  THEN
7469         ELSE
7470           IM=I
7471   140     IM=K(IM,3)
7472           IF(IM.LE.0.OR.IM.GT.N) THEN
7473             NP=NP+1
7474           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7475             NP=NP+1
7476           ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
7477           ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)
7478      &    THEN
7479           ELSE
7480             GOTO 140
7481           ENDIF
7482         ENDIF
7483   150   CONTINUE
7484         NPCO=MAX(NP,1)
7485         IF(NP.GE.6) NPCO=6
7486         IF(NP.GE.8) NPCO=7
7487         IF(NP.GE.11) NPCO=8
7488         IF(NP.GE.16) NPCO=9
7489         IF(NP.GE.26) NPCO=10
7490         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
7491         MSTU(62)=NP
7492
7493 C...Write statistics on initial parton state.
7494       ELSEIF(MTABU.EQ.12) THEN
7495         FAC=1./MAX(1,NEVIS)
7496         WRITE(MSTU(11),1000) NEVIS
7497         DO 160 I=1,NKFIS
7498         KFMN=KFIS(I,1)
7499         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7500         KFM1=(KFMN+1)/2
7501         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7502         CALL LUNAME(KFM1,CHAU)
7503         CHIS(1)=CHAU(1:12)
7504         IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
7505         KFMX=KFIS(I,2)
7506         IF(KFIS(I,1).EQ.0) KFMX=0
7507         KFM2=(KFMX+1)/2
7508         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7509         CALL LUNAME(KFM2,CHAU)
7510         CHIS(2)=CHAU(1:12)
7511         IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
7512   160   WRITE(MSTU(11),1100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
7513      &  (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10)
7514
7515 C...Copy statistics on initial parton state into /LUJETS/.
7516       ELSEIF(MTABU.EQ.13) THEN
7517         FAC=1./MAX(1,NEVIS)
7518         DO 170 I=1,NKFIS
7519         KFMN=KFIS(I,1)
7520         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7521         KFM1=(KFMN+1)/2
7522         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7523         KFMX=KFIS(I,2)
7524         IF(KFIS(I,1).EQ.0) KFMX=0
7525         KFM2=(KFMX+1)/2
7526         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7527         K(I,1)=32
7528         K(I,2)=99
7529         K(I,3)=KFM1
7530         K(I,4)=KFM2
7531         K(I,5)=NPIS(I,0)
7532         DO 170 J=1,5
7533         P(I,J)=FAC*NPIS(I,J)
7534   170   V(I,J)=FAC*NPIS(I,J+5)
7535         N=NKFIS
7536         DO 180 J=1,5
7537         K(N+1,J)=0
7538         P(N+1,J)=0.
7539   180   V(N+1,J)=0.
7540         K(N+1,1)=32
7541         K(N+1,2)=99
7542         K(N+1,5)=NEVIS
7543         MSTU(3)=1
7544
7545 C...Reset statistics on number of particles/partons.
7546       ELSEIF(MTABU.EQ.20) THEN
7547         NEVFS=0
7548         NPRFS=0
7549         NFIFS=0
7550         NCHFS=0
7551         NKFFS=0
7552
7553 C...Identify whether particle/parton is primary or not.
7554       ELSEIF(MTABU.EQ.21) THEN
7555         NEVFS=NEVFS+1
7556         MSTU(62)=0
7557         DO 230 I=1,N
7558         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 230
7559         MSTU(62)=MSTU(62)+1
7560         KC=LUCOMP(K(I,2))
7561         MPRI=0
7562         IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
7563           MPRI=1
7564         ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
7565           MPRI=1
7566         ELSEIF(KC.EQ.0) THEN
7567         ELSEIF(K(K(I,3),1).EQ.13) THEN
7568           IM=K(K(I,3),3)
7569           IF(IM.LE.0.OR.IM.GT.N) THEN
7570             MPRI=1
7571           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7572             MPRI=1
7573           ENDIF
7574         ELSEIF(KCHG(KC,2).EQ.0) THEN
7575           KCM=LUCOMP(K(K(I,3),2))
7576           IF(KCM.NE.0) THEN
7577             IF(KCHG(KCM,2).NE.0) MPRI=1
7578           ENDIF
7579         ENDIF
7580         IF(KC.NE.0.AND.MPRI.EQ.1) THEN
7581           IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
7582         ENDIF
7583         IF(K(I,1).LE.10) THEN
7584           NFIFS=NFIFS+1
7585           IF(LUCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
7586         ENDIF
7587
7588 C...Fill statistics on number of particles/partons in event.
7589         KFA=IABS(K(I,2))
7590         KFS=3-ISIGN(1,K(I,2))-MPRI
7591         DO 190 IP=1,NKFFS
7592         IF(KFA.EQ.KFFS(IP)) THEN
7593           IKFFS=-IP
7594           GOTO 200
7595         ELSEIF(KFA.LT.KFFS(IP)) THEN
7596           IKFFS=IP
7597           GOTO 200
7598         ENDIF
7599   190   CONTINUE
7600         IKFFS=NKFFS+1
7601   200   IF(IKFFS.LT.0) THEN
7602           IKFFS=-IKFFS
7603         ELSE
7604           IF(NKFFS.GE.400) RETURN
7605           DO 210 IP=NKFFS,IKFFS,-1
7606           KFFS(IP+1)=KFFS(IP)
7607           DO 210 J=1,4
7608   210     NPFS(IP+1,J)=NPFS(IP,J)
7609           NKFFS=NKFFS+1
7610           KFFS(IKFFS)=KFA
7611           DO 220 J=1,4
7612   220     NPFS(IKFFS,J)=0
7613         ENDIF
7614         NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
7615   230   CONTINUE
7616
7617 C...Write statistics on particle/parton composition of events.
7618       ELSEIF(MTABU.EQ.22) THEN
7619         FAC=1./MAX(1,NEVFS)
7620         WRITE(MSTU(11),1200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
7621         DO 240 I=1,NKFFS
7622         CALL LUNAME(KFFS(I),CHAU)
7623         KC=LUCOMP(KFFS(I))
7624         MDCYF=0
7625         IF(KC.NE.0) MDCYF=MDCY(KC,1)
7626   240   WRITE(MSTU(11),1300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
7627      &  FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
7628
7629 C...Copy particle/parton composition information into /LUJETS/.
7630       ELSEIF(MTABU.EQ.23) THEN
7631         FAC=1./MAX(1,NEVFS)
7632         DO 260 I=1,NKFFS
7633         K(I,1)=32
7634         K(I,2)=99
7635         K(I,3)=KFFS(I)
7636         K(I,4)=0
7637         K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
7638         DO 250 J=1,4
7639         P(I,J)=FAC*NPFS(I,J)
7640   250   V(I,J)=0.
7641         P(I,5)=FAC*K(I,5)
7642   260   V(I,5)=0.
7643         N=NKFFS
7644         DO 270 J=1,5
7645         K(N+1,J)=0
7646         P(N+1,J)=0.
7647   270   V(N+1,J)=0.
7648         K(N+1,1)=32
7649         K(N+1,2)=99
7650         K(N+1,5)=NEVFS
7651         P(N+1,1)=FAC*NPRFS
7652         P(N+1,2)=FAC*NFIFS
7653         P(N+1,3)=FAC*NCHFS
7654         MSTU(3)=1
7655
7656 C...Reset factorial moments statistics.
7657       ELSEIF(MTABU.EQ.30) THEN
7658         NEVFM=0
7659         NMUFM=0
7660         DO 280 IM=1,3
7661         DO 280 IB=1,10
7662         DO 280 IP=1,4
7663         FM1FM(IM,IB,IP)=0.
7664   280   FM2FM(IM,IB,IP)=0.
7665
7666 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
7667       ELSEIF(MTABU.EQ.31) THEN
7668         NEVFM=NEVFM+1
7669         NLOW=N+MSTU(3)
7670         NUPP=NLOW
7671         DO 360 I=1,N
7672         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
7673         IF(MSTU(41).GE.2) THEN
7674           KC=LUCOMP(K(I,2))
7675           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7676      &    KC.EQ.18) GOTO 360
7677           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7678      &    GOTO 360
7679         ENDIF
7680         PMR=0.
7681         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
7682         IF(MSTU(42).GE.2) PMR=P(I,5)
7683         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
7684         YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
7685      &  1E20)),P(I,3))
7686         IF(ABS(YETA).GT.PARU(57)) GOTO 360
7687         PHI=ULANGL(P(I,1),P(I,2))
7688         IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))
7689         IYETA=MAX(0,MIN(511,IYETA))
7690         IPHI=512.*(PHI+PARU(1))/PARU(2)
7691         IPHI=MAX(0,MIN(511,IPHI))
7692         IYEP=0
7693         DO 290 IB=0,9
7694   290   IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
7695
7696 C...Order particles in (pseudo)rapidity and/or azimuth.
7697         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
7698           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
7699           RETURN
7700         ENDIF
7701         NUPP=NUPP+1
7702         IF(NUPP.EQ.NLOW+1) THEN
7703           K(NUPP,1)=IYETA
7704           K(NUPP,2)=IPHI
7705           K(NUPP,3)=IYEP
7706         ELSE
7707           DO 300 I1=NUPP-1,NLOW+1,-1
7708           IF(IYETA.GE.K(I1,1)) GOTO 310
7709   300     K(I1+1,1)=K(I1,1)
7710   310     K(I1+1,1)=IYETA
7711           DO 320 I1=NUPP-1,NLOW+1,-1
7712           IF(IPHI.GE.K(I1,2)) GOTO 330
7713   320     K(I1+1,2)=K(I1,2)
7714   330     K(I1+1,2)=IPHI
7715           DO 340 I1=NUPP-1,NLOW+1,-1
7716           IF(IYEP.GE.K(I1,3)) GOTO 350
7717   340     K(I1+1,3)=K(I1,3)
7718   350     K(I1+1,3)=IYEP
7719         ENDIF
7720   360   CONTINUE
7721         K(NUPP+1,1)=2**10
7722         K(NUPP+1,2)=2**10
7723         K(NUPP+1,3)=4**10
7724
7725 C...Calculate sum of factorial moments in event.
7726         DO 400 IM=1,3
7727         DO 370 IB=1,10
7728         DO 370 IP=1,4
7729   370   FEVFM(IB,IP)=0.
7730         DO 380 IB=1,10
7731         IF(IM.LE.2) IBIN=2**(10-IB)
7732         IF(IM.EQ.3) IBIN=4**(10-IB)
7733         IAGR=K(NLOW+1,IM)/IBIN
7734         NAGR=1
7735         DO 380 I=NLOW+2,NUPP+1
7736         ICUT=K(I,IM)/IBIN
7737         IF(ICUT.EQ.IAGR) THEN
7738           NAGR=NAGR+1
7739         ELSE
7740           IF(NAGR.EQ.1) THEN
7741           ELSEIF(NAGR.EQ.2) THEN
7742             FEVFM(IB,1)=FEVFM(IB,1)+2.
7743           ELSEIF(NAGR.EQ.3) THEN
7744             FEVFM(IB,1)=FEVFM(IB,1)+6.
7745             FEVFM(IB,2)=FEVFM(IB,2)+6.
7746           ELSEIF(NAGR.EQ.4) THEN
7747             FEVFM(IB,1)=FEVFM(IB,1)+12.
7748             FEVFM(IB,2)=FEVFM(IB,2)+24.
7749             FEVFM(IB,3)=FEVFM(IB,3)+24.
7750           ELSE
7751             FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)
7752             FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)
7753             FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)
7754             FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)*
7755      &      (NAGR-4.)
7756           ENDIF
7757           IAGR=ICUT
7758           NAGR=1
7759         ENDIF
7760   380   CONTINUE
7761
7762 C...Add results to total statistics.
7763         DO 390 IB=10,1,-1
7764         DO 390 IP=1,4
7765         IF(FEVFM(1,IP).LT.0.5) THEN
7766           FEVFM(IB,IP)=0.
7767         ELSEIF(IM.LE.2) THEN
7768           FEVFM(IB,IP)=2**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
7769         ELSE
7770           FEVFM(IB,IP)=4**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
7771         ENDIF
7772         FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
7773   390   FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
7774   400   CONTINUE
7775         NMUFM=NMUFM+(NUPP-NLOW)
7776         MSTU(62)=NUPP-NLOW
7777
7778 C...Write accumulated statistics on factorial moments.
7779       ELSEIF(MTABU.EQ.32) THEN
7780         FAC=1./MAX(1,NEVFM)
7781         IF(MSTU(42).LE.0) WRITE(MSTU(11),1400) NEVFM,'eta'
7782         IF(MSTU(42).EQ.1) WRITE(MSTU(11),1400) NEVFM,'ypi'
7783         IF(MSTU(42).GE.2) WRITE(MSTU(11),1400) NEVFM,'y  '
7784         DO 420 IM=1,3
7785         WRITE(MSTU(11),1500)
7786         DO 420 IB=1,10
7787         BYETA=2.*PARU(57)
7788         IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
7789         BPHI=PARU(2)
7790         IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
7791         IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))
7792         IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))
7793         DO 410 IP=1,4
7794         FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
7795   410   FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
7796   420   WRITE(MSTU(11),1600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
7797      &  IP=1,4)
7798
7799 C...Copy statistics on factorial moments into /LUJETS/.
7800       ELSEIF(MTABU.EQ.33) THEN
7801         FAC=1./MAX(1,NEVFM)
7802         DO 430 IM=1,3
7803         DO 430 IB=1,10
7804         I=10*(IM-1)+IB
7805         K(I,1)=32
7806         K(I,2)=99
7807         K(I,3)=1
7808         IF(IM.NE.2) K(I,3)=2**(IB-1)
7809         K(I,4)=1
7810         IF(IM.NE.1) K(I,4)=2**(IB-1)
7811         K(I,5)=0
7812         P(I,1)=2.*PARU(57)/K(I,3)
7813         V(I,1)=PARU(2)/K(I,4)
7814         DO 430 IP=1,4
7815         P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
7816   430   V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))
7817         N=30
7818         DO 440 J=1,5
7819         K(N+1,J)=0
7820         P(N+1,J)=0.
7821   440   V(N+1,J)=0.
7822         K(N+1,1)=32
7823         K(N+1,2)=99
7824         K(N+1,5)=NEVFM
7825         MSTU(3)=1
7826
7827 C...Reset statistics on Energy-Energy Correlation.
7828       ELSEIF(MTABU.EQ.40) THEN
7829         NEVEE=0
7830         DO 450 J=1,25
7831         FE1EC(J)=0.
7832         FE2EC(J)=0.
7833         FE1EC(51-J)=0.
7834         FE2EC(51-J)=0.
7835         FE1EA(J)=0.
7836   450   FE2EA(J)=0.
7837
7838 C...Find particles to include, with proper assumed mass.
7839       ELSEIF(MTABU.EQ.41) THEN
7840         NEVEE=NEVEE+1
7841         NLOW=N+MSTU(3)
7842         NUPP=NLOW
7843         ECM=0.
7844         DO 460 I=1,N
7845         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 460
7846         IF(MSTU(41).GE.2) THEN
7847           KC=LUCOMP(K(I,2))
7848           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7849      &    KC.EQ.18) GOTO 460
7850           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7851      &    GOTO 460
7852         ENDIF
7853         PMR=0.
7854         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
7855         IF(MSTU(42).GE.2) PMR=P(I,5)
7856         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
7857           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
7858           RETURN
7859         ENDIF
7860         NUPP=NUPP+1
7861         P(NUPP,1)=P(I,1)
7862         P(NUPP,2)=P(I,2)
7863         P(NUPP,3)=P(I,3)
7864         P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7865         P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
7866         ECM=ECM+P(NUPP,4)
7867   460   CONTINUE
7868         IF(NUPP.EQ.NLOW) RETURN
7869
7870 C...Analyze Energy-Energy Correlation in event.
7871         FAC=(2./ECM**2)*50./PARU(1)
7872         DO 470 J=1,50
7873   470   FEVEE(J)=0.
7874         DO 480 I1=NLOW+2,NUPP
7875         DO 480 I2=NLOW+1,I1-1
7876         CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
7877      &  (P(I1,5)*P(I2,5))
7878         THE=ACOS(MAX(-1.,MIN(1.,CTHE)))
7879         ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))
7880   480   FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
7881         DO 490 J=1,25
7882         FE1EC(J)=FE1EC(J)+FEVEE(J)
7883         FE2EC(J)=FE2EC(J)+FEVEE(J)**2
7884         FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
7885         FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
7886         FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
7887   490   FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
7888         MSTU(62)=NUPP-NLOW
7889
7890 C...Write statistics on Energy-Energy Correlation.
7891       ELSEIF(MTABU.EQ.42) THEN
7892         FAC=1./MAX(1,NEVEE)
7893         WRITE(MSTU(11),1700) NEVEE
7894         DO 500 J=1,25
7895         FEEC1=FAC*FE1EC(J)
7896         FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2)))
7897         FEEC2=FAC*FE1EC(51-J)
7898         FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
7899         FEECA=FAC*FE1EA(J)
7900         FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2)))
7901   500   WRITE(MSTU(11),1800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,
7902      &  FEECA,FEESA
7903
7904 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
7905       ELSEIF(MTABU.EQ.43) THEN
7906         FAC=1./MAX(1,NEVEE)
7907         DO 510 I=1,25
7908         K(I,1)=32
7909         K(I,2)=99
7910         K(I,3)=0
7911         K(I,4)=0
7912         K(I,5)=0
7913         P(I,1)=FAC*FE1EC(I)
7914         V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
7915         P(I,2)=FAC*FE1EC(51-I)
7916         V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
7917         P(I,3)=FAC*FE1EA(I)
7918         V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
7919         P(I,4)=PARU(1)*(I-1)/50.
7920         P(I,5)=PARU(1)*I/50.
7921         V(I,4)=3.6*(I-1)
7922   510   V(I,5)=3.6*I
7923         N=25
7924         DO 520 J=1,5
7925         K(N+1,J)=0
7926         P(N+1,J)=0.
7927   520   V(N+1,J)=0.
7928         K(N+1,1)=32
7929         K(N+1,2)=99
7930         K(N+1,5)=NEVEE
7931         MSTU(3)=1
7932
7933 C...Reset statistics on decay channels.
7934       ELSEIF(MTABU.EQ.50) THEN
7935         NEVDC=0
7936         NKFDC=0
7937         NREDC=0
7938
7939 C...Identify and order flavour content of final state.
7940       ELSEIF(MTABU.EQ.51) THEN
7941         NEVDC=NEVDC+1
7942         NDS=0
7943         DO 550 I=1,N
7944         IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 550
7945         NDS=NDS+1
7946         IF(NDS.GT.8) THEN
7947           NREDC=NREDC+1
7948           RETURN
7949         ENDIF
7950         KFM=2*IABS(K(I,2))
7951         IF(K(I,2).LT.0) KFM=KFM-1
7952         DO 530 IDS=NDS-1,1,-1
7953         IIN=IDS+1
7954         IF(KFM.LT.KFDM(IDS)) GOTO 540
7955   530   KFDM(IDS+1)=KFDM(IDS)
7956         IIN=1
7957   540   KFDM(IIN)=KFM
7958   550   CONTINUE
7959
7960 C...Find whether old or new final state.
7961         DO 570 IDC=1,NKFDC
7962         IF(NDS.LT.KFDC(IDC,0)) THEN
7963           IKFDC=IDC
7964           GOTO 580
7965         ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
7966           DO 560 I=1,NDS
7967           IF(KFDM(I).LT.KFDC(IDC,I)) THEN
7968             IKFDC=IDC
7969             GOTO 580
7970           ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
7971             GOTO 570
7972           ENDIF
7973   560     CONTINUE
7974           IKFDC=-IDC
7975           GOTO 580
7976         ENDIF
7977   570   CONTINUE
7978         IKFDC=NKFDC+1
7979   580   IF(IKFDC.LT.0) THEN
7980           IKFDC=-IKFDC
7981         ELSEIF(NKFDC.GE.200) THEN
7982           NREDC=NREDC+1
7983           RETURN
7984         ELSE
7985           DO 590 IDC=NKFDC,IKFDC,-1
7986           NPDC(IDC+1)=NPDC(IDC)
7987           DO 590 I=0,8
7988   590     KFDC(IDC+1,I)=KFDC(IDC,I)
7989           NKFDC=NKFDC+1
7990           KFDC(IKFDC,0)=NDS
7991           DO 600 I=1,NDS
7992   600     KFDC(IKFDC,I)=KFDM(I)
7993           NPDC(IKFDC)=0
7994         ENDIF
7995         NPDC(IKFDC)=NPDC(IKFDC)+1
7996
7997 C...Write statistics on decay channels.
7998       ELSEIF(MTABU.EQ.52) THEN
7999         FAC=1./MAX(1,NEVDC)
8000         WRITE(MSTU(11),1900) NEVDC
8001         DO 620 IDC=1,NKFDC
8002         DO 610 I=1,KFDC(IDC,0)
8003         KFM=KFDC(IDC,I)
8004         KF=(KFM+1)/2
8005         IF(2*KF.NE.KFM) KF=-KF
8006         CALL LUNAME(KF,CHAU)
8007         CHDC(I)=CHAU(1:12)
8008   610   IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
8009   620   WRITE(MSTU(11),2000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
8010         IF(NREDC.NE.0) WRITE(MSTU(11),2100) FAC*NREDC
8011
8012 C...Copy statistics on decay channels into /LUJETS/.
8013       ELSEIF(MTABU.EQ.53) THEN
8014         FAC=1./MAX(1,NEVDC)
8015         DO 650 IDC=1,NKFDC
8016         K(IDC,1)=32
8017         K(IDC,2)=99
8018         K(IDC,3)=0
8019         K(IDC,4)=0
8020         K(IDC,5)=KFDC(IDC,0)
8021         DO 630 J=1,5
8022         P(IDC,J)=0.
8023   630   V(IDC,J)=0.
8024         DO 640 I=1,KFDC(IDC,0)
8025         KFM=KFDC(IDC,I)
8026         KF=(KFM+1)/2
8027         IF(2*KF.NE.KFM) KF=-KF
8028         IF(I.LE.5) P(IDC,I)=KF
8029   640   IF(I.GE.6) V(IDC,I-5)=KF
8030   650   V(IDC,5)=FAC*NPDC(IDC)
8031         N=NKFDC
8032         DO 660 J=1,5
8033         K(N+1,J)=0
8034         P(N+1,J)=0.
8035   660   V(N+1,J)=0.
8036         K(N+1,1)=32
8037         K(N+1,2)=99
8038         K(N+1,5)=NEVDC
8039         V(N+1,5)=FAC*NREDC
8040         MSTU(3)=1
8041       ENDIF
8042
8043 C...Format statements for output on unit MSTU(11) (default 6).
8044  1000 FORMAT(///20X,'Event statistics - initial state'/
8045      &20X,'based on an analysis of ',I6,' events'//
8046      &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
8047      &'according to fragmenting system multiplicity'/
8048      &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
8049      &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
8050  1100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
8051  1200 FORMAT(///20X,'Event statistics - final state'/
8052      &20X,'based on an analysis of ',I6,' events'//
8053      &5X,'Mean primary multiplicity =',F8.3/
8054      &5X,'Mean final   multiplicity =',F8.3/
8055      &5X,'Mean charged multiplicity =',F8.3//
8056      &5X,'Number of particles produced per event (directly and via ',
8057      &'decays/branchings)'/
8058      &5X,'KF    Particle/jet  MDCY',8X,'Particles',9X,'Antiparticles',
8059      &5X,'Total'/34X,'prim      seco      prim      seco'/)
8060  1300 FORMAT(1X,I6,4X,A16,I2,5(1X,F9.4))
8061  1400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
8062      &20X,'based on an analysis of ',I6,' events'//
8063      &3X,'delta-',A3,' delta-phi     <n>/bin',10X,'<F2>',18X,'<F3>',
8064      &18X,'<F4>',18X,'<F5>'/35X,4('     value     error  '))
8065  1500 FORMAT(10X)
8066  1600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
8067  1700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
8068      &20X,'based on an analysis of ',I6,' events'//
8069      &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
8070      &'EECA(theta)'/2X,'in degrees ',3('      value    error')/)
8071  1800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
8072  1900 FORMAT(///20X,'Decay channel analysis - final state'/
8073      &20X,'based on an analysis of ',I6,' events'//
8074      &2X,'Probability',10X,'Complete final state'/)
8075  2000 FORMAT(2X,F9.5,5X,8(A12,1X))
8076  2100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
8077      &'or table overflow)')
8078
8079       RETURN
8080       END
8081
8082 C*********************************************************************
8083
8084       SUBROUTINE LUEEVT(KFL,ECM)
8085
8086 C...Purpose: to handle the generation of an e+e- annihilation jet event.
8087       IMPLICIT DOUBLE PRECISION(D)
8088       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
8089       SAVE /LUJETS/
8090       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8091       SAVE /LUDAT1/
8092       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8093       SAVE /LUDAT2/
8094
8095 C...Check input parameters.
8096       IF(MSTU(12).GE.1) CALL LULIST(0)
8097       IF(KFL.LT.0.OR.KFL.GT.8) THEN
8098         CALL LUERRM(16,'(LUEEVT:) called with unknown flavour code')
8099         IF(MSTU(21).GE.1) RETURN
8100       ENDIF
8101       IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))
8102       IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)
8103       IF(ECM.LT.ECMMIN) THEN
8104         CALL LUERRM(16,'(LUEEVT:) called with too small CM energy')
8105         IF(MSTU(21).GE.1) RETURN
8106       ENDIF
8107
8108 C...Check consistency of MSTJ options set.
8109       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
8110         CALL LUERRM(6,
8111      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
8112         MSTJ(110)=1
8113       ENDIF
8114       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
8115         CALL LUERRM(6,
8116      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
8117         MSTJ(111)=0
8118       ENDIF
8119
8120 C...Initialize alpha_strong and total cross-section.
8121       MSTU(111)=MSTJ(108)
8122       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
8123      &MSTU(111)=1
8124       PARU(112)=PARJ(121)
8125       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
8126       IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
8127      &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LUXTOT(KFL,ECM,
8128      &XTOT)
8129       IF(MSTJ(116).GE.3) MSTJ(116)=1
8130
8131 C...Add initial e+e- to event record (documentation only).
8132       NTRY=0
8133   100 NTRY=NTRY+1
8134       IF(NTRY.GT.100) THEN
8135         CALL LUERRM(14,'(LUEEVT:) caught in an infinite loop')
8136         RETURN
8137       ENDIF
8138       NC=0
8139       IF(MSTJ(115).GE.2) THEN
8140         NC=NC+2
8141         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
8142         K(NC-1,1)=21
8143         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
8144         K(NC,1)=21
8145       ENDIF
8146
8147 C...Radiative photon (in initial state).
8148       MK=0
8149       ECMC=ECM
8150       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LURADK(ECM,MK,PAK,
8151      &THEK,PHIK,ALPK)
8152       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
8153       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
8154         NC=NC+1
8155         CALL LU1ENT(NC,22,PAK,THEK,PHIK)
8156         K(NC,3)=MIN(MSTJ(115)/2,1)
8157       ENDIF
8158
8159 C...Virtual exchange boson (gamma or Z0).
8160       IF(MSTJ(115).GE.3) THEN
8161         NC=NC+1
8162         KF=22
8163         IF(MSTJ(102).EQ.2) KF=23
8164         MSTU10=MSTU(10)
8165         MSTU(10)=1
8166         P(NC,5)=ECMC
8167         CALL LU1ENT(NC,KF,ECMC,0.,0.)
8168         K(NC,1)=21
8169         K(NC,3)=1
8170         MSTU(10)=MSTU10
8171       ENDIF
8172
8173 C...Choice of flavour and jet configuration.
8174       CALL LUXKFL(KFL,ECM,ECMC,KFLC)
8175       IF(KFLC.EQ.0) GOTO 100
8176       CALL LUXJET(ECMC,NJET,CUT)
8177       KFLN=21
8178       IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
8179      &X12,X14)
8180       IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
8181       IF(NJET.EQ.2) MSTJ(120)=1
8182
8183 C...Fill jet configuration and origin.
8184       IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LU2ENT(NC+1,KFLC,-KFLC,ECMC)
8185       IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LU2ENT(-(NC+1),KFLC,-KFLC,
8186      &ECMC)
8187       IF(NJET.EQ.3) CALL LU3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
8188       IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LU4ENT(NC+1,KFLC,KFLN,KFLN,
8189      &-KFLC,ECMC,X1,X2,X4,X12,X14)
8190       IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LU4ENT(NC+1,KFLC,-KFLN,KFLN,
8191      &-KFLC,ECMC,X1,X2,X4,X12,X14)
8192       DO 110 IP=NC+1,N
8193   110 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
8194
8195 C...Angular orientation according to matrix element.
8196       IF(MSTJ(106).EQ.1) THEN
8197         CALL LUXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
8198         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
8199         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
8200       ENDIF
8201
8202 C...Rotation and boost from radiative photon.
8203       IF(MK.EQ.1) THEN
8204         DBEK=-PAK/(ECM-PAK)
8205         NMIN=NC+1-MSTJ(115)/3
8206         CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)
8207         CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
8208         CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0)
8209       ENDIF
8210
8211 C...Generate parton shower. Rearrange along strings and check.
8212       IF(MSTJ(101).EQ.5) THEN
8213         CALL LUSHOW(N-1,N,ECMC)
8214         MSTJ14=MSTJ(14)
8215         IF(MSTJ(105).EQ.-1) MSTJ(14)=0
8216         IF(MSTJ(105).GE.0) MSTU(28)=0
8217         CALL LUPREP(0)
8218         MSTJ(14)=MSTJ14
8219         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
8220       ENDIF
8221
8222 C...Fragmentation/decay generation. Information for LUTABU.
8223       IF(MSTJ(105).EQ.1) CALL LUEXEC
8224       MSTU(161)=KFLC
8225       MSTU(162)=-KFLC
8226
8227       RETURN
8228       END
8229
8230 C*********************************************************************
8231
8232       SUBROUTINE LUXTOT(KFL,ECM,XTOT)
8233
8234 C...Purpose: to calculate total cross-section, including initial
8235 C...state radiation effects.
8236       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8237       SAVE /LUDAT1/
8238       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8239       SAVE /LUDAT2/
8240
8241 C...Status, (optimized) Q^2 scale, alpha_strong.
8242       PARJ(151)=ECM
8243       MSTJ(119)=10*MSTJ(102)+KFL
8244       IF(MSTJ(111).EQ.0) THEN
8245         Q2R=ECM**2
8246       ELSEIF(MSTU(111).EQ.0) THEN
8247         PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8248      &  ((33.-2.*MSTU(112))*PARU(111)))))
8249         Q2R=PARJ(168)*ECM**2
8250       ELSE
8251         PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8252      &  (2.*PARU(112)/ECM)**2))
8253         Q2R=PARJ(168)*ECM**2
8254       ENDIF
8255       ALSPI=ULALPS(Q2R)/PARU(1)
8256
8257 C...QCD corrections factor in R.
8258       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
8259         RQCD=1.
8260       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
8261         RQCD=1.+ALSPI
8262       ELSEIF(MSTJ(109).EQ.0) THEN
8263         RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8264         IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8265      &  LOG(PARJ(168))*ALSPI**2)
8266       ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
8267         RQCD=1.+(3./4.)*ALSPI
8268       ELSE
8269         RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
8270       ENDIF
8271
8272 C...Calculate Z0 width if default value not acceptable.
8273       IF(MSTJ(102).GE.3) THEN
8274         RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/
8275      &  3.)**2+(4.*PARU(102)/3.-1.)**2)
8276         DO 100 KFLC=5,6
8277         VQ=1.
8278         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*ULMASS(KFLC)/
8279      &  ECM)**2))
8280         IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1.
8281         IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3.
8282   100   RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3)
8283         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
8284       ENDIF
8285
8286 C...Calculate propagator and related constants for QFD case.
8287       POLL=1.-PARJ(131)*PARJ(132)
8288       IF(MSTJ(102).GE.2) THEN
8289         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8290         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8291         SFI=SFW*(1.-(PARJ(123)/ECM)**2)
8292         VE=4.*PARU(102)-1.
8293         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
8294         SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8295         HF1I=SFI*SF1I
8296         HF1W=SFW*SF1W
8297       ENDIF
8298
8299 C...Loop over different flavours: charge, velocity.
8300       RTOT=0.
8301       RQQ=0.
8302       RQV=0.
8303       RVA=0.
8304       DO 110 KFLC=1,MAX(MSTJ(104),KFL)
8305       IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
8306       MSTJ(93)=1
8307       PMQ=ULMASS(KFLC)
8308       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
8309       QF=KCHG(KFLC,1)/3.
8310       VQ=1.
8311       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
8312
8313 C...Calculate R and sum of charges for QED or QFD case.
8314       RQQ=RQQ+3.*QF**2*POLL
8315       IF(MSTJ(102).LE.1) THEN
8316         RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL
8317       ELSE
8318         VF=SIGN(1.,QF)-4.*QF*PARU(102)
8319         RQV=RQV-6.*QF*VF*SF1I
8320         RVA=RVA+3.*(VF**2+1.)*SF1W
8321         RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+
8322      &  VF**2*HF1W)+VQ**3*HF1W)
8323       ENDIF
8324   110 CONTINUE
8325       RSUM=RQQ
8326       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
8327
8328 C...Calculate cross-section, including QCD corrections.
8329       PARJ(141)=RQQ
8330       PARJ(142)=RTOT
8331       PARJ(143)=RTOT*RQCD
8332       PARJ(144)=PARJ(143)
8333       PARJ(145)=PARJ(141)*86.8/ECM**2
8334       PARJ(146)=PARJ(142)*86.8/ECM**2
8335       PARJ(147)=PARJ(143)*86.8/ECM**2
8336       PARJ(148)=PARJ(147)
8337       PARJ(157)=RSUM*RQCD
8338       PARJ(158)=0.
8339       PARJ(159)=0.
8340       XTOT=PARJ(147)
8341       IF(MSTJ(107).LE.0) RETURN
8342
8343 C...Virtual cross-section.
8344       XKL=PARJ(135)
8345       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8346       ALE=2.*LOG(ECM/ULMASS(11))-1.
8347       SIGV=ALE/3.+2.*LOG(ECM**2/(ULMASS(13)*ULMASS(15)))/3.-4./3.+
8348      &1.526*LOG(ECM**2/0.932)
8349
8350 C...Soft and hard radiative cross-section in QED case.
8351       IF(MSTJ(102).LE.1) THEN
8352         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV
8353         SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)
8354         SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL))
8355
8356 C...Soft and hard radiative cross-section in QFD case.
8357       ELSE
8358         SZM=1.-(PARJ(123)/ECM)**2
8359         SZW=PARJ(123)*PARJ(124)/ECM**2
8360         PARJ(161)=-RQQ/RSUM
8361         PARJ(162)=-(RQQ+RQV+RVA)/RSUM
8362         PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM
8363         PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM-
8364      &  SZM**2))/(SZW*RSUM)
8365         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+
8366      &  (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.
8367         SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+
8368      &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
8369      &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
8370         SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+
8371      &  PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/
8372      &  ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-
8373      &  ATAN((XKL-SZM)/SZW)))
8374       ENDIF
8375
8376 C...Total cross-section and fraction of hard photon events.
8377       PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
8378       PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
8379       PARJ(144)=PARJ(157)
8380       PARJ(148)=PARJ(144)*86.8/ECM**2
8381       XTOT=PARJ(148)
8382
8383       RETURN
8384       END
8385
8386 C*********************************************************************
8387
8388       SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK)
8389
8390 C...Purpose: to generate initial state photon radiation.
8391       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8392       SAVE /LUDAT1/
8393
8394 C...Function: cumulative hard photon spectrum in QFD case.
8395       FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+
8396      &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
8397
8398 C...Determine whether radiative photon or not.
8399       MK=0
8400       PAK=0.
8401       IF(PARJ(160).LT.RLU(0)) RETURN
8402       MK=1
8403
8404 C...Photon energy range. Find photon momentum in QED case.
8405       XKL=PARJ(135)
8406       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8407       IF(MSTJ(102).LE.1) THEN
8408   100   XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLU(0))
8409         IF(1.+(1.-XK)**2.LT.2.*RLU(0)) GOTO 100
8410
8411 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
8412       ELSE
8413         SZM=1.-(PARJ(123)/ECM)**2
8414         SZW=PARJ(123)*PARJ(124)/ECM**2
8415         FXKL=FXK(XKL)
8416         FXKU=FXK(XKU)
8417         FXKD=1E-4*(FXKU-FXKL)
8418         FXKR=FXKL+RLU(0)*(FXKU-FXKL)
8419         NXK=0
8420   110   NXK=NXK+1
8421         XK=0.5*(XKL+XKU)
8422         FXKV=FXK(XK)
8423         IF(FXKV.GT.FXKR) THEN
8424           XKU=XK
8425           FXKU=FXKV
8426         ELSE
8427           XKL=XK
8428           FXKL=FXKV
8429         ENDIF
8430         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
8431         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
8432       ENDIF
8433       PAK=0.5*ECM*XK
8434
8435 C...Photon polar and azimuthal angle.
8436       PME=2.*(ULMASS(11)/ECM)**2
8437   120 CTHM=PME*(2./PME)**RLU(0)
8438       IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,
8439      &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLU(0)) GOTO 120
8440       CTHE=1.-CTHM
8441       IF(RLU(0).GT.0.5) CTHE=-CTHE
8442       STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
8443       THEK=ULANGL(CTHE,STHE)
8444       PHIK=PARU(2)*RLU(0)
8445
8446 C...Rotation angle for hadronic system.
8447       SGN=1.
8448       IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
8449      &RLU(0)) SGN=-1.
8450       ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
8451      &(2.-XK*(1.-SGN*CTHE)))
8452
8453       RETURN
8454       END
8455
8456 C*********************************************************************
8457
8458       SUBROUTINE LUXKFL(KFL,ECM,ECMC,KFLC)
8459
8460 C...Purpose: to select flavour for produced qqbar pair.
8461       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8462       SAVE /LUDAT1/
8463       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8464       SAVE /LUDAT2/
8465
8466 C...Calculate maximum weight in QED or QFD case.
8467       IF(MSTJ(102).LE.1) THEN
8468         RFMAX=4./9.
8469       ELSE
8470         POLL=1.-PARJ(131)*PARJ(132)
8471         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8472         SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8473         SFI=SFW*(1.-(PARJ(123)/ECMC)**2)
8474         VE=4.*PARU(102)-1.
8475         HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
8476         HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8477         RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+
8478      &  ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.*
8479      &  (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)
8480       ENDIF
8481
8482 C...Choose flavour. Gives charge and velocity.
8483       NTRY=0
8484   100 NTRY=NTRY+1
8485       IF(NTRY.GT.100) THEN
8486         CALL LUERRM(14,'(LUXKFL:) caught in an infinite loop')
8487         KFLC=0
8488         RETURN
8489       ENDIF
8490       KFLC=KFL
8491       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLU(0))
8492       MSTJ(93)=1
8493       PMQ=ULMASS(KFLC)
8494       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
8495       QF=KCHG(KFLC,1)/3.
8496       VQ=1.
8497       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
8498
8499 C...Calculate weight in QED or QFD case.
8500       IF(MSTJ(102).LE.1) THEN
8501         RF=QF**2
8502         RFV=0.5*VQ*(3.-VQ**2)*QF**2
8503       ELSE
8504         VF=SIGN(1.,QF)-4.*QF*PARU(102)
8505         RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W
8506         RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+
8507      &  VQ**3*HF1W
8508       ENDIF
8509
8510 C...Weighting or new event (radiative photon). Cross-section update.
8511       IF(KFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100
8512       PARJ(158)=PARJ(158)+1.
8513       IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLU(0)*RF) KFLC=0
8514       IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
8515       IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.
8516       PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
8517       PARJ(148)=PARJ(144)*86.8/ECM**2
8518
8519       RETURN
8520       END
8521
8522 C*********************************************************************
8523
8524       SUBROUTINE LUXJET(ECM,NJET,CUT)
8525
8526 C...Purpose: to select number of jets in matrix element approach.
8527       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8528       SAVE /LUDAT1/
8529       DIMENSION ZHUT(5)
8530
8531 C...Relative three-jet rate in Zhu second order parametrization.
8532       DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
8533
8534 C...Trivial result for two-jets only, including parton shower.
8535       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
8536         CUT=0.
8537
8538 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
8539       ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
8540         CF=4./3.
8541         IF(MSTJ(109).EQ.2) CF=1.
8542         IF(MSTJ(111).EQ.0) THEN
8543           Q2=ECM**2
8544           Q2R=ECM**2
8545         ELSEIF(MSTU(111).EQ.0) THEN
8546           PARJ(169)=MIN(1.,PARJ(129))
8547           Q2=PARJ(169)*ECM**2
8548           PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8549      &    ((33.-2.*MSTU(112))*PARU(111)))))
8550           Q2R=PARJ(168)*ECM**2
8551         ELSE
8552           PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))
8553           Q2=PARJ(169)*ECM**2
8554           PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8555      &    (2.*PARU(112)/ECM)**2))
8556           Q2R=PARJ(168)*ECM**2
8557         ENDIF
8558
8559 C...alpha_strong for R and R itself.
8560         ALSPI=(3./4.)*CF*ULALPS(Q2R)/PARU(1)
8561         IF(IABS(MSTJ(101)).EQ.1) THEN
8562           RQCD=1.+ALSPI
8563         ELSEIF(MSTJ(109).EQ.0) THEN
8564           RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8565           IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8566      &    LOG(PARJ(168))*ALSPI**2)
8567         ELSE
8568           RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
8569         ENDIF
8570
8571 C...alpha_strong for jet rate. Initial value for y cut.
8572         ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8573         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2)
8574         IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
8575      &  CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)
8576         IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8577
8578 C...Parametrization of first order three-jet cross-section.
8579   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
8580           PARJ(152)=0.
8581         ELSE
8582           PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))*
8583      &    LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+
8584      &    5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+
8585      &    1.342*(1.-3.*CUT)**4)/RQCD
8586           IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
8587      &    PARJ(152)=0.
8588         ENDIF
8589
8590 C...Parametrization of second order three-jet cross-section.
8591         IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
8592      &  CUT.GE.0.25) THEN
8593           PARJ(153)=0.
8594         ELSEIF(MSTJ(110).LE.1) THEN
8595           CT=LOG(1./CUT-2.)
8596           PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-
8597      &    0.2661*CT**3+0.01159*CT**4)/RQCD
8598
8599 C...Interpolation in second/first order ratio for Zhu parametrization.
8600         ELSEIF(MSTJ(110).EQ.2) THEN
8601           IZA=0
8602           DO 110 IY=1,5
8603   110     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
8604           IF(IZA.NE.0) THEN
8605             ZHURAT=ZHUT(IZA)
8606           ELSE
8607             IZ=100.*CUT
8608             ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
8609           ENDIF
8610           PARJ(153)=ALSPI*PARJ(152)*ZHURAT
8611         ENDIF
8612
8613 C...Shift in second order three-jet cross-section with optimized Q^2.
8614         IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.
8615      &  AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*
8616      &  LOG(PARJ(169))*ALSPI*PARJ(152)
8617
8618 C...Parametrization of second order four-jet cross-section.
8619         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
8620           PARJ(154)=0.
8621         ELSE
8622           CT=LOG(1./CUT-5.)
8623           IF(CUT.LE.0.018) THEN
8624             XQQGG=6.349-4.330*CT+0.8304*CT**2
8625             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+
8626      &      0.4059*CT**2)
8627             XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
8628             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8629           ELSE
8630             XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3
8631             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-
8632      &      0.1326*CT**2+0.04365*CT**3)
8633             XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*
8634      &      CT**3)
8635             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8636           ENDIF
8637           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
8638           PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
8639         ENDIF
8640
8641 C...If negative three-jet rate, change y' optimization parameter.
8642         IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.
8643      &  PARJ(169).LT.0.99) THEN
8644           PARJ(169)=MIN(1.,1.2*PARJ(169))
8645           Q2=PARJ(169)*ECM**2
8646           ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8647           GOTO 100
8648         ENDIF
8649
8650 C...If too high cross-section, use harder cuts, or fail.
8651         IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
8652           IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.
8653      &    PARJ(169).LT.0.99) THEN
8654             PARJ(169)=MIN(1.,1.2*PARJ(169))
8655             Q2=PARJ(169)*ECM**2
8656             ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8657             GOTO 100
8658           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
8659             CALL LUERRM(26,
8660      &      '(LUXJET:) no allowed y cut value for Zhu parametrization')
8661           ENDIF
8662           CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)
8663           IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8664           GOTO 100
8665         ENDIF
8666
8667 C...Scalar gluon (first order only).
8668       ELSE
8669         ALSPI=ULALPS(ECM**2)/PARU(1)
8670         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
8671         PARJ(152)=0.
8672         IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*
8673      &  LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))
8674         PARJ(153)=0.
8675         PARJ(154)=0.
8676       ENDIF
8677
8678 C...Select number of jets.
8679       PARJ(150)=CUT
8680       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
8681         NJET=2
8682       ELSEIF(MSTJ(101).LE.0) THEN
8683         NJET=MIN(4,2-MSTJ(101))
8684       ELSE
8685         RNJ=RLU(0)
8686         NJET=2
8687         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
8688         IF(PARJ(154).GT.RNJ) NJET=4
8689       ENDIF
8690
8691       RETURN
8692       END
8693
8694 C*********************************************************************
8695
8696       SUBROUTINE LUX3JT(NJET,CUT,KFL,ECM,X1,X2)
8697
8698 C...Purpose: to select the kinematical variables of three-jet events.
8699       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8700       SAVE /LUDAT1/
8701       DIMENSION ZHUP(5,12)
8702
8703 C...Coefficients of Zhu second order parametrization.
8704       DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
8705      &    18.29,    89.56,    4.541,   -52.09,   -109.8,    24.90,
8706      &    11.63,    3.683,    17.50, 0.002440,   -1.362,  -0.3537,
8707      &    11.42,    6.299,   -22.55,   -8.915,    59.25,   -5.855,
8708      &   -32.85,   -1.054,   -16.90, 0.006489,  -0.8156,  0.01095,
8709      &    7.847,   -3.964,   -35.83,    1.178,    29.39,   0.2806,
8710      &    47.82,   -12.36,   -56.72,  0.04054,  -0.4365,   0.6062,
8711      &    5.441,   -56.89,   -50.27,    15.13,    114.3,   -18.19,
8712      &    97.05,   -1.890,   -139.9,  0.08153,  -0.4984,   0.9439,
8713      &   -17.65,    51.44,   -58.32,    70.95,   -255.7,   -78.99,
8714      &    476.9,    29.65,   -239.3,   0.4745,   -1.174,    6.081/
8715
8716 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
8717       DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.
8718
8719 C...Event type. Mass effect factors and other common constants.
8720       MSTJ(120)=2
8721       MSTJ(121)=0
8722       PMQ=ULMASS(KFL)
8723       QME=(2.*PMQ/ECM)**2
8724       IF(MSTJ(109).NE.1) THEN
8725         CUTL=LOG(CUT)
8726         CUTD=LOG(1./CUT-2.)
8727         IF(MSTJ(109).EQ.0) THEN
8728           CF=4./3.
8729           CN=3.
8730           TR=2.
8731           WTMX=MIN(20.,37.-6.*CUTD)
8732           IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
8733         ELSE
8734           CF=1.
8735           CN=0.
8736           TR=12.
8737           WTMX=0.
8738         ENDIF
8739
8740 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
8741         ALS2PI=PARU(118)/PARU(2)
8742         WTOPT=0.
8743         IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
8744      &  ALS2PI
8745         WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
8746
8747 C...Choose three-jet events in allowed region.
8748   100   NJET=3
8749   110   Y13L=CUTL+CUTD*RLU(0)
8750         Y23L=CUTL+CUTD*RLU(0)
8751         Y13=EXP(Y13L)
8752         Y23=EXP(Y23L)
8753         Y12=1.-Y13-Y23
8754         IF(Y12.LE.CUT) GOTO 110
8755         IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLU(0)) GOTO 110
8756
8757 C...Second order corrections.
8758         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
8759           Y12L=LOG(Y12)
8760           Y13M=LOG(1.-Y13)
8761           Y23M=LOG(1.-Y23)
8762           Y12M=LOG(1.-Y12)
8763           IF(Y13.LE.0.5) Y13I=DILOG(Y13)
8764           IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)
8765           IF(Y23.LE.0.5) Y23I=DILOG(Y23)
8766           IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)
8767           IF(Y12.LE.0.5) Y12I=DILOG(Y12)
8768           IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)
8769           WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)
8770           WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+
8771      &    2.*(2.*CUTL-Y12L)*CUT/Y12)+
8772      &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+
8773      &    67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*
8774      &    CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+
8775      &    TR*(2.*CUTL/3.-10./9.)+
8776      &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
8777      &    Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+
8778      &    Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/
8779      &    WT1+
8780      &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+
8781      &    (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
8782      &    Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
8783      &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/
8784      &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
8785      &    2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-
8786      &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I)
8787           IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1
8788           IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
8789           PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)
8790
8791         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
8792 C...Second order corrections; Zhu parametrization of ERT.
8793           ZX=(Y23-Y13)**2
8794           ZY=1.-Y12
8795           IZA=0
8796           DO 120 IY=1,5
8797   120     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
8798           IF(IZA.NE.0) THEN
8799             IZ=IZA
8800             WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
8801      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
8802      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
8803      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
8804           ELSE
8805             IZ=100.*CUT
8806             WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
8807      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
8808      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
8809      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
8810             IZ=IZ+1
8811             WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
8812      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
8813      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
8814      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
8815             WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)
8816           ENDIF
8817           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1
8818           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
8819           PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)
8820         ENDIF
8821
8822 C...Impose mass cuts (gives two jets). For fixed jet number new try.
8823         X1=1.-Y23
8824         X2=1.-Y13
8825         X3=1.-Y12
8826         IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
8827         IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
8828      &  0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+
8829      &  (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLU(0)) NJET=2
8830         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
8831
8832 C...Scalar gluon model (first order only, no mass effects).
8833       ELSE
8834   130   NJET=3
8835   140   Y12=SQRT(4.*CUT**2+RLU(0)*((1.-CUT)**2-4.*CUT**2))
8836         IF(LOG((Y12-CUT)/CUT).LE.RLU(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140
8837         YD=SIGN(2.*CUT*((Y12-CUT)/CUT)**RLU(0)-Y12,RLU(0)-0.5)
8838         X1=1.-0.5*(Y12+YD)
8839         X2=1.-0.5*(Y12-YD)
8840         IF(4.*(1.-X1)*(1.-X2)*Y12/(1.-Y12)**2.LE.QME) NJET=2
8841         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
8842       ENDIF
8843
8844       RETURN
8845       END
8846
8847 C*********************************************************************
8848
8849       SUBROUTINE LUX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
8850
8851 C...Purpose: to select the kinematical variables of four-jet events.
8852       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8853       SAVE /LUDAT1/
8854       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
8855
8856 C...Common constants. Colour factors for QCD and Abelian gluon theory.
8857       PMQ=ULMASS(KFL)
8858       QME=(2.*PMQ/ECM)**2
8859       CT=LOG(1./CUT-5.)
8860       IF(MSTJ(109).EQ.0) THEN
8861         CF=4./3.
8862         CN=3.
8863         TR=2.
8864       ELSE
8865         CF=1.
8866         CN=0.
8867         TR=12.
8868       ENDIF
8869
8870 C...Choice of process (qqbargg or qqbarqqbar).
8871   100 NJET=4
8872       IT=1
8873       IF(PARJ(155).GT.RLU(0)) IT=2
8874       IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
8875       IF(IT.EQ.1) WTMX=0.7/CUT**2
8876       IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2
8877       IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2
8878       ID=1
8879
8880 C...Sample the five kinematical variables (for qqgg preweighted in y34).
8881   110 Y134=3.*CUT+(1.-6.*CUT)*RLU(0)
8882       Y234=3.*CUT+(1.-6.*CUT)*RLU(0)
8883       IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLU(0))
8884       IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLU(0)
8885       IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110
8886       VT=RLU(0)
8887       CP=COS(PARU(1)*RLU(0))
8888       Y14=(Y134-Y34)*VT
8889       Y13=Y134-Y14-Y34
8890       VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
8891       Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*
8892      &CP-(1.-2.*VT)*(1.-2.*VB))
8893       Y23=Y234-Y34-Y24
8894       Y12=1.-Y134-Y23-Y24
8895       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
8896       Y123=Y12+Y13+Y23
8897       Y124=Y12+Y14+Y24
8898
8899 C...Calculate matrix elements for qqgg or qqqq process.
8900       IC=0
8901       WTTOT=0.
8902   120 IC=IC+1
8903       IF(IT.EQ.1) THEN
8904         WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+
8905      &  3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-
8906      &  Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12*
8907      &  Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+
8908      &  2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*
8909      &  Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*
8910      &  Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)
8911         WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12*
8912      &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*
8913      &  Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+
8914      &  Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)
8915         WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*
8916      &  Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+
8917      &  Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-
8918      &  Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/
8919      &  (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24*
8920      &  Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*
8921      &  Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*
8922      &  Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+
8923      &  2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-
8924      &  2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)
8925         WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+
8926      &  4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34-
8927      &  Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+
8928      &  4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+
8929      &  2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*
8930      &  Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)-
8931      &  (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*
8932      &  Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-
8933      &  4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/
8934      &  (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34-
8935      &  2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-
8936      &  2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-
8937      &  Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)
8938         WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/
8939      &  8.
8940       ELSE
8941         WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12*
8942      &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
8943      &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
8944      &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
8945      &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
8946      &  Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
8947      &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
8948      &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
8949      &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
8950         WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
8951      &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
8952      &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
8953      &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
8954      &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
8955      &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
8956      &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
8957      &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
8958         WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16.
8959       ENDIF
8960
8961 C...Permutations of momenta in matrix element. Weighting.
8962   130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
8963         YSAV=Y13
8964         Y13=Y14
8965         Y14=YSAV
8966         YSAV=Y23
8967         Y23=Y24
8968         Y24=YSAV
8969         YSAV=Y123
8970         Y123=Y124
8971         Y124=YSAV
8972       ENDIF
8973       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
8974         YSAV=Y13
8975         Y13=Y23
8976         Y23=YSAV
8977         YSAV=Y14
8978         Y14=Y24
8979         Y24=YSAV
8980         YSAV=Y134
8981         Y134=Y234
8982         Y234=YSAV
8983       ENDIF
8984       IF(IC.LE.3) GOTO 120
8985       IF(ID.EQ.1.AND.WTTOT.LT.RLU(0)*WTMX) GOTO 110
8986       IC=5
8987
8988 C...qqgg events: string configuration and event type.
8989       IF(IT.EQ.1) THEN
8990         IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
8991           PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+
8992      &    WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT)
8993           IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLU(0)*(WTA(1)+WTA(2)+
8994      &    WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
8995           IF(ID.EQ.2) GOTO 130
8996         ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
8997           PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)
8998           IF(WTA(2)+WTA(4).GT.RLU(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
8999           IF(ID.EQ.2) GOTO 130
9000         ENDIF
9001         MSTJ(120)=3
9002         IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.
9003      &  RLU(0)*WTTOT) MSTJ(120)=4
9004         KFLN=21
9005
9006 C...Mass cuts. Kinematical variables out.
9007         IF(Y12.LE.CUT+QME) NJET=2
9008         IF(NJET.EQ.2) GOTO 150
9009         Q12=0.5*(1.-SQRT(1.-QME/Y12))
9010         X1=1.-(1.-Q12)*Y234-Q12*Y134
9011         X4=1.-(1.-Q12)*Y134-Q12*Y234
9012         X2=1.-Y124
9013         X12=(1.-Q12)*Y13+Q12*Y23
9014         X14=Y12-0.5*QME
9015         IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9016
9017 C...qqbarqqbar events: string configuration, choose new flavour.
9018       ELSE
9019         IF(ID.EQ.1) THEN
9020           WTR=RLU(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
9021           IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
9022           IF(WTR.LT.WTD(3)+WTD(4)) ID=3
9023           IF(WTR.LT.WTD(4)) ID=4
9024           IF(ID.GE.2) GOTO 130
9025         ENDIF
9026         MSTJ(120)=5
9027         PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)
9028   140   KFLN=1+INT(5.*RLU(0))
9029         IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLU(0)) GOTO 140
9030         IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLU(0)) GOTO 140
9031         IF(KFLN.GT.MSTJ(104)) NJET=2
9032         PMQN=ULMASS(KFLN)
9033         QMEN=(2.*PMQN/ECM)**2
9034
9035 C...Mass cuts. Kinematical variables out.
9036         IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2
9037         IF(NJET.EQ.2) GOTO 150
9038         Q24=0.5*(1.-SQRT(1.-QME/Y24))
9039         Q13=0.5*(1.-SQRT(1.-QMEN/Y13))
9040         X1=1.-(1.-Q24)*Y123-Q24*Y134
9041         X4=1.-(1.-Q24)*Y134-Q24*Y123
9042         X2=1.-(1.-Q13)*Y234-Q13*Y124
9043         X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)
9044         X14=Y24-0.5*QME
9045         X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)
9046         IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
9047      &  (PARJ(127)+PMQ+PMQN)**2) NJET=2
9048         IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9049       ENDIF
9050   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
9051
9052       RETURN
9053       END
9054
9055 C*********************************************************************
9056
9057       SUBROUTINE LUXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
9058
9059 C...Purpose: to give the angular orientation of events.
9060       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9061       SAVE /LUJETS/
9062       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9063       SAVE /LUDAT1/
9064       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9065       SAVE /LUDAT2/
9066
9067 C...Charge. Factors depending on polarization for QED case.
9068       QF=KCHG(KFL,1)/3.
9069       POLL=1.-PARJ(131)*PARJ(132)
9070       POLD=PARJ(132)-PARJ(131)
9071       IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
9072         HF1=POLL
9073         HF2=0.
9074         HF3=PARJ(133)**2
9075         HF4=0.
9076
9077 C...Factors depending on flavour, energy and polarization for QFD case.
9078       ELSE
9079         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9080         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9081         SFI=SFW*(1.-(PARJ(123)/ECM)**2)
9082         AE=-1.
9083         VE=4.*PARU(102)-1.
9084         AF=SIGN(1.,QF)
9085         VF=AF-4.*QF*PARU(102)
9086         HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
9087      &  (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD)
9088         HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*
9089      &  (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)
9090         HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
9091      &  SFW*SFF**2*(VE**2-AE**2))
9092         HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
9093      &  SFF*AE
9094       ENDIF
9095
9096 C...Mass factor. Differential cross-sections for two-jet events.
9097       SQ2=SQRT(2.)
9098       QME=0.
9099       IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
9100      &MSTJ(109).NE.1) QME=(2.*ULMASS(KFL)/ECM)**2
9101       IF(NJET.EQ.2) THEN
9102         SIGU=4.*SQRT(1.-QME)
9103         SIGL=2.*QME*SQRT(1.-QME)
9104         SIGT=0.
9105         SIGI=0.
9106         SIGA=0.
9107         SIGP=4.
9108
9109 C...Kinematical variables. Reduce four-jet event to three-jet one.
9110       ELSE
9111         IF(NJET.EQ.3) THEN
9112           X1=2.*P(NC+1,4)/ECM
9113           X2=2.*P(NC+3,4)/ECM
9114         ELSE
9115           ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
9116      &    (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
9117           X1=2.*P(NC+1,4)/ECMR
9118           X2=2.*P(NC+4,4)/ECMR
9119         ENDIF
9120
9121 C...Differential cross-sections for three-jet (or reduced four-jet).
9122         XQ=(1.-X1)/(1.-X2)
9123         CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))
9124         ST12=SQRT(1.-CT12**2)
9125         IF(MSTJ(109).NE.1) THEN
9126           SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-
9127      &    QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ
9128           SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+
9129      &    0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ
9130           SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2
9131           SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+
9132      &    0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2
9133           SIGA=X2**2*ST12/SQ2
9134           SIGP=2.*(X1**2-X2**2*CT12)
9135
9136 C...Differential cross-sect for scalar gluons (no mass or QFD effects).
9137         ELSE
9138           SIGU=2.*(2.-X1-X2)**2-(X2*ST12)**2
9139           SIGL=(X2*ST12)**2
9140           SIGT=0.5*SIGL
9141           SIGI=-(2.-X1-X2)*X2*ST12/SQ2
9142           SIGA=0.
9143           SIGP=0.
9144         ENDIF
9145       ENDIF
9146
9147 C...Upper bounds for differential cross-section.
9148       HF1A=ABS(HF1)
9149       HF2A=ABS(HF2)
9150       HF3A=ABS(HF3)
9151       HF4A=ABS(HF4)
9152       SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)*
9153      &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2*
9154      &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+
9155      &2.*HF2A*ABS(SIGP)
9156
9157 C...Generate angular orientation according to differential cross-sect.
9158   100 CHI=PARU(2)*RLU(0)
9159       CTHE=2.*RLU(0)-1.
9160       PHI=PARU(2)*RLU(0)
9161       CCHI=COS(CHI)
9162       SCHI=SIN(CHI)
9163       C2CHI=COS(2.*CHI)
9164       S2CHI=SIN(2.*CHI)
9165       THE=ACOS(CTHE)
9166       STHE=SIN(THE)
9167       C2PHI=COS(2.*(PHI-PARJ(134)))
9168       S2PHI=SIN(2.*(PHI-PARJ(134)))
9169       SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
9170      &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
9171      &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*
9172      &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*
9173      &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-
9174      &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
9175      &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP
9176       IF(SIG.LT.SIGMAX*RLU(0)) GOTO 100
9177
9178       RETURN
9179       END
9180
9181 C*********************************************************************
9182
9183       SUBROUTINE LUONIA(KFL,ECM)
9184
9185 C...Purpose: to generate Upsilon and toponium decays into three
9186 C...gluons or two gluons and a photon.
9187       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9188       SAVE /LUJETS/
9189       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9190       SAVE /LUDAT1/
9191       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9192       SAVE /LUDAT2/
9193
9194 C...Printout. Check input parameters.
9195       IF(MSTU(12).GE.1) CALL LULIST(0)
9196       IF(KFL.LT.0.OR.KFL.GT.8) THEN
9197         CALL LUERRM(16,'(LUONIA:) called with unknown flavour code')
9198         IF(MSTU(21).GE.1) RETURN
9199       ENDIF
9200       IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN
9201         CALL LUERRM(16,'(LUONIA:) called with too small CM energy')
9202         IF(MSTU(21).GE.1) RETURN
9203       ENDIF
9204
9205 C...Initial e+e- and onium state (optional).
9206       NC=0
9207       IF(MSTJ(115).GE.2) THEN
9208         NC=NC+2
9209         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
9210         K(NC-1,1)=21
9211         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9212         K(NC,1)=21
9213       ENDIF
9214       KFLC=IABS(KFL)
9215       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
9216         NC=NC+1
9217         KF=110*KFLC+3
9218         MSTU10=MSTU(10)
9219         MSTU(10)=1
9220         P(NC,5)=ECM
9221         CALL LU1ENT(NC,KF,ECM,0.,0.)
9222         K(NC,1)=21
9223         K(NC,3)=1
9224         MSTU(10)=MSTU10
9225       ENDIF
9226
9227 C...Choose x1 and x2 according to matrix element.
9228       NTRY=0
9229   100 X1=RLU(0)
9230       X2=RLU(0)
9231       X3=2.-X1-X2
9232       IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+
9233      &((1.-X3)/(X1*X2))**2.LE.2.*RLU(0)) GOTO 100
9234       NTRY=NTRY+1
9235       NJET=3
9236       IF(MSTJ(101).LE.4) CALL LU3ENT(NC+1,21,21,21,ECM,X1,X3)
9237       IF(MSTJ(101).GE.5) CALL LU3ENT(-(NC+1),21,21,21,ECM,X1,X3)
9238
9239 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
9240       MSTU(111)=MSTJ(108)
9241       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9242      &MSTU(111)=1
9243       PARU(112)=PARJ(121)
9244       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9245       QF=0.
9246       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
9247       RGAM=7.2*QF**2*PARU(101)/ULALPS(ECM**2)
9248       MK=0
9249       ECMC=ECM
9250       IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN
9251         IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
9252      &  NJET=2
9253         IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LU2ENT(NC+1,21,21,ECM)
9254         IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LU2ENT(-(NC+1),21,21,ECM)
9255       ELSE
9256         MK=1
9257         ECMC=SQRT(1.-X1)*ECM
9258         IF(ECMC.LT.2.*PARJ(127)) GOTO 100
9259         K(NC+1,1)=1
9260         K(NC+1,2)=22
9261         K(NC+1,4)=0
9262         K(NC+1,5)=0
9263         IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
9264         IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
9265         IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
9266         IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
9267         NJET=2
9268         IF(ECMC.LT.4.*PARJ(127)) THEN
9269           MSTU10=MSTU(10)
9270           MSTU(10)=1
9271           P(NC+2,5)=ECMC
9272           CALL LU1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
9273           MSTU(10)=MSTU10
9274           NJET=0
9275         ENDIF
9276       ENDIF
9277       DO 110 IP=NC+1,N
9278   110 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
9279
9280 C...Differential cross-sections. Upper limit for cross-section.
9281       IF(MSTJ(106).EQ.1) THEN
9282         SQ2=SQRT(2.)
9283         HF1=1.-PARJ(131)*PARJ(132)
9284         HF3=PARJ(133)**2
9285         CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3)
9286         ST13=SQRT(1.-CT13**2)
9287         SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2
9288         SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL
9289         SIGT=0.5*SIGL
9290         SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2
9291         SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+
9292      &  2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI)
9293
9294 C...Angular orientation of event.
9295   120   CHI=PARU(2)*RLU(0)
9296         CTHE=2.*RLU(0)-1.
9297         PHI=PARU(2)*RLU(0)
9298         CCHI=COS(CHI)
9299         SCHI=SIN(CHI)
9300         C2CHI=COS(2.*CHI)
9301         S2CHI=SIN(2.*CHI)
9302         THE=ACOS(CTHE)
9303         STHE=SIN(THE)
9304         C2PHI=COS(2.*(PHI-PARJ(134)))
9305         S2PHI=SIN(2.*(PHI-PARJ(134)))
9306         SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-
9307      &  STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*
9308      &  C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*
9309      &  CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
9310         IF(SIG.LT.SIGMAX*RLU(0)) GOTO 120
9311         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
9312         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
9313       ENDIF
9314
9315 C...Generate parton shower. Rearrange along strings and check.
9316       IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
9317         CALL LUSHOW(NC+MK+1,-NJET,ECMC)
9318         MSTJ14=MSTJ(14)
9319         IF(MSTJ(105).EQ.-1) MSTJ(14)=0
9320         IF(MSTJ(105).GE.0) MSTU(28)=0
9321         CALL LUPREP(0)
9322         MSTJ(14)=MSTJ14
9323         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9324       ENDIF
9325
9326 C...Generate fragmentation. Information for LUTABU:
9327       IF(MSTJ(105).EQ.1) CALL LUEXEC
9328       MSTU(161)=110*KFLC+3
9329       MSTU(162)=0
9330
9331       RETURN
9332       END
9333
9334 C*********************************************************************
9335
9336       SUBROUTINE LUHEPC(MCONV)
9337
9338 C...Purpose: to convert JETSET event record contents to or from
9339 C...the standard event record commonblock.
9340       PARAMETER (NMXHEP=9000)
9341       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
9342      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
9343       SAVE /HEPEVT/
9344       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9345       SAVE /LUJETS/
9346       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9347       SAVE /LUDAT1/
9348       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9349       SAVE /LUDAT2/
9350
9351 C...Conversion from JETSET to standard, the easy part.
9352       IF(MCONV.EQ.1) THEN
9353         NEVHEP=0
9354         IF(N.GT.NMXHEP) CALL LUERRM(8,
9355      &  '(LUHEPC:) no more space in /HEPEVT/')
9356         NHEP=MIN(N,NMXHEP)
9357         DO 140 I=1,NHEP
9358         ISTHEP(I)=0
9359         IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
9360         IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
9361         IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
9362         IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
9363         IDHEP(I)=K(I,2)
9364         JMOHEP(1,I)=K(I,3)
9365         JMOHEP(2,I)=0
9366         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
9367           JDAHEP(1,I)=K(I,4)
9368           JDAHEP(2,I)=K(I,5)
9369         ELSE
9370           JDAHEP(1,I)=0
9371           JDAHEP(2,I)=0
9372         ENDIF
9373         DO 100 J=1,5
9374   100   PHEP(J,I)=P(I,J)
9375         DO 110 J=1,4
9376   110   VHEP(J,I)=V(I,J)
9377
9378 C...Fill in missing mother information.
9379         IF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
9380           I1=K(I,3)-1
9381   120     I1=I1+1
9382           IF(I1.GE.I) CALL LUERRM(8,
9383      &    '(LUHEPC:) translation of inconsistent event history')
9384           IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
9385           KC=LUCOMP(K(I1,2))
9386           IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
9387           IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
9388           JMOHEP(2,I)=I1
9389         ELSEIF(K(I,2).EQ.94) THEN
9390           NJET=2
9391           IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
9392           IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
9393           JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
9394           IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
9395      &    MOD(K(I+1,4)/MSTU(5),MSTU(5))
9396         ENDIF
9397
9398 C...Fill in missing daughter information.
9399         IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
9400           DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
9401           I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
9402   130     JDAHEP(1,I2)=I
9403         ENDIF
9404         IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
9405         I1=JMOHEP(1,I)
9406         IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
9407         IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
9408         IF(JDAHEP(1,I1).EQ.0) THEN
9409           JDAHEP(1,I1)=I
9410         ELSE
9411           JDAHEP(2,I1)=I
9412         ENDIF
9413   140   CONTINUE
9414         DO 150 I=1,NHEP
9415         IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
9416         IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
9417   150   CONTINUE
9418
9419 C...Conversion from standard to JETSET, the easy part.
9420       ELSE
9421         IF(NHEP.GT.MSTU(4)) CALL LUERRM(8,
9422      &  '(LUHEPC:) no more space in /LUJETS/')
9423         N=MIN(NHEP,MSTU(4))
9424         NKQ=0
9425         KQSUM=0
9426         DO 180 I=1,N
9427         K(I,1)=0
9428         IF(ISTHEP(I).EQ.1) K(I,1)=1
9429         IF(ISTHEP(I).EQ.2) K(I,1)=11
9430         IF(ISTHEP(I).EQ.3) K(I,1)=21
9431         K(I,2)=IDHEP(I)
9432         K(I,3)=JMOHEP(1,I)
9433         K(I,4)=JDAHEP(1,I)
9434         K(I,5)=JDAHEP(2,I)
9435         DO 160 J=1,5
9436   160   P(I,J)=PHEP(J,I)
9437         DO 170 J=1,4
9438   170   V(I,J)=VHEP(J,I)
9439         V(I,5)=0.
9440         IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
9441           I1=JDAHEP(1,I)
9442           IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
9443      &    PHEP(5,I)/PHEP(4,I)
9444         ENDIF
9445
9446 C...Fill in missing information on colour connection in jet systems.
9447         IF(ISTHEP(I).EQ.1) THEN
9448           KC=LUCOMP(K(I,2))
9449           KQ=0
9450           IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
9451           IF(KQ.NE.0) NKQ=NKQ+1
9452           IF(KQ.NE.2) KQSUM=KQSUM+KQ
9453           IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
9454             K(I,1)=2
9455           ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
9456             IF(K(I+1,2).EQ.21) K(I,1)=2
9457           ENDIF
9458         ENDIF
9459   180   CONTINUE
9460         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LUERRM(8,
9461      &  '(LUHEPC:) input parton configuration not colour singlet')
9462       ENDIF
9463
9464       END
9465
9466 C*********************************************************************
9467
9468       SUBROUTINE LUTEST(MTEST)
9469
9470 C...Purpose: to provide a simple program (disguised as subroutine) to
9471 C...run at installation as a check that the program works as intended.
9472       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9473       SAVE /LUJETS/
9474       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9475       SAVE /LUDAT1/
9476       DIMENSION PSUM(5),PINI(6),PFIN(6)
9477
9478 C...Loop over events to be generated.
9479       IF(MTEST.GE.1) CALL LUTABU(20)
9480       NERR=0
9481       DO 170 IEV=1,600
9482
9483 C...Reset parameter values. Switch on some nonstandard features.
9484       MSTJ(1)=1
9485       MSTJ(3)=0
9486       MSTJ(11)=1
9487       MSTJ(42)=2
9488       MSTJ(43)=4
9489       MSTJ(44)=2
9490       PARJ(17)=0.1
9491       PARJ(22)=1.5
9492       PARJ(43)=1.
9493       PARJ(54)=-0.05
9494       MSTJ(101)=5
9495       MSTJ(104)=5
9496       MSTJ(105)=0
9497       MSTJ(107)=1
9498       IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
9499
9500 C...Ten events each for some single jets configurations.
9501       IF(IEV.LE.50) THEN
9502         ITY=(IEV+9)/10
9503         MSTJ(3)=-1
9504         IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
9505         IF(ITY.EQ.1) CALL LU1ENT(1,1,15.,0.,0.)
9506         IF(ITY.EQ.2) CALL LU1ENT(1,3101,15.,0.,0.)
9507         IF(ITY.EQ.3) CALL LU1ENT(1,-2203,15.,0.,0.)
9508         IF(ITY.EQ.4) CALL LU1ENT(1,-4,30.,0.,0.)
9509         IF(ITY.EQ.5) CALL LU1ENT(1,21,15.,0.,0.)
9510
9511 C...Ten events each for some simple jet systems; string fragmentation.
9512       ELSEIF(IEV.LE.130) THEN
9513         ITY=(IEV-41)/10
9514         IF(ITY.EQ.1) CALL LU2ENT(1,1,-1,40.)
9515         IF(ITY.EQ.2) CALL LU2ENT(1,4,-4,30.)
9516         IF(ITY.EQ.3) CALL LU2ENT(1,2,2103,100.)
9517         IF(ITY.EQ.4) CALL LU2ENT(1,21,21,40.)
9518         IF(ITY.EQ.5) CALL LU3ENT(1,2101,21,-3203,30.,0.6,0.8)
9519         IF(ITY.EQ.6) CALL LU3ENT(1,5,21,-5,40.,0.9,0.8)
9520         IF(ITY.EQ.7) CALL LU3ENT(1,21,21,21,60.,0.7,0.5)
9521         IF(ITY.EQ.8) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9522
9523 C...Seventy events with independent fragmentation and momentum cons.
9524       ELSEIF(IEV.LE.200) THEN
9525         ITY=1+(IEV-131)/16
9526         MSTJ(2)=1+MOD(IEV-131,4)
9527         MSTJ(3)=1+MOD((IEV-131)/4,4)
9528         IF(ITY.EQ.1) CALL LU2ENT(1,4,-5,40.)
9529         IF(ITY.EQ.2) CALL LU3ENT(1,3,21,-3,40.,0.9,0.4)
9530         IF(ITY.EQ.3) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9531         IF(ITY.GE.4) CALL LU4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
9532
9533 C...A hundred events with random jets (check invariant mass).
9534       ELSEIF(IEV.LE.300) THEN
9535   100   DO 110 J=1,5
9536   110   PSUM(J)=0.
9537         NJET=2.+6.*RLU(0)
9538         DO 120 I=1,NJET
9539         KFL=21
9540         IF(I.EQ.1) KFL=INT(1.+4.*RLU(0))
9541         IF(I.EQ.NJET) KFL=-INT(1.+4.*RLU(0))
9542         EJET=5.+20.*RLU(0)
9543         THETA=ACOS(2.*RLU(0)-1.)
9544         PHI=6.2832*RLU(0)
9545         IF(I.LT.NJET) CALL LU1ENT(-I,KFL,EJET,THETA,PHI)
9546         IF(I.EQ.NJET) CALL LU1ENT(I,KFL,EJET,THETA,PHI)
9547         IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+ULMASS(KFL)
9548         DO 120 J=1,4
9549   120   PSUM(J)=PSUM(J)+P(I,J)
9550         IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
9551      &  (PSUM(5)+PARJ(32))**2) GOTO 100
9552
9553 C...Fifty e+e- continuum events with matrix elements.
9554       ELSEIF(IEV.LE.350) THEN
9555         MSTJ(101)=2
9556         CALL LUEEVT(0,40.)
9557
9558 C...Fifty e+e- continuum event with varying shower options.
9559       ELSEIF(IEV.LE.400) THEN
9560         MSTJ(42)=1+MOD(IEV,2)
9561         MSTJ(43)=1+MOD(IEV/2,4)
9562         MSTJ(44)=MOD(IEV/8,3)
9563         CALL LUEEVT(0,90.)
9564
9565 C...Fifty e+e- continuum events with coherent shower, including top.
9566       ELSEIF(IEV.LE.450) THEN
9567         MSTJ(104)=6
9568         CALL LUEEVT(0,500.)
9569
9570 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
9571       ELSEIF(IEV.LE.500) THEN
9572         CALL LUONIA(5,9.46)
9573
9574 C...One decay each for some heavy mesons.
9575       ELSEIF(IEV.LE.560) THEN
9576         ITY=IEV-501
9577         KFLS=2*(ITY/20)+1
9578         KFLB=8-MOD(ITY/5,4)
9579         KFLC=KFLB-MOD(ITY,5)
9580         CALL LU1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9581
9582 C...One decay each for some heavy baryons.
9583       ELSEIF(IEV.LE.600) THEN
9584         ITY=IEV-561
9585         KFLS=2*(ITY/20)+2
9586         KFLA=8-MOD(ITY/5,4)
9587         KFLB=KFLA-MOD(ITY,5)
9588         KFLC=MAX(1,KFLB-1)
9589         CALL LU1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9590       ENDIF
9591
9592 C...Generate event. Find total momentum, energy and charge.
9593       DO 130 J=1,4
9594   130 PINI(J)=PLU(0,J)
9595       PINI(6)=PLU(0,6)
9596       CALL LUEXEC
9597       DO 140 J=1,4
9598   140 PFIN(J)=PLU(0,J)
9599       PFIN(6)=PLU(0,6)
9600
9601 C...Check conservation of energy, momentum and charge;
9602 C...usually exact, but only approximate for single jets.
9603       MERR=0
9604       IF(IEV.LE.50) THEN
9605         IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1
9606         EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
9607         IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1
9608         IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1
9609       ELSE
9610         DO 150 J=1,4
9611   150   IF(ABS(PFIN(J)-PINI(J)).GT.0001*PINI(4)) MERR=MERR+1
9612         IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
9613       ENDIF
9614       IF(MERR.NE.0) WRITE(MSTU(11),1000) (PINI(J),J=1,4),PINI(6),
9615      &(PFIN(J),J=1,4),PFIN(6)
9616
9617 C...Check that all KF codes are known ones, and that partons/particles
9618 C...satisfy energy-momentum-mass relation. Store particle statistics.
9619       DO 160 I=1,N
9620       IF(K(I,1).GT.20) GOTO 160
9621       IF(LUCOMP(K(I,2)).EQ.0) THEN
9622         WRITE(MSTU(11),1100) I
9623         MERR=MERR+1
9624       ENDIF
9625       PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
9626       IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN
9627         WRITE(MSTU(11),1200) I
9628         MERR=MERR+1
9629       ENDIF
9630   160 CONTINUE
9631       IF(MTEST.GE.1) CALL LUTABU(21)
9632
9633 C...List all erroneous events and some normal ones.
9634       IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
9635         CALL LULIST(2)
9636       ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
9637         CALL LULIST(1)
9638       ENDIF
9639
9640 C...Stop execution if too many errors. Endresult of run.
9641       IF(MERR.NE.0) NERR=NERR+1
9642       IF(NERR.GE.10) THEN
9643         WRITE(MSTU(11),1300) IEV
9644         STOP
9645       ENDIF
9646   170 CONTINUE
9647       IF(MTEST.GE.1) CALL LUTABU(22)
9648       WRITE(MSTU(11),1400) NERR
9649
9650 C...Reset commonblock variables changed during run.
9651       MSTJ(2)=3
9652       PARJ(17)=0.
9653       PARJ(22)=1.
9654       PARJ(43)=0.5
9655       PARJ(54)=0.
9656       MSTJ(105)=1
9657       MSTJ(107)=0
9658
9659 C...Format statements for output.
9660  1000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
9661      &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
9662      &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
9663      &4(1X,F12.5),1X,F8.2)
9664  1100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
9665  1200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
9666      &'kinematics')
9667  1300 FORMAT(/5X,'Ten errors experienced by event ',I3/
9668      &5X,'Something is seriously wrong! Execution stopped now!')
9669  1400 FORMAT(/5X,'Number of erroneous or suspect events in run:',I3/
9670      &5X,'(0 fine, 1 acceptable if a single jet, ',
9671      &'>=2 something is wrong)')
9672
9673       RETURN
9674       END
9675
9676 C*********************************************************************
9677
9678       BLOCK DATA LUDATA
9679
9680 C...Purpose: to give default values to parameters and particle and
9681 C...decay data.
9682       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9683       SAVE /LUDAT1/
9684       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9685       SAVE /LUDAT2/
9686       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
9687       SAVE /LUDAT3/
9688       COMMON/LUDAT4/CHAF(500)
9689       CHARACTER CHAF*8
9690       SAVE /LUDAT4/
9691       COMMON/LUDATR/MRLU(6),RRLU(100)
9692       SAVE /LUDATR/
9693
9694 C...LUDAT1, containing status codes and most parameters.
9695       DATA MSTU/
9696      &    0,    0,    0, 9000,10000,  500, 2000,    0,    0,    2,
9697      1    6,    1,    1,    0,    1,    1,    0,    0,    0,    0,
9698      2    2,   10,    0,    0,    1,   10,    0,    0,    0,    0,
9699      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
9700      4    2,    2,    1,    4,    2,    1,    1,    0,    0,    0,
9701      5   25,   24,    0,    1,    0,    0,    0,    0,    0,    0,
9702      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
9703      7  40*0,
9704      1    1,    5,    3,    5,    0,    0,    0,    0,    0,    0,
9705      2  60*0,
9706      8    7,    2, 1989,   11,   25,    0,    0,    0,    0,    0,
9707      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
9708       DATA PARU/
9709      & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568,   4*0.,
9710      1 0.001, 0.09, 0.01,  0.,   0.,   0.,   0.,   0.,   0.,   0.,
9711      2   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9712      3   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9713      4  2.0,  1.0, 0.25,  2.5, 0.05,   0.,   0., 0.0001, 0.,   0.,
9714      5  2.5,  1.5,  7.0,  1.0,  0.5,  2.0,  3.2,   0.,   0.,   0.,
9715      6  40*0.,
9716      & 0.0072974, 0.230, 0., 0., 0.,   0.,   0.,   0.,   0.,   0.,
9717      1 0.20, 0.25,  1.0,  4.0,   0.,   0.,   0.,   0.,   0.,   0.,
9718      2  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9719      3  70*0./
9720       DATA MSTJ/
9721      &    1,    3,    0,    0,    0,    0,    0,    0,    0,    0,
9722      1    1,    2,    0,    1,    0,    0,    0,    0,    0,    0,
9723      2    2,    1,    1,    2,    1,    0,    0,    0,    0,    0,
9724      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
9725      4    1,    2,    4,    2,    5,    0,    1,    0,    0,    0,
9726      5    0,    3,    0,    0,    0,    0,    0,    0,    0,    0,
9727      6  40*0,
9728      &    5,    2,    7,    5,    1,    1,    0,    2,    0,    1,
9729      1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
9730      2  80*0/
9731       DATA PARJ/
9732      & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50,   0.,   0.,   0.,
9733      1 0.50, 0.60, 0.75,   0.,   0.,   0.,   0.,  1.0,  1.0,   0.,
9734      2 0.35,  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9735      3 0.10,  1.0,  0.8,  1.5,  0.8,  2.0,  0.2,  2.5,  0.6,  2.5,
9736      4  0.5,  0.9,  0.5,  0.9,  0.5,   0.,   0.,   0.,   0.,   0.,
9737      5 0.77, 0.77, 0.77,   0.,   0.,   0.,   0.,   0.,  1.0,   0.,
9738      6  4.5,  0.7,  0., 0.003,  0.5,  0.5,   0.,   0.,   0.,   0.,
9739      7  10., 1000., 100., 1000., 0.,   0.,   0.,   0.,   0.,   0.,
9740      8  0.4,  1.0,  1.0,   0.,  10.,  10.,   0.,   0.,   0.,   0.,
9741      9 0.02,  1.0,  0.2,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9742      &   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9743      1   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9744      2  1.5,  0.5, 91.2, 2.40, 0.02,  2.0,  1.0, 0.25,0.002,   0.,
9745      3   0.,   0.,   0.,   0., 0.01, 0.99,   0.,   0.,  0.2,   0.,
9746      4  60*0./
9747
9748 C...LUDAT2, with particle data and flavour treatment parameters.
9749       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
9750      &-3,0,-3,6*0,3,9*0,3,2*0,3,46*0,2,-1,2,-1,2,3,11*0,3,0,2*3,
9751      &0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,
9752      &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,
9753      &3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,
9754      &4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,-3,0,3,-3,0,-3,114*0/
9755       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,68*0,-1,410*0/
9756       DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,2*0,1,
9757      &41*0,1,0,7*1,10*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,
9758      &11*0,9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,
9759      &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
9760       DATA (PMAS(I,1),I=   1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,
9761      &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15.,
9762      &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,
9763      &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,
9764      &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921,
9765      &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,
9766      &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,
9767      &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,
9768      &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,
9769      &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,
9770      &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,
9771      &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,
9772      &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,
9773      &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,
9774      &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,
9775      &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,
9776      &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,
9777      &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./
9778       DATA (PMAS(I,2),I=   1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,
9779      &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06,
9780      &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,
9781      &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,
9782      &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,
9783      &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./
9784       DATA (PMAS(I,3),I=   1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4,
9785      &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2,
9786      &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,
9787      &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,
9788      &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./
9789       DATA (PMAS(I,4),I=   1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,
9790      &15*0.,7803.,0.,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,
9791      &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,
9792      &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./
9793       DATA PARF/
9794      &  0.5, 0.25,  0.5, 0.25,   1.,  0.5,   0.,   0.,   0.,   0.,
9795      1  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9796      2  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9797      3  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9798      4  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9799      5  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9800      6 0.75,  0.5,   0., 0.1667, 0.0833, 0.1667, 0., 0., 0.,   0.,
9801      7   0.,   0.,   1., 0.3333, 0.6667, 0.3333, 0., 0., 0.,   0.,
9802      8   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9803      9   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9804      & 0.325, 0.325, 0.5, 1.6,  5.0,   0.,   0.,   0.,   0.,   0.,
9805      1   0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60,  0.,   0.,
9806      2  0.2,  0.1,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9807      3  1870*0./
9808       DATA ((VCKM(I,J),J=1,4),I=1,4)/
9809      1  0.95150,  0.04847,  0.00003,  0.00000,
9810      2  0.04847,  0.94936,  0.00217,  0.00000,
9811      3  0.00003,  0.00217,  0.99780,  0.00000,
9812      4  0.00000,  0.00000,  0.00000,  1.00000/
9813
9814 C...LUDAT3, with particle decay parameters and data.
9815       DATA (MDCY(I,1),I=   1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,
9816      &1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,
9817      &9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,2*1,
9818      &6*0,1,0,2*1,9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
9819       DATA (MDCY(I,2),I=   1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
9820      &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,
9821      &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,
9822      &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,
9823      &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,
9824      &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,
9825      &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,
9826      &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,
9827      &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,
9828      &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,
9829      &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,
9830      &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023,
9831      &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,
9832      &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,
9833      &1065,114*0/
9834       DATA (MDCY(I,3),I=   1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,
9835      &17,20,17,6*0,16,4*0,8,2*0,9,42*0,1,4,9,3*2,20,11*0,1,2,6,121,168,
9836      &32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,2*0,1,2*5,
9837      &2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,2*4,3*2,2*1,
9838      &2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,2*8,5,0,7,8,
9839      &4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,2,1,3,1,2,0,
9840      &6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
9841       DATA (MDME(I,1),I=   1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
9842      &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,2*-1,6*1,2*-1,6*1,3*-1,3*1,-1,3*1,
9843      &-1,3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,2*-1,3*1,-1,3*1,
9844      &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/
9845       DATA (MDME(I,2),I=   1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
9846      &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
9847      &8*0,4*32,4*0,6*32,3*0,12,2*42,2*11,9*42,6*45,20*46,7*0,34*42,
9848      &86*0,2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,
9849      &8*0,2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0,
9850      &12,3*0,4*32,2*4,6*0,5*32,2*4,2*45,87,88,30*0,12,32,0,32,87,88,
9851      &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,
9852      &32,87,88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,
9853      &974*0/
9854       DATA (BRAT(I)  ,I=   1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003,
9855      &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,
9856      &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,
9857      &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01,
9858      &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,
9859      &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,
9860      &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,
9861      &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,
9862      &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032,
9863      &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,
9864      &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001,
9865      &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037,
9866      &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,
9867      &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004,
9868      &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004,
9869      &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021,
9870      &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,
9871      &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,
9872      &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007,
9873      &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/
9874       DATA (BRAT(I)  ,I= 526, 893)/.019,2*.003,.002,.005,.004,.008,
9875      &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001,
9876      &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04,
9877      &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012,
9878      &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,
9879      &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,
9880      &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,
9881      &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,
9882      &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,
9883      &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,
9884      &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033,
9885      &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,
9886      &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333,
9887      &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35,
9888      &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,
9889      &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084,
9890      &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,
9891      &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,
9892      &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,
9893      &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/
9894       DATA (BRAT(I)  ,I= 894,2000)/.003,.573,.287,.063,.028,2*.021,
9895      &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,
9896      &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003,
9897      &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006,
9898      &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,
9899      &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001,
9900      &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,
9901      &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,
9902      &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676,
9903      &.234,.085,.005,3*1.,4*.5,7*1.,935*0./
9904       DATA (KFDP(I,1),I=   1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,
9905      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
9906      &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
9907      &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
9908      &23,-24,25,23,24,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,
9909      &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5,
9910      &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,
9911      &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,
9912      &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,
9913      &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
9914      &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,
9915      &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,
9916      &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,
9917      &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,
9918      &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311,
9919      &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311,
9920      &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,
9921      &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,
9922      &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,
9923      &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/
9924       DATA (KFDP(I,1),I= 500, 873)/-323,2*-321,-311,2*333,211,213,
9925      &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,
9926      &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313,
9927      &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15,
9928      &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,
9929      &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111,
9930      &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,
9931      &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,
9932      &82,11,13,15,1,2,3,4,21,22,11,12,13,14,15,16,1,2,3,4,5,21,22,2*89,
9933      &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,
9934      &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,
9935      &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413,
9936      &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,
9937      &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,
9938      &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,
9939      &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213,
9940      &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,
9941      &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,
9942      &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,
9943      &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/
9944       DATA (KFDP(I,1),I= 874,2000)/2*511,521,513,523,513,523,511,2*521,
9945      &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130,
9946      &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,
9947      &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
9948      &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212,
9949      &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
9950      &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,
9951      &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,
9952      &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,
9953      &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,
9954      &935*0/
9955       DATA (KFDP(I,2),I=   1, 496)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
9956      &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,
9957      &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
9958      &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
9959      &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
9960      &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
9961      &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,
9962      &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
9963      &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,
9964      &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
9965      &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
9966      &-3,11,13,15,1,4,3,4,1,3,5,3,6,4,7,5,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
9967      &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,
9968      &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,
9969      &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223,
9970      &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113,
9971      &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1,
9972      &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,
9973      &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,
9974      &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/
9975       DATA (KFDP(I,2),I= 497, 863)/323,321,2*311,313,2*311,111,211,
9976      &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,
9977      &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,
9978      &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,
9979      &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,
9980      &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,
9981      &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,
9982      &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,
9983      &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4,
9984      &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,
9985      &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,
9986      &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,
9987      &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,
9988      &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321,
9989      &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211,
9990      &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111,
9991      &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22,
9992      &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
9993      &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
9994      &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/
9995       DATA (KFDP(I,2),I= 864,2000)/2*111,211,-211,111,-211,111,-211,
9996      &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,
9997      &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22,
9998      &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111,
9999      &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,
10000      &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,
10001      &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,
10002      &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
10003      &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211,
10004      &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,
10005      &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,
10006      &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/
10007       DATA (KFDP(I,3),I=   1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,
10008      &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
10009      &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,
10010      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10011      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10012      &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
10013      &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
10014      &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
10015      &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
10016      &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
10017      &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
10018      &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
10019      &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
10020      &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
10021      &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
10022      &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,
10023      &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
10024      &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
10025      &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
10026      &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
10027       DATA (KFDP(I,3),I= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,
10028      &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
10029      &2112,43*0,3322,949*0/
10030       DATA (KFDP(I,4),I=   1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
10031      &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111,
10032      &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
10033      &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
10034      &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
10035      &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
10036      &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
10037      &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
10038      &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
10039      &1006*0/
10040       DATA (KFDP(I,5),I=   1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
10041      &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
10042      &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/
10043
10044 C...LUDAT4, with character strings.
10045       DATA (CHAF(I)  ,I=   1, 331)/'d','u','s','c','b','t','l','h',
10046      &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
10047      &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',
10048      &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron',
10049      &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',
10050      &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis',
10051      &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B',
10052      &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l',
10053      &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho',
10054      &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',
10055      &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',
10056      &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',
10057      &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
10058      &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
10059      &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
10060      &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
10061      &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
10062      &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
10063      &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',
10064      &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/
10065       DATA (CHAF(I)  ,I= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',
10066      &3*'Sigma_c',2*'Xi''_c','Omega_c',
10067      &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
10068      &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
10069      &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
10070
10071 C...LUDATR, with initial values for the random number generator.
10072       DATA MRLU/19780503,0,0,97,33,0/
10073
10074       END
10075       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
10076
10077 C...Initializes the generation procedure; finds maxima of the
10078 C...differential cross-sections to be used for weighting.
10079       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10080       SAVE /LUDAT1/
10081       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10082       SAVE /LUDAT2/
10083       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10084       SAVE /LUDAT3/
10085       COMMON/LUDAT4/CHAF(500)
10086       CHARACTER CHAF*8
10087       SAVE /LUDAT4/
10088       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10089       SAVE /PYSUBS/
10090       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10091       SAVE /PYPARS/
10092       COMMON/PYINT1/MINT(400),VINT(400)
10093       SAVE /PYINT1/
10094       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
10095       SAVE /PYINT2/
10096       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
10097       SAVE /PYINT5/
10098       CHARACTER*(*) FRAME,BEAM,TARGET
10099       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHMO(12)*3,CHLH(2)*6
10100       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
10101      &'Oct','Nov','Dec'/, CHLH/'lepton','hadron'/
10102
10103 C...Write headers.
10104 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),
10105 C     &MSTP(185),CHMO(MSTP(184)),MSTP(183)
10106       CALL LULIST(0)
10107 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)
10108
10109 C...Identify beam and target particles and initialize kinematics.
10110       CHFRAM=FRAME//' '
10111       CHBEAM=BEAM//' '
10112       CHTARG=TARGET//' '
10113       CALL PYINKI(CHFRAM,CHBEAM,CHTARG,WIN)
10114
10115 C...Select partonic subprocesses to be included in the simulation.
10116       IF(MSEL.NE.0) THEN
10117         DO 100 I=1,200
10118   100   MSUB(I)=0
10119       ENDIF
10120       IF(MINT(43).EQ.1.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
10121 C...Lepton+lepton -> gamma/Z0 or W.
10122         IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
10123         IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
10124       ELSEIF(MSEL.EQ.1) THEN
10125 C...High-pT QCD processes:
10126         MSUB(11)=1
10127         MSUB(12)=1
10128         MSUB(13)=1
10129         MSUB(28)=1
10130         MSUB(53)=1
10131         MSUB(68)=1
10132         IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
10133         IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
10134       ELSEIF(MSEL.EQ.2) THEN
10135 C...All QCD processes:
10136         MSUB(11)=1
10137         MSUB(12)=1
10138         MSUB(13)=1
10139         MSUB(28)=1
10140         MSUB(53)=1
10141         MSUB(68)=1
10142         MSUB(91)=1
10143         MSUB(92)=1
10144         MSUB(93)=1
10145         MSUB(95)=1
10146       ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
10147 C...Heavy quark production.
10148         MSUB(81)=1
10149         MSUB(82)=1
10150         DO 110 J=1,MIN(8,MDCY(21,3))
10151   110   MDME(MDCY(21,2)+J-1,1)=0
10152         MDME(MDCY(21,2)+MSEL-1,1)=1
10153       ELSEIF(MSEL.EQ.10) THEN
10154 C...Prompt photon production:
10155         MSUB(14)=1
10156         MSUB(18)=1
10157         MSUB(29)=1
10158       ELSEIF(MSEL.EQ.11) THEN
10159 C...Z0/gamma* production:
10160         MSUB(1)=1
10161       ELSEIF(MSEL.EQ.12) THEN
10162 C...W+/- production:
10163         MSUB(2)=1
10164       ELSEIF(MSEL.EQ.13) THEN
10165 C...Z0 + jet:
10166         MSUB(15)=1
10167         MSUB(30)=1
10168       ELSEIF(MSEL.EQ.14) THEN
10169 C...W+/- + jet:
10170         MSUB(16)=1
10171         MSUB(31)=1
10172       ELSEIF(MSEL.EQ.15) THEN
10173 C...Z0 & W+/- pair production:
10174         MSUB(19)=1
10175         MSUB(20)=1
10176         MSUB(22)=1
10177         MSUB(23)=1
10178         MSUB(25)=1
10179       ELSEIF(MSEL.EQ.16) THEN
10180 C...H0 production:
10181         MSUB(3)=1
10182         MSUB(5)=1
10183         MSUB(8)=1
10184         MSUB(102)=1
10185       ELSEIF(MSEL.EQ.17) THEN
10186 C...H0 & Z0 or W+/- pair production:
10187         MSUB(24)=1
10188         MSUB(26)=1
10189       ELSEIF(MSEL.EQ.21) THEN
10190 C...Z'0 production:
10191         MSUB(141)=1
10192       ELSEIF(MSEL.EQ.22) THEN
10193 C...H+/- production:
10194         MSUB(142)=1
10195       ELSEIF(MSEL.EQ.23) THEN
10196 C...R production:
10197         MSUB(143)=1
10198       ENDIF
10199
10200 C...Count number of subprocesses on.
10201       MINT(44)=0
10202       DO 120 ISUB=1,200
10203       IF(MINT(43).LT.4.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
10204      &MSUB(ISUB).EQ.1) THEN
10205         WRITE(MSTU(11),1200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
10206         STOP
10207       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
10208         WRITE(MSTU(11),1300) ISUB
10209         STOP
10210       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
10211         WRITE(MSTU(11),1400) ISUB
10212         STOP
10213       ELSEIF(MSUB(ISUB).EQ.1) THEN
10214         MINT(44)=MINT(44)+1
10215       ENDIF
10216   120 CONTINUE
10217       IF(MINT(44).EQ.0) THEN
10218         WRITE(MSTU(11),1500)
10219         STOP
10220       ENDIF
10221       MINT(45)=MINT(44)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
10222
10223 C...Maximum 4 generations; set maximum number of allowed flavours.
10224       MSTP(1)=MIN(4,MSTP(1))
10225       MSTU(114)=MIN(MSTU(114),2*MSTP(1))
10226       MSTP(54)=MIN(MSTP(54),2*MSTP(1))
10227
10228 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
10229       DO 140 I=-20,20
10230       VINT(180+I)=0.
10231       IA=IABS(I)
10232       IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
10233         DO 130 J=1,MSTP(1)
10234         IB=2*J-1+MOD(IA,2)
10235         IPM=(5-ISIGN(1,I))/2
10236         IDC=J+MDCY(IA,2)+2
10237   130   IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
10238      &  VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
10239       ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
10240         VINT(180+I)=1.
10241       ENDIF
10242   140 CONTINUE
10243
10244 C...Choose Lambda value to use in alpha-strong.
10245       MSTU(111)=MSTP(2)
10246       IF(MSTP(3).GE.1) THEN
10247         ALAM=PARP(1)
10248         IF(MSTP(51).EQ.1) ALAM=0.2
10249         IF(MSTP(51).EQ.2) ALAM=0.29
10250         IF(MSTP(51).EQ.3) ALAM=0.2
10251         IF(MSTP(51).EQ.4) ALAM=0.4
10252         IF(MSTP(51).EQ.11) ALAM=0.16
10253         IF(MSTP(51).EQ.12) ALAM=0.26
10254         IF(MSTP(51).EQ.13) ALAM=0.36
10255         PARP(1)=ALAM
10256         PARP(61)=ALAM
10257         PARU(112)=ALAM
10258         PARJ(81)=ALAM
10259       ENDIF
10260
10261 C...Initialize widths and partial widths for resonances.
10262       CALL PYINRE
10263
10264 C...Reset variables for cross-section calculation.
10265       DO 150 I=0,200
10266       DO 150 J=1,3
10267       NGEN(I,J)=0
10268   150 XSEC(I,J)=0.
10269       VINT(108)=0.
10270
10271 C...Find parametrized total cross-sections.
10272       IF(MINT(43).EQ.4) CALL PYXTOT
10273
10274 C...Maxima of differential cross-sections.
10275       IF(MSTP(121).LE.0) CALL PYMAXI
10276
10277 C...Initialize possibility of overlayed events.
10278       IF(MSTP(131).NE.0) CALL PYOVLY(1)
10279
10280 C...Initialize multiple interactions with variable impact parameter.
10281       IF(MINT(43).EQ.4.AND.(MINT(45).NE.0.OR.MSTP(131).NE.0).AND.
10282      &MSTP(82).GE.2) CALL PYMULT(1)
10283 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)
10284
10285 C...Formats for initialization information.
10286  1000 FORMAT(///20X,'The Lund Monte Carlo - PYTHIA version ',I1,'.',I1/
10287      &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)
10288  1100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
10289      &'routines',1X,17('*'))
10290  1200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
10291      &'-',A6,' interactions.'/1X,'Execution stopped!')
10292  1300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
10293      &1X,'Execution stopped!')
10294  1400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
10295      &1X,'Execution stopped!')
10296  1500 FORMAT(1X,'Error: no subprocess switched on.'/
10297      &1X,'Execution stopped.')
10298  1600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
10299      &22('*'))
10300
10301       RETURN
10302       END
10303
10304 C*********************************************************************
10305
10306       SUBROUTINE PYTHIA
10307
10308 C...Administers the generation of a high-pt event via calls to a number
10309 C...of subroutines; also computes cross-sections.
10310       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10311       SAVE /LUJETS/
10312       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10313       SAVE /LUDAT1/
10314       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10315       SAVE /LUDAT2/
10316       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10317       SAVE /PYSUBS/
10318       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10319       SAVE /PYPARS/
10320       COMMON/PYINT1/MINT(400),VINT(400)
10321       SAVE /PYINT1/
10322       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
10323       SAVE /PYINT2/
10324       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
10325       SAVE /PYINT5/
10326
10327 C...Loop over desired number of overlayed events (normally 1).
10328       MINT(7)=0
10329       MINT(8)=0
10330       NOVL=1
10331       IF(MSTP(131).NE.0) CALL PYOVLY(2)
10332       IF(MSTP(131).NE.0) NOVL=MINT(81)
10333       MINT(83)=0
10334       MINT(84)=MSTP(126)
10335       MSTU(70)=0
10336       DO 190 IOVL=1,NOVL
10337       IF(MINT(84)+100.GE.MSTU(4)) THEN
10338         CALL LUERRM(11,
10339      &  '(PYTHIA:) no more space in LUJETS for overlayed events')
10340         IF(MSTU(21).GE.1) GOTO 200
10341       ENDIF
10342       MINT(82)=IOVL
10343
10344 C...Generate variables of hard scattering.
10345   100 CONTINUE
10346       IF(IOVL.EQ.1) NGEN(0,2)=NGEN(0,2)+1
10347       MINT(31)=0
10348       MINT(51)=0
10349       CALL PYRAND
10350       ISUB=MINT(1)
10351       IF(IOVL.EQ.1) THEN
10352         NGEN(ISUB,2)=NGEN(ISUB,2)+1
10353
10354 C...Store information on hard interaction.
10355         DO 110 J=1,200
10356         MSTI(J)=0
10357   110   PARI(J)=0.
10358         MSTI(1)=MINT(1)
10359         MSTI(2)=MINT(2)
10360         MSTI(11)=MINT(11)
10361         MSTI(12)=MINT(12)
10362         MSTI(15)=MINT(15)
10363         MSTI(16)=MINT(16)
10364         MSTI(17)=MINT(17)
10365         MSTI(18)=MINT(18)
10366         PARI(11)=VINT(1)
10367         PARI(12)=VINT(2)
10368         IF(ISUB.NE.95) THEN
10369           DO 120 J=13,22
10370   120     PARI(J)=VINT(30+J)
10371           PARI(33)=VINT(41)
10372           PARI(34)=VINT(42)
10373           PARI(35)=PARI(33)-PARI(34)
10374           PARI(36)=VINT(21)
10375           PARI(37)=VINT(22)
10376           PARI(38)=VINT(26)
10377           PARI(41)=VINT(23)
10378         ENDIF
10379       ENDIF
10380
10381       IF(MSTP(111).EQ.-1) GOTO 160
10382       IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
10383 C...Hard scattering (including low-pT):
10384 C...reconstruct kinematics and colour flow of hard scattering.
10385         CALL PYSCAT
10386         IF(MINT(51).EQ.1) GOTO 100
10387
10388 C...Showering of initial state partons (optional).
10389         IPU1=MINT(84)+1
10390         IPU2=MINT(84)+2
10391         IF(MSTP(61).GE.1.AND.MINT(43).NE.1.AND.ISUB.NE.95)
10392      &  CALL PYSSPA(IPU1,IPU2)
10393         NSAV1=N
10394
10395 C...Multiple interactions.
10396         IF(MSTP(81).GE.1.AND.MINT(43).EQ.4.AND.ISUB.NE.95)
10397      &  CALL PYMULT(6)
10398         MINT(1)=ISUB
10399         NSAV2=N
10400
10401 C...Hadron remnants and primordial kT.
10402         CALL PYREMN(IPU1,IPU2)
10403         IF(MINT(51).EQ.1) GOTO 100
10404         NSAV3=N
10405
10406 C...Showering of final state partons (optional).
10407         IPU3=MINT(84)+3
10408         IPU4=MINT(84)+4
10409         IF(MSTP(71).GE.1.AND.ISUB.NE.95.AND.K(IPU3,1).GT.0.AND.
10410      &  K(IPU3,1).LE.10.AND.K(IPU4,1).GT.0.AND.K(IPU4,1).LE.10) THEN
10411           QMAX=SQRT(PARP(71)*VINT(52))
10412           IF(ISUB.EQ.5) QMAX=SQRT(PMAS(23,1)**2)
10413           IF(ISUB.EQ.8) QMAX=SQRT(PMAS(24,1)**2)
10414           CALL LUSHOW(IPU3,IPU4,QMAX)
10415         ENDIF
10416
10417 C...Sum up transverse and longitudinal momenta.
10418         IF(IOVL.EQ.1) THEN
10419           PARI(65)=2.*PARI(17)
10420           DO 130 I=MSTP(126)+1,N
10421           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
10422           PT=SQRT(P(I,1)**2+P(I,2)**2)
10423           PARI(69)=PARI(69)+PT
10424           IF(I.LE.NSAV1.OR.I.GT.NSAV3) PARI(66)=PARI(66)+PT
10425           IF(I.GT.NSAV1.AND.I.LE.NSAV2) PARI(68)=PARI(68)+PT
10426   130     CONTINUE
10427           PARI(67)=PARI(68)
10428           PARI(71)=VINT(151)
10429           PARI(72)=VINT(152)
10430           PARI(73)=VINT(151)
10431           PARI(74)=VINT(152)
10432         ENDIF
10433
10434 C...Decay of final state resonances.
10435         IF(MSTP(41).GE.1.AND.ISUB.NE.95) CALL PYRESD
10436
10437       ELSE
10438 C...Diffractive and elastic scattering.
10439         CALL PYDIFF
10440         IF(IOVL.EQ.1) THEN
10441           PARI(65)=2.*PARI(17)
10442           PARI(66)=PARI(65)
10443           PARI(69)=PARI(65)
10444         ENDIF
10445       ENDIF
10446
10447 C...Recalculate energies from momenta and masses (if desired).
10448       IF(MSTP(113).GE.1) THEN
10449         DO 140 I=MINT(83)+1,N
10450   140   IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
10451      &  P(I,2)**2+P(I,3)**2+P(I,5)**2)
10452       ENDIF
10453
10454 C...Rearrange partons along strings, check invariant mass cuts.
10455       MSTU(28)=0
10456       CALL LUPREP(MINT(84)+1)
10457       IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
10458       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
10459         DO 150 I=MINT(84)+1,N
10460         IF(K(I,2).NE.94) GOTO 150
10461         K(I+1,3)=MOD(K(I+1,4)/MSTU(5),MSTU(5))
10462         K(I+2,3)=MOD(K(I+2,4)/MSTU(5),MSTU(5))
10463   150   CONTINUE
10464         CALL LUEDIT(12)
10465         CALL LUEDIT(14)
10466         IF(MSTP(125).EQ.0) CALL LUEDIT(15)
10467         IF(MSTP(125).EQ.0) MINT(4)=0
10468       ENDIF
10469
10470 C...Introduce separators between sections in LULIST event listing.
10471       IF(IOVL.EQ.1.AND.MSTP(125).LE.0) THEN
10472         MSTU(70)=1
10473         MSTU(71)=N
10474       ELSEIF(IOVL.EQ.1) THEN
10475         MSTU(70)=3
10476         MSTU(71)=2
10477         MSTU(72)=MINT(4)
10478         MSTU(73)=N
10479       ENDIF
10480
10481 C...Perform hadronization (if desired).
10482       IF(MSTP(111).GE.1) CALL LUEXEC
10483       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL LUEDIT(14)
10484
10485 C...Calculate Monte Carlo estimates of cross-sections.
10486   160 IF(IOVL.EQ.1) THEN
10487         IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
10488         NGEN(0,3)=NGEN(0,3)+1
10489         XSEC(0,3)=0.
10490         DO 170 I=1,200
10491         IF(I.EQ.96) THEN
10492           XSEC(I,3)=0.
10493         ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
10494      &  I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
10495           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1.,FLOAT(NGEN(96,1))*
10496      &    FLOAT(NGEN(96,2)))
10497         ELSEIF(NGEN(I,1).EQ.0) THEN
10498           XSEC(I,3)=0.
10499         ELSEIF(NGEN(I,2).EQ.0) THEN
10500           XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(FLOAT(NGEN(I,1))*
10501      &    FLOAT(NGEN(0,2)))
10502         ELSE
10503           XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(FLOAT(NGEN(I,1))*
10504      &    FLOAT(NGEN(I,2)))
10505         ENDIF
10506   170   XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
10507         IF(MSUB(95).EQ.1) THEN
10508           NGENS=NGEN(91,3)+NGEN(92,3)+NGEN(93,3)+NGEN(94,3)+NGEN(95,3)
10509           XSECS=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+XSEC(95,3)
10510           XMAXS=XSEC(95,1)
10511           IF(MSUB(91).EQ.1) XMAXS=XMAXS+XSEC(91,1)
10512           IF(MSUB(92).EQ.1) XMAXS=XMAXS+XSEC(92,1)
10513           IF(MSUB(93).EQ.1) XMAXS=XMAXS+XSEC(93,1)
10514           IF(MSUB(94).EQ.1) XMAXS=XMAXS+XSEC(94,1)
10515           FAC=1.
10516           IF(NGENS.LT.NGEN(0,3)) FAC=(XMAXS-XSECS)/(XSEC(0,3)-XSECS)
10517           XSEC(11,3)=FAC*XSEC(11,3)
10518           XSEC(12,3)=FAC*XSEC(12,3)
10519           XSEC(13,3)=FAC*XSEC(13,3)
10520           XSEC(28,3)=FAC*XSEC(28,3)
10521           XSEC(53,3)=FAC*XSEC(53,3)
10522           XSEC(68,3)=FAC*XSEC(68,3)
10523           XSEC(0,3)=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+
10524      &    XSEC(95,1)
10525         ENDIF
10526
10527 C...Store final information.
10528         MINT(5)=MINT(5)+1
10529         MSTI(3)=MINT(3)
10530         MSTI(4)=MINT(4)
10531         MSTI(5)=MINT(5)
10532         MSTI(6)=MINT(6)
10533         MSTI(7)=MINT(7)
10534         MSTI(8)=MINT(8)
10535         MSTI(13)=MINT(13)
10536         MSTI(14)=MINT(14)
10537         MSTI(21)=MINT(21)
10538         MSTI(22)=MINT(22)
10539         MSTI(23)=MINT(23)
10540         MSTI(24)=MINT(24)
10541         MSTI(25)=MINT(25)
10542         MSTI(26)=MINT(26)
10543         MSTI(31)=MINT(31)
10544         PARI(1)=XSEC(0,3)
10545         PARI(2)=XSEC(0,3)/MINT(5)
10546         PARI(31)=VINT(141)
10547         PARI(32)=VINT(142)
10548         IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
10549           PARI(42)=2.*VINT(47)/VINT(1)
10550           DO 180 IS=7,8
10551           PARI(36+IS)=P(MINT(IS),3)/VINT(1)
10552           PARI(38+IS)=P(MINT(IS),4)/VINT(1)
10553           I=MINT(IS)
10554           PR=MAX(1E-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
10555           PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
10556      &    SQRT(PR),1E20)),P(I,3))
10557           PR=MAX(1E-20,P(I,1)**2+P(I,2)**2)
10558           PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
10559      &    SQRT(PR),1E20)),P(I,3))
10560           PARI(44+IS)=P(I,3)/SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
10561           PARI(46+IS)=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
10562           PARI(48+IS)=ULANGL(P(I,1),P(I,2))
10563   180     CONTINUE
10564         ENDIF
10565         PARI(61)=VINT(148)
10566         IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
10567           MSTU(161)=MINT(21)
10568           MSTU(162)=0
10569         ELSE
10570           MSTU(161)=MINT(21)
10571           MSTU(162)=MINT(22)
10572         ENDIF
10573       ENDIF
10574
10575 C...Prepare to go to next overlayed event.
10576       MSTI(41)=IOVL
10577       IF(IOVL.GE.2.AND.IOVL.LE.10) MSTI(40+IOVL)=ISUB
10578       IF(MSTU(70).LT.10) THEN
10579         MSTU(70)=MSTU(70)+1
10580         MSTU(70+MSTU(70))=N
10581       ENDIF
10582       MINT(83)=N
10583       MINT(84)=N+MSTP(126)
10584   190 CONTINUE
10585
10586 C...Information on overlayed events.
10587       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
10588         PARI(91)=VINT(132)
10589         PARI(92)=VINT(133)
10590         PARI(93)=VINT(134)
10591         IF(MSTP(133).EQ.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
10592       ENDIF
10593
10594 C...Transform to the desired coordinate frame.
10595   200 CALL PYFRAM(MSTP(124))
10596
10597       RETURN
10598       END
10599
10600 C***********************************************************************
10601
10602       SUBROUTINE PYSTAT(MSTAT)
10603
10604 C...Prints out information about cross-sections, decay widths, branching
10605 C...ratios, kinematical limits, status codes and parameter values.
10606       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10607       SAVE /LUDAT1/
10608       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10609       SAVE /LUDAT2/
10610       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10611       SAVE /LUDAT3/
10612       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10613       SAVE /PYSUBS/
10614       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10615       SAVE /PYPARS/
10616       COMMON/PYINT1/MINT(400),VINT(400)
10617       SAVE /PYINT1/
10618       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
10619       SAVE /PYINT4/
10620       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
10621       SAVE /PYINT5/
10622       COMMON/PYINT6/PROC(0:200)
10623       CHARACTER PROC*28
10624       SAVE /PYINT6/
10625       CHARACTER CHAU*16,CHPA(-40:40)*12,CHIN(2)*12,
10626      &STATE(-1:5)*4,CHKIN(21)*18
10627       DATA STATE/'----','off ','on  ','on/+','on/-','on/1','on/2'/,
10628      &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
10629      &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',
10630      &'     y*_small     ','    eta*_large    ','    eta*_small    ',
10631      &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',
10632      &'       x_2        ','       x_F        ',' cos(theta_hard)  ',
10633      &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',
10634      &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',
10635      &'       tau''       '/
10636
10637 C...Cross-sections.
10638       IF(MSTAT.LE.1) THEN
10639         WRITE(MSTU(11),1000)
10640         WRITE(MSTU(11),1100)
10641         WRITE(MSTU(11),1200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
10642         DO 100 I=1,200
10643         IF(MSUB(I).NE.1) GOTO 100
10644         WRITE(MSTU(11),1200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
10645   100   CONTINUE
10646         WRITE(MSTU(11),1300) 1.-FLOAT(NGEN(0,3))/
10647      &  MAX(1.,FLOAT(NGEN(0,2)))
10648
10649 C...Decay widths and branching ratios.
10650       ELSEIF(MSTAT.EQ.2) THEN
10651         DO 110 KF=-40,40
10652         CALL LUNAME(KF,CHAU)
10653   110   CHPA(KF)=CHAU(1:12)
10654         WRITE(MSTU(11),1400)
10655         WRITE(MSTU(11),1500)
10656 C...Off-shell branchings.
10657         DO 130 I=1,17
10658         KC=I
10659         IF(I.GE.9) KC=I+2
10660         IF(I.EQ.17) KC=21
10661         WRITE(MSTU(11),1600) CHPA(KC),0.,0.,STATE(MDCY(KC,1)),0.
10662         DO 120 J=1,MDCY(KC,3)
10663         IDC=J+MDCY(KC,2)-1
10664   120   IF(MDME(IDC,2).EQ.102) WRITE(MSTU(11),1700) CHPA(KFDP(IDC,1)),
10665      &  CHPA(KFDP(IDC,2)),0.,0.,STATE(MDME(IDC,1)),0.
10666   130   CONTINUE
10667 C...On-shell decays.
10668         DO 150 I=1,6
10669         KC=I+22
10670         IF(I.EQ.4) KC=32
10671         IF(I.EQ.5) KC=37
10672         IF(I.EQ.6) KC=40
10673         IF(WIDE(KC,0).GT.0.) THEN
10674           WRITE(MSTU(11),1600) CHPA(KC),WIDP(KC,0),1.,
10675      &    STATE(MDCY(KC,1)),1.
10676           DO 140 J=1,MDCY(KC,3)
10677           IDC=J+MDCY(KC,2)-1
10678   140     WRITE(MSTU(11),1700) CHPA(KFDP(IDC,1)),CHPA(KFDP(IDC,2)),
10679      &    WIDP(KC,J),WIDP(KC,J)/WIDP(KC,0),STATE(MDME(IDC,1)),
10680      &    WIDE(KC,J)/WIDE(KC,0)
10681         ELSE
10682           WRITE(MSTU(11),1600) CHPA(KC),WIDP(KC,0),1.,
10683      &    STATE(MDCY(KC,1)),0.
10684         ENDIF
10685   150   CONTINUE
10686         WRITE(MSTU(11),1800)
10687
10688 C...Allowed incoming partons/particles at hard interaction.
10689       ELSEIF(MSTAT.EQ.3) THEN
10690         WRITE(MSTU(11),1900)
10691         CALL LUNAME(MINT(11),CHAU)
10692         CHIN(1)=CHAU(1:12)
10693         CALL LUNAME(MINT(12),CHAU)
10694         CHIN(2)=CHAU(1:12)
10695         WRITE(MSTU(11),2000) CHIN(1),CHIN(2)
10696         DO 160 KF=-40,40
10697         CALL LUNAME(KF,CHAU)
10698   160   CHPA(KF)=CHAU(1:12)
10699         IF(MINT(43).EQ.1) THEN
10700           WRITE(MSTU(11),2100) CHPA(MINT(11)),STATE(KFIN(1,MINT(11))),
10701      &    CHPA(MINT(12)),STATE(KFIN(2,MINT(12)))
10702         ELSEIF(MINT(43).EQ.2) THEN
10703           WRITE(MSTU(11),2100) CHPA(MINT(11)),STATE(KFIN(1,MINT(11))),
10704      &    CHPA(-MSTP(54)),STATE(KFIN(2,-MSTP(54)))
10705           DO 170 I=-MSTP(54)+1,-1
10706   170     WRITE(MSTU(11),2200) CHPA(I),STATE(KFIN(2,I))
10707           DO 180 I=1,MSTP(54)
10708   180     WRITE(MSTU(11),2200) CHPA(I),STATE(KFIN(2,I))
10709           WRITE(MSTU(11),2200) CHPA(21),STATE(KFIN(2,21))
10710         ELSEIF(MINT(43).EQ.3) THEN
10711           WRITE(MSTU(11),2100) CHPA(-MSTP(54)),STATE(KFIN(1,-MSTP(54))),
10712      &    CHPA(MINT(12)),STATE(KFIN(2,MINT(12)))
10713           DO 190 I=-MSTP(54)+1,-1
10714   190     WRITE(MSTU(11),2300) CHPA(I),STATE(KFIN(1,I))
10715           DO 200 I=1,MSTP(54)
10716   200     WRITE(MSTU(11),2300) CHPA(I),STATE(KFIN(1,I))
10717           WRITE(MSTU(11),2300) CHPA(21),STATE(KFIN(1,21))
10718         ELSEIF(MINT(43).EQ.4) THEN
10719           DO 210 I=-MSTP(54),-1
10720   210     WRITE(MSTU(11),2100) CHPA(I),STATE(KFIN(1,I)),CHPA(I),
10721      &    STATE(KFIN(2,I))
10722           DO 220 I=1,MSTP(54)
10723   220     WRITE(MSTU(11),2100) CHPA(I),STATE(KFIN(1,I)),CHPA(I),
10724      &    STATE(KFIN(2,I))
10725           WRITE(MSTU(11),2100) CHPA(21),STATE(KFIN(1,21)),CHPA(21),
10726      &    STATE(KFIN(2,21))
10727         ENDIF
10728         WRITE(MSTU(11),2400)
10729
10730 C...User-defined and derived limits on kinematical variables.
10731       ELSEIF(MSTAT.EQ.4) THEN
10732         WRITE(MSTU(11),2500)
10733         WRITE(MSTU(11),2600)
10734         SHRMAX=CKIN(2)
10735         IF(SHRMAX.LT.0.) SHRMAX=VINT(1)
10736         WRITE(MSTU(11),2700) CKIN(1),CHKIN(1),SHRMAX
10737         PTHMIN=MAX(CKIN(3),CKIN(5))
10738         PTHMAX=CKIN(4)
10739         IF(PTHMAX.LT.0.) PTHMAX=0.5*SHRMAX
10740         WRITE(MSTU(11),2800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
10741         WRITE(MSTU(11),2900) CHKIN(3),CKIN(6)
10742         DO 230 I=4,14
10743   230   WRITE(MSTU(11),2700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
10744         SPRMAX=CKIN(32)
10745         IF(SPRMAX.LT.0.) SPRMAX=VINT(1)
10746         WRITE(MSTU(11),2700) CKIN(31),CHKIN(13),SPRMAX
10747         WRITE(MSTU(11),3000)
10748         WRITE(MSTU(11),3100)
10749         WRITE(MSTU(11),2600)
10750         DO 240 I=16,21
10751   240   WRITE(MSTU(11),2700) VINT(I-5),CHKIN(I),VINT(I+15)
10752         WRITE(MSTU(11),3000)
10753
10754 C...Status codes and parameter values.
10755       ELSEIF(MSTAT.EQ.5) THEN
10756         WRITE(MSTU(11),3200)
10757         WRITE(MSTU(11),3300)
10758         DO 250 I=1,100
10759   250   WRITE(MSTU(11),3400) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
10760      &  PARP(100+I)
10761       ENDIF
10762
10763 C...Formats for printouts.
10764  1000 FORMAT('1',9('*'),1X,'PYSTAT:  Statistics on Number of ',
10765      &'Events and Cross-sections',1X,9('*'))
10766  1100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
10767      &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
10768      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
10769      &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
10770      &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
10771      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
10772      &'I',12X,'I')
10773  1200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
10774      &E10.3,1X,'I')
10775  1300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
10776      &1X,'********* Fraction of events that fail fragmentation ',
10777      &'cuts =',1X,F8.5,' *********'/)
10778  1400 FORMAT('1',17('*'),1X,'PYSTAT:  Decay Widths and Branching ',
10779      &'Ratios',1X,17('*'))
10780  1500 FORMAT(/1X,78('=')/1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
10781      &1X,'I',1X,'Branching/Decay Channel',5X,'I',1X,'Width (GeV)',1X,
10782      &'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,'Eff. B.R.',1X,'I'/1X,
10783      &'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,78('='))
10784  1600 FORMAT(1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
10785      &A12,1X,'->',13X,'I',2X,1P,E10.3,0P,1X,'I',1X,1P,E10.3,0P,1X,'I',
10786      &1X,A4,1X,'I',1X,1P,E10.3,0P,1X,'I')
10787  1700 FORMAT(1X,'I',1X,A12,1X,'+',1X,A12,1X,'I',2X,1P,E10.3,0P,1X,'I',
10788      &1X,1P,E10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,E10.3,0P,1X,'I')
10789  1800 FORMAT(1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,78('='))
10790  1900 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
10791      &'Particles at Hard Interaction',1X,7('*'))
10792  2000 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
10793      &'Beam particle:',1X,A,10X,'I',1X,'Target particle:',1X,A,7X,
10794      &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',9X,'State',16X,
10795      &'I',1X,'Content',9X,'State',15X,'I'/1X,'I',38X,'I',37X,'I'/1X,
10796      &78('=')/1X,'I',38X,'I',37X,'I')
10797  2100 FORMAT(1X,'I',1X,A,5X,A,16X,'I',1X,A,5X,A,15X,'I')
10798  2200 FORMAT(1X,'I',38X,'I',1X,A,5X,A,15X,'I')
10799  2300 FORMAT(1X,'I',1X,A,5X,A,16X,'I',37X,'I')
10800  2400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
10801  2500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
10802      &'Kinematical Variables',1X,12('*'))
10803  2600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
10804  2700 FORMAT(1X,'I',16X,1P,E10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,E10.3,0P,
10805      &16X,'I')
10806  2800 FORMAT(1X,'I',3X,1P,E10.3,0P,1X,'(',1P,E10.3,0P,')',1X,'<',1X,A,
10807      &1X,'<',1X,1P,E10.3,0P,16X,'I')
10808  2900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,E10.3,0P,16X,'I')
10809  3000 FORMAT(1X,'I',76X,'I'/1X,78('='))
10810  3100 FORMAT(////1X,5('*'),1X,'PYSTAT: Derived Limits on Kinematical ',
10811      &'Variables Used in Generation',1X,5('*'))
10812  3200 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
10813      &'Parameter Values',1X,12('*'))
10814  3300 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
10815      &'PARP(I)'/)
10816  3400 FORMAT(1X,I3,5X,I6,6X,1P,E10.3,0P,18X,I3,5X,I6,6X,1P,E10.3)
10817
10818       RETURN
10819       END
10820
10821 C*********************************************************************
10822
10823       SUBROUTINE PYINKI(CHFRAM,CHBEAM,CHTARG,WIN)
10824
10825 C...Identifies the two incoming particles and sets up kinematics,
10826 C...including rotations and boosts to/from CM frame.
10827       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10828       SAVE /LUJETS/
10829       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10830       SAVE /LUDAT1/
10831       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10832       SAVE /PYSUBS/
10833       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10834       SAVE /PYPARS/
10835       COMMON/PYINT1/MINT(400),VINT(400)
10836       SAVE /PYINT1/
10837       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
10838      &CHIDNT(3)*8,CHTEMP*8,CHCDE(18)*8,CHINIT*76
10839       DIMENSION LEN(3),KCDE(18)
10840       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
10841      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
10842       DATA CHCDE/'e-      ','e+      ','nue     ','nue~    ',
10843      &'mu-     ','mu+     ','numu    ','numu~   ','tau-    ',
10844      &'tau+    ','nutau   ','nutau~  ','pi+     ','pi-     ',
10845      &'n       ','n~      ','p       ','p~      '/
10846       DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
10847      &211,-211,2112,-2112,2212,-2212/
10848
10849 C...Convert character variables to lowercase and find their length.
10850       CHCOM(1)=CHFRAM
10851       CHCOM(2)=CHBEAM
10852       CHCOM(3)=CHTARG
10853       DO 120 I=1,3
10854       LEN(I)=8
10855       DO 100 LL=8,1,-1
10856       IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
10857       DO 100 LA=1,26
10858   100 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
10859      &CHALP(1)(LA:LA)
10860       CHIDNT(I)=CHCOM(I)
10861       DO 110 LL=1,6
10862       IF(CHIDNT(I)(LL:LL+2).EQ.'bar') THEN
10863         CHTEMP=CHIDNT(I)
10864         CHIDNT(I)=CHTEMP(1:LL-1)//'~'//CHTEMP(LL+3:8)//'  '
10865       ENDIF
10866   110 CONTINUE
10867       DO 120 LL=1,8
10868       IF(CHIDNT(I)(LL:LL).EQ.'_') THEN
10869         CHTEMP=CHIDNT(I)
10870         CHIDNT(I)=CHTEMP(1:LL-1)//CHTEMP(LL+1:8)//' '
10871       ENDIF
10872   120 CONTINUE
10873
10874 C...Set initial state. Error for unknown codes. Reset variables.
10875       N=2
10876       DO 140 I=1,2
10877       K(I,2)=0
10878       DO 130 J=1,18
10879   130 IF(CHIDNT(I+1).EQ.CHCDE(J)) K(I,2)=KCDE(J)
10880       P(I,5)=ULMASS(K(I,2))
10881       MINT(40+I)=1
10882       IF(IABS(K(I,2)).GT.100) MINT(40+I)=2
10883       DO 140 J=1,5
10884   140 V(I,J)=0.
10885       IF(K(1,2).EQ.0) WRITE(MSTU(11),1000) CHBEAM(1:LEN(2))
10886       IF(K(2,2).EQ.0) WRITE(MSTU(11),1100) CHTARG(1:LEN(3))
10887       IF(K(1,2).EQ.0.OR.K(2,2).EQ.0) STOP
10888       DO 150 J=6,10
10889   150 VINT(J)=0.
10890       CHINIT=' '
10891
10892 C...Set up kinematics for events defined in CM frame.
10893       IF(CHCOM(1)(1:2).EQ.'cm') THEN
10894         IF(CHCOM(2)(1:1).NE.'e') THEN
10895           LOFFS=(34-(LEN(2)+LEN(3)))/2
10896           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
10897      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
10898         ELSE
10899           LOFFS=(33-(LEN(2)+LEN(3)))/2
10900           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
10901      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
10902         ENDIF
10903 C        WRITE(MSTU(11),1200) CHINIT
10904 C        WRITE(MSTU(11),1300) WIN
10905         S=WIN**2
10906         P(1,1)=0.
10907         P(1,2)=0.
10908         P(2,1)=0.
10909         P(2,2)=0.
10910         P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2.*P(1,5)*P(2,5))**2)/
10911      &  (4.*S))
10912         P(2,3)=-P(1,3)
10913         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
10914         P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
10915
10916 C...Set up kinematics for fixed target events.
10917       ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
10918         LOFFS=(29-(LEN(2)+LEN(3)))/2
10919         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
10920      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
10921      &  ' fixed target'//' '
10922 C        WRITE(MSTU(11),1200) CHINIT
10923 C        WRITE(MSTU(11),1400) WIN
10924         P(1,1)=0.
10925         P(1,2)=0.
10926         P(2,1)=0.
10927         P(2,2)=0.
10928         P(1,3)=WIN
10929         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
10930         P(2,3)=0.
10931         P(2,4)=P(2,5)
10932         S=P(1,5)**2+P(2,5)**2+2.*P(2,4)*P(1,4)
10933         VINT(10)=P(1,3)/(P(1,4)+P(2,4))
10934         CALL LUROBO(0.,0.,0.,0.,-VINT(10))
10935 C        WRITE(MSTU(11),1500) SQRT(S)
10936
10937 C...Set up kinematics for events in user-defined frame.
10938       ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
10939         LOFFS=(13-(LEN(1)+LEN(2)))/2
10940         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
10941      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
10942      &  'user-specified configuration'//' '
10943 C        WRITE(MSTU(11),1200) CHINIT
10944 C        WRITE(MSTU(11),1600)
10945 C        WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)
10946 C        WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)
10947         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
10948         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
10949         DO 160 J=1,3
10950   160   VINT(7+J)=(DBLE(P(1,J))+DBLE(P(2,J)))/DBLE(P(1,4)+P(2,4))
10951         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
10952         VINT(7)=ULANGL(P(1,1),P(1,2))
10953         CALL LUROBO(0.,-VINT(7),0.,0.,0.)
10954         VINT(6)=ULANGL(P(1,3),P(1,1))
10955         CALL LUROBO(-VINT(6),0.,0.,0.,0.)
10956         S=P(1,5)**2+P(2,5)**2+2.*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
10957 C        WRITE(MSTU(11),1500) SQRT(S)
10958
10959 C...Unknown frame. Error for too low CM energy.
10960       ELSE
10961         WRITE(MSTU(11),1800) CHFRAM(1:LEN(1))
10962         STOP
10963       ENDIF
10964       IF(S.LT.PARP(2)**2) THEN
10965         WRITE(MSTU(11),1900) SQRT(S)
10966         STOP
10967       ENDIF
10968
10969 C...Save information on incoming particles.
10970       MINT(11)=K(1,2)
10971       MINT(12)=K(2,2)
10972       MINT(43)=2*MINT(41)+MINT(42)-2
10973       VINT(1)=SQRT(S)
10974       VINT(2)=S
10975       VINT(3)=P(1,5)
10976       VINT(4)=P(2,5)
10977       VINT(5)=P(1,3)
10978
10979 C...Store constants to be used in generation.
10980       IF(MSTP(82).LE.1) VINT(149)=4.*PARP(81)**2/S
10981       IF(MSTP(82).GE.2) VINT(149)=4.*PARP(82)**2/S
10982
10983 C...Formats for initialization and error information.
10984  1000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''.'/
10985      &1X,'Execution stopped!')
10986  1100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''.'/
10987      &1X,'Execution stopped!')
10988  1200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
10989  1300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
10990      &19X,'I'/1X,'I',76X,'I'/1X,78('='))
10991  1400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
10992  1500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
10993      &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
10994  1600 FORMAT(1X,'I',76X,'I'/1X,'I',24X,'px (GeV/c)',3X,'py (GeV/c)',3X,
10995      &'pz (GeV/c)',16X,'I')
10996  1700 FORMAT(1X,'I',15X,A8,3(2X,F10.3,1X),15X,'I')
10997  1800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''.'/
10998      &1X,'Execution stopped!')
10999  1900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
11000      &'generation.'/1X,'Execution stopped!')
11001
11002       RETURN
11003       END
11004
11005 C*********************************************************************
11006
11007       SUBROUTINE PYINRE
11008
11009 C...Calculates full and effective widths of guage bosons, stores masses
11010 C...and widths, rescales coefficients to be used for resonance
11011 C...production generation.
11012       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11013       SAVE /LUDAT1/
11014       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11015       SAVE /LUDAT2/
11016       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
11017       SAVE /LUDAT3/
11018       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11019       SAVE /PYSUBS/
11020       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11021       SAVE /PYPARS/
11022       COMMON/PYINT1/MINT(400),VINT(400)
11023       SAVE /PYINT1/
11024       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11025       SAVE /PYINT2/
11026       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11027       SAVE /PYINT4/
11028       COMMON/PYINT6/PROC(0:200)
11029       CHARACTER PROC*28
11030       SAVE /PYINT6/
11031       DIMENSION WDTP(0:40),WDTE(0:40,0:5)
11032
11033 C...Calculate full and effective widths of gauge bosons.
11034       AEM=PARU(101)
11035       XW=PARU(102)
11036       DO 100 I=21,40
11037       DO 100 J=0,40
11038       WIDP(I,J)=0.
11039   100 WIDE(I,J)=0.
11040
11041 C...W+/-:
11042       WMAS=PMAS(24,1)
11043       WFAC=AEM/(24.*XW)*WMAS
11044       CALL PYWIDT(24,WMAS,WDTP,WDTE)
11045       WIDS(24,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
11046      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
11047      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
11048       WIDS(24,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
11049       WIDS(24,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
11050       DO 110 I=0,40
11051       WIDP(24,I)=WFAC*WDTP(I)
11052   110 WIDE(24,I)=WFAC*WDTE(I,0)
11053
11054 C...H+/-:
11055       HCMAS=PMAS(37,1)
11056       HCFAC=AEM/(8.*XW)*(HCMAS/WMAS)**2*HCMAS
11057       CALL PYWIDT(37,HCMAS,WDTP,WDTE)
11058       WIDS(37,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
11059      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
11060      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
11061       WIDS(37,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
11062       WIDS(37,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
11063       DO 120 I=0,40
11064       WIDP(37,I)=HCFAC*WDTP(I)
11065   120 WIDE(37,I)=HCFAC*WDTE(I,0)
11066
11067 C...Z0:
11068       ZMAS=PMAS(23,1)
11069       ZFAC=AEM/(48.*XW*(1.-XW))*ZMAS
11070       CALL PYWIDT(23,ZMAS,WDTP,WDTE)
11071       WIDS(23,1)=((WDTE(0,1)+WDTE(0,2))**2+
11072      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
11073      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
11074       WIDS(23,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
11075       WIDS(23,3)=0.
11076       DO 130 I=0,40
11077       WIDP(23,I)=ZFAC*WDTP(I)
11078   130 WIDE(23,I)=ZFAC*WDTE(I,0)
11079
11080 C...H0:
11081       HMAS=PMAS(25,1)
11082       HFAC=AEM/(8.*XW)*(HMAS/WMAS)**2*HMAS
11083       CALL PYWIDT(25,HMAS,WDTP,WDTE)
11084       WIDS(25,1)=((WDTE(0,1)+WDTE(0,2))**2+
11085      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
11086      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
11087       WIDS(25,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
11088       WIDS(25,3)=0.
11089       DO 140 I=0,40
11090       WIDP(25,I)=HFAC*WDTP(I)
11091   140 WIDE(25,I)=HFAC*WDTE(I,0)
11092
11093 C...Z'0:
11094       ZPMAS=PMAS(32,1)
11095       ZPFAC=AEM/(48.*XW*(1.-XW))*ZPMAS
11096       CALL PYWIDT(32,ZPMAS,WDTP,WDTE)
11097       WIDS(32,1)=((WDTE(0,1)+WDTE(0,2)+WDTE(0,3))**2+
11098      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
11099      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
11100       WIDS(32,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
11101       WIDS(32,3)=0.
11102       DO 150 I=0,40
11103       WIDP(32,I)=ZPFAC*WDTP(I)
11104   150 WIDE(32,I)=ZPFAC*WDTE(I,0)
11105
11106 C...R:
11107       RMAS=PMAS(40,1)
11108       RFAC=0.08*RMAS/((MSTP(1)-1)*(1.+6.*(1.+ULALPS(RMAS**2)/PARU(1))))
11109       CALL PYWIDT(40,RMAS,WDTP,WDTE)
11110       WIDS(40,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
11111      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
11112      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
11113       WIDS(40,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
11114       WIDS(40,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
11115       DO 160 I=0,40
11116       WIDP(40,I)=WFAC*WDTP(I)
11117   160 WIDE(40,I)=WFAC*WDTE(I,0)
11118
11119 C...Q:
11120       KFLQM=1
11121       DO 170 I=1,MIN(8,MDCY(21,3))
11122       IDC=I+MDCY(21,2)-1
11123       IF(MDME(IDC,1).LE.0) GOTO 170
11124       KFLQM=I
11125   170 CONTINUE
11126       MINT(46)=KFLQM
11127       KFPR(81,1)=KFLQM
11128       KFPR(81,2)=KFLQM
11129       KFPR(82,1)=KFLQM
11130       KFPR(82,2)=KFLQM
11131
11132 C...Set resonance widths and branching ratios in JETSET.
11133       DO 180 I=1,6
11134       IF(I.LE.3) KC=I+22
11135       IF(I.EQ.4) KC=32
11136       IF(I.EQ.5) KC=37
11137       IF(I.EQ.6) KC=40
11138       PMAS(KC,2)=WIDP(KC,0)
11139       PMAS(KC,3)=MIN(0.9*PMAS(KC,1),10.*PMAS(KC,2))
11140       DO 180 J=1,MDCY(KC,3)
11141       IDC=J+MDCY(KC,2)-1
11142       BRAT(IDC)=WIDE(KC,J)/WIDE(KC,0)
11143   180 CONTINUE
11144
11145 C...Special cases in treatment of gamma*/Z0: redefine process name.
11146       IF(MSTP(43).EQ.1) THEN
11147         PROC(1)='f + fb -> gamma*'
11148       ELSEIF(MSTP(43).EQ.2) THEN
11149         PROC(1)='f + fb -> Z0'
11150       ELSEIF(MSTP(43).EQ.3) THEN
11151         PROC(1)='f + fb -> gamma*/Z0'
11152       ENDIF
11153
11154 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
11155       IF(MSTP(44).EQ.1) THEN
11156         PROC(141)='f + fb -> gamma*'
11157       ELSEIF(MSTP(44).EQ.2) THEN
11158         PROC(141)='f + fb -> Z0'
11159       ELSEIF(MSTP(44).EQ.3) THEN
11160         PROC(141)='f + fb -> Z''0'
11161       ELSEIF(MSTP(44).EQ.4) THEN
11162         PROC(141)='f + fb -> gamma*/Z0'
11163       ELSEIF(MSTP(44).EQ.5) THEN
11164         PROC(141)='f + fb -> gamma*/Z''0'
11165       ELSEIF(MSTP(44).EQ.6) THEN
11166         PROC(141)='f + fb -> Z0/Z''0'
11167       ELSEIF(MSTP(44).EQ.7) THEN
11168         PROC(141)='f + fb -> gamma*/Z0/Z''0'
11169       ENDIF
11170
11171       RETURN
11172       END
11173
11174 C*********************************************************************
11175
11176       SUBROUTINE PYXTOT
11177
11178 C...Parametrizes total, double diffractive, single diffractive and
11179 C...elastic cross-sections for different energies and beams.
11180       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11181       SAVE /LUDAT1/
11182       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11183       SAVE /PYPARS/
11184       COMMON/PYINT1/MINT(400),VINT(400)
11185       SAVE /PYINT1/
11186       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
11187       SAVE /PYINT5/
11188       DIMENSION BCS(5,8),BCB(2,5),BCC(3)
11189
11190 C...The following data lines are coefficients needed in the
11191 C...Block, Cahn parametrization of total cross-section and nuclear
11192 C...slope parameter; see below.
11193       DATA ((BCS(I,J),J=1,8),I=1,5)/
11194      1 41.74, 0.66, 0.0000, 337.,  0.0, 0.0, -39.3, 0.48,
11195      2 41.66, 0.60, 0.0000, 306.,  0.0, 0.0, -34.6, 0.51,
11196      3 41.36, 0.63, 0.0000, 299.,  7.3, 0.5, -40.4, 0.47,
11197      4 41.68, 0.63, 0.0083, 330.,  0.0, 0.0, -39.0, 0.48,
11198      5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/
11199       DATA ((BCB(I,J),J=1,5),I=1,2)/
11200      1 10.79, -0.049, 0.040, 21.5, 1.23,
11201      2  9.92, -0.027, 0.013, 18.9, 1.07/
11202       DATA BCC/2.0164346,-0.5590311,0.0376279/
11203
11204 C...Total cross-section and nuclear slope parameter for pp and p-pbar
11205       NFIT=MIN(5,MAX(1,MSTP(31)))
11206       SIGP=BCS(NFIT,1)+BCS(NFIT,2)*(-0.25*PARU(1)**2*
11207      &(1.-0.25*BCS(NFIT,3)*PARU(1)**2)+(1.+0.5*BCS(NFIT,3)*PARU(1)**2)*
11208      &(LOG(VINT(2)/BCS(NFIT,4)))**2+BCS(NFIT,3)*
11209      &(LOG(VINT(2)/BCS(NFIT,4)))**4)/
11210      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
11211      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)*(LOG(VINT(2)/BCS(NFIT,4)))**2+
11212      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)+BCS(NFIT,5)*
11213      &VINT(2)**(BCS(NFIT,6)-1.)*SIN(0.5*PARU(1)*BCS(NFIT,6))
11214       SIGM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
11215      &COS(0.5*PARU(1)*BCS(NFIT,8))
11216       REFP=BCS(NFIT,2)*PARU(1)*LOG(VINT(2)/BCS(NFIT,4))/
11217      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
11218      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)+(LOG(VINT(2)/BCS(NFIT,4)))**2+
11219      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)-BCS(NFIT,5)*
11220      &VINT(2)**(BCS(NFIT,6)-1.)*COS(0.5*PARU(1)*BCS(NFIT,6))
11221       REFM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
11222      &SIN(0.5*PARU(1)*BCS(NFIT,8))
11223       SIGMA=SIGP-ISIGN(1,MINT(11)*MINT(12))*SIGM
11224       RHO=(REFP-ISIGN(1,MINT(11)*MINT(12))*REFM)/SIGMA
11225
11226 C...Nuclear slope parameter B, curvature C:
11227       NFIT=1
11228       IF(MSTP(31).GE.4) NFIT=2
11229       BP=BCB(NFIT,1)+BCB(NFIT,2)*LOG(VINT(2))+
11230      &BCB(NFIT,3)*(LOG(VINT(2)))**2
11231       BM=BCB(NFIT,4)+BCB(NFIT,5)*LOG(VINT(2))
11232       B=BP-ISIGN(1,MINT(11)*MINT(12))*SIGM/SIGP*(BM-BP)
11233       VINT(121)=B
11234       C=-0.5*BCC(2)/BCC(3)*(1.-SQRT(MAX(0.,1.+4.*BCC(3)/BCC(2)**2*
11235      &(1.E-03*VINT(1)-BCC(1)))))
11236       VINT(122)=C
11237
11238 C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).
11239       SIGEL=SIGMA**2*(1.+RHO**2)/(16.*PARU(1)*PARU(5)*B)
11240
11241 C...Single diffractive scattering cross-section from Goulianos:
11242       SIGSD=2.*0.68*(1.+36./VINT(2))*LOG(0.6+0.1*VINT(2))
11243
11244 C...Double diffractive scattering cross-section (essentially fixed by
11245 C...sigma-sd and sigma-el).
11246       SIGDD=SIGSD**2/(3.*SIGEL)
11247
11248 C...Total non-elastic, non-diffractive cross-section.
11249       SIGND=SIGMA-SIGDD-SIGSD-SIGEL
11250
11251 C...Rescale for pions.
11252       IF(IABS(MINT(11)).EQ.211.AND.IABS(MINT(12)).EQ.211) THEN
11253         SIGMA=4./9.*SIGMA
11254         SIGDD=4./9.*SIGDD
11255         SIGSD=4./9.*SIGSD
11256         SIGEL=4./9.*SIGEL
11257         SIGND=4./9.*SIGND
11258       ELSEIF(IABS(MINT(11)).EQ.211.OR.IABS(MINT(12)).EQ.211) THEN
11259         SIGMA=2./3.*SIGMA
11260         SIGDD=2./3.*SIGDD
11261         SIGSD=2./3.*SIGSD
11262         SIGEL=2./3.*SIGEL
11263         SIGND=2./3.*SIGND
11264       ENDIF
11265
11266 C...Save cross-sections in common block PYPARA.
11267       VINT(101)=SIGMA
11268       VINT(102)=SIGEL
11269       VINT(103)=SIGSD
11270       VINT(104)=SIGDD
11271       VINT(106)=SIGND
11272       XSEC(95,1)=SIGND
11273
11274       RETURN
11275       END
11276
11277 C*********************************************************************
11278
11279       SUBROUTINE PYMAXI
11280
11281 C...Finds optimal set of coefficients for kinematical variable selection
11282 C...and the maximum of the part of the differential cross-section used
11283 C...in the event weighting.
11284       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11285       SAVE /LUDAT1/
11286       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11287       SAVE /LUDAT2/
11288       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11289       SAVE /PYSUBS/
11290       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11291       SAVE /PYPARS/
11292       COMMON/PYINT1/MINT(400),VINT(400)
11293       SAVE /PYINT1/
11294       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11295       SAVE /PYINT2/
11296       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11297       SAVE /PYINT3/
11298       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11299       SAVE /PYINT4/
11300       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
11301       SAVE /PYINT5/
11302       COMMON/PYINT6/PROC(0:200)
11303       CHARACTER PROC*28
11304       SAVE /PYINT6/
11305       CHARACTER CVAR(4)*4
11306       DIMENSION NPTS(4),MVARPT(200,4),VINTPT(200,30),SIGSPT(200),
11307      &NAREL(6),WTREL(6),WTMAT(6,6),COEFU(6),IACCMX(4),SIGSMX(4),
11308      &SIGSSM(3)
11309       DATA CVAR/'tau ','tau''','y*  ','cth '/
11310
11311 C...Select subprocess to study: skip cases not applicable.
11312       VINT(143)=1.
11313       VINT(144)=1.
11314       XSEC(0,1)=0.
11315       DO 350 ISUB=1,200
11316       IF(ISUB.GE.91.AND.ISUB.LE.95) THEN
11317         XSEC(ISUB,1)=VINT(ISUB+11)
11318         IF(MSUB(ISUB).NE.1) GOTO 350
11319         GOTO 340
11320       ELSEIF(ISUB.EQ.96) THEN
11321         IF(MINT(43).NE.4) GOTO 350
11322         IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0) GOTO 350
11323       ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
11324      &ISUB.EQ.53.OR.ISUB.EQ.68) THEN
11325         IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 350
11326       ELSE
11327         IF(MSUB(ISUB).NE.1) GOTO 350
11328       ENDIF
11329       MINT(1)=ISUB
11330       ISTSB=ISET(ISUB)
11331       IF(ISUB.EQ.96) ISTSB=2
11332       IF(MSTP(122).GE.2) WRITE(MSTU(11),1000) ISUB
11333
11334 C...Find resonances (explicit or implicit in cross-section).
11335       MINT(72)=0
11336       KFR1=0
11337       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3) THEN
11338         KFR1=KFPR(ISUB,1)
11339       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
11340         KFR1=25
11341       ENDIF
11342       IF(KFR1.NE.0) THEN
11343         TAUR1=PMAS(KFR1,1)**2/VINT(2)
11344         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
11345         MINT(72)=1
11346         MINT(73)=KFR1
11347         VINT(73)=TAUR1
11348         VINT(74)=GAMR1
11349       ENDIF
11350       IF(ISUB.EQ.141) THEN
11351         KFR2=23
11352         TAUR2=PMAS(KFR2,1)**2/VINT(2)
11353         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
11354         MINT(72)=2
11355         MINT(74)=KFR2
11356         VINT(75)=TAUR2
11357         VINT(76)=GAMR2
11358       ENDIF
11359
11360 C...Find product masses and minimum pT of process.
11361       SQM3=0.
11362       SQM4=0.
11363       MINT(71)=0
11364       VINT(71)=CKIN(3)
11365       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
11366         IF(KFPR(ISUB,1).NE.0) SQM3=PMAS(KFPR(ISUB,1),1)**2
11367         IF(KFPR(ISUB,2).NE.0) SQM4=PMAS(KFPR(ISUB,2),1)**2
11368         IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
11369         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
11370         IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
11371         IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08*PARP(82)
11372       ENDIF
11373       VINT(63)=SQM3
11374       VINT(64)=SQM4
11375
11376 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
11377       NPTS(1)=2+2*MINT(72)
11378       IF(MINT(43).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) NPTS(1)=1
11379       NPTS(2)=1
11380       IF(MINT(43).GE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) NPTS(2)=2
11381       NPTS(3)=1
11382       IF(MINT(43).EQ.4) NPTS(3)=3
11383       NPTS(4)=1
11384       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
11385       NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
11386
11387 C...Reset coefficients of cross-section weighting.
11388       DO 100 J=1,20
11389   100 COEF(ISUB,J)=0.
11390       COEF(ISUB,1)=1.
11391       COEF(ISUB,7)=0.5
11392       COEF(ISUB,8)=0.5
11393       COEF(ISUB,10)=1.
11394       COEF(ISUB,15)=1.
11395       MCTH=0
11396       MTAUP=0
11397       CTH=0.
11398       TAUP=0.
11399       SIGSAM=0.
11400
11401 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
11402 C...in grid of phase space points.
11403       CALL PYKLIM(1)
11404       NACC=0
11405       DO 120 ITRY=1,NTRY
11406       IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
11407         MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
11408         CALL PYKMAP(1,MTAU,0.5)
11409         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4)
11410       ENDIF
11411       IF((ISTSB.EQ.3.OR.ISTSB.EQ.4).AND.MOD(ITRY-1,NPTS(3)*NPTS(4)).
11412      &EQ.0) THEN
11413         MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
11414         CALL PYKMAP(4,MTAUP,0.5)
11415       ENDIF
11416       IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) CALL PYKLIM(2)
11417       IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
11418         MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
11419         CALL PYKMAP(2,MYST,0.5)
11420         CALL PYKLIM(3)
11421       ENDIF
11422       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
11423         MCTH=1+MOD(ITRY-1,NPTS(4))
11424         CALL PYKMAP(3,MCTH,0.5)
11425       ENDIF
11426       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
11427
11428 C...Calculate and store cross-section.
11429       MINT(51)=0
11430       CALL PYKLIM(0)
11431       IF(MINT(51).EQ.1) GOTO 120
11432       NACC=NACC+1
11433       MVARPT(NACC,1)=MTAU
11434       MVARPT(NACC,2)=MTAUP
11435       MVARPT(NACC,3)=MYST
11436       MVARPT(NACC,4)=MCTH
11437       DO 110 J=1,30
11438   110 VINTPT(NACC,J)=VINT(10+J)
11439       CALL PYSIGH(NCHN,SIGS)
11440       SIGSPT(NACC)=SIGS
11441       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
11442       IF(MSTP(122).GE.2) WRITE(MSTU(11),1100) MTAU,MTAUP,MYST,MCTH,
11443      &VINT(21),VINT(22),VINT(23),VINT(26),SIGS
11444   120 CONTINUE
11445       IF(SIGSAM.EQ.0.) THEN
11446         WRITE(MSTU(11),1200) ISUB
11447         STOP
11448       ENDIF
11449
11450 C...Calculate integrals in tau and y* over maximal phase space limits.
11451       TAUMIN=VINT(11)
11452       TAUMAX=VINT(31)
11453       ATAU1=LOG(TAUMAX/TAUMIN)
11454       ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
11455       IF(NPTS(1).GE.3) THEN
11456         ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
11457         ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
11458      &  GAMR1
11459       ENDIF
11460       IF(NPTS(1).GE.5) THEN
11461         ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
11462         ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
11463      &  GAMR2
11464       ENDIF
11465       YSTMIN=0.5*LOG(TAUMIN)
11466       YSTMAX=-YSTMIN
11467       AYST0=YSTMAX-YSTMIN
11468       AYST1=0.5*(YSTMAX-YSTMIN)**2
11469       AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
11470
11471 C...Reset. Sum up cross-sections in points calculated.
11472       DO 230 IVAR=1,4
11473       IF(NPTS(IVAR).EQ.1) GOTO 230
11474       IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 230
11475       NBIN=NPTS(IVAR)
11476       DO 130 J1=1,NBIN
11477       NAREL(J1)=0
11478       WTREL(J1)=0.
11479       COEFU(J1)=0.
11480       DO 130 J2=1,NBIN
11481   130 WTMAT(J1,J2)=0.
11482       DO 140 IACC=1,NACC
11483       IBIN=MVARPT(IACC,IVAR)
11484       NAREL(IBIN)=NAREL(IBIN)+1
11485       WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
11486
11487 C...Sum up tau cross-section pieces in points used.
11488       IF(IVAR.EQ.1) THEN
11489         TAU=VINTPT(IACC,11)
11490         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
11491         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
11492         IF(NBIN.GE.3) THEN
11493           WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
11494           WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
11495      &    ((TAU-TAUR1)**2+GAMR1**2)
11496         ENDIF
11497         IF(NBIN.GE.5) THEN
11498           WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
11499           WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
11500      &    ((TAU-TAUR2)**2+GAMR2**2)
11501         ENDIF
11502
11503 C...Sum up tau' cross-section pieces in points used.
11504       ELSEIF(IVAR.EQ.2) THEN
11505         TAU=VINTPT(IACC,11)
11506         TAUP=VINTPT(IACC,16)
11507         TAUPMN=VINTPT(IACC,6)
11508         TAUPMX=VINTPT(IACC,26)
11509         ATAUP1=LOG(TAUPMX/TAUPMN)
11510         ATAUP2=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
11511         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
11512         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*(1.-TAU/TAUP)**3/
11513      &  TAUP
11514
11515 C...Sum up y* and cos(theta-hat) cross-section pieces in points used.
11516       ELSEIF(IVAR.EQ.3) THEN
11517         YST=VINTPT(IACC,12)
11518         WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
11519         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST1)*(YSTMAX-YST)
11520         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
11521       ELSE
11522         RM34=2.*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2
11523         RSQM=1.+RM34
11524         CTHMAX=SQRT(1.-4.*VINT(71)**2/(TAUMAX*VINT(2)))
11525         CTHMIN=-CTHMAX
11526         IF(CTHMAX.GT.0.9999) RM34=MAX(RM34,2.*VINT(71)**2/
11527      &  (TAUMAX*VINT(2)))
11528         ACTH1=CTHMAX-CTHMIN
11529         ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
11530         ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
11531         ACTH4=1./MAX(RM34,RSQM-CTHMAX)-1./MAX(RM34,RSQM-CTHMIN)
11532         ACTH5=1./MAX(RM34,RSQM+CTHMIN)-1./MAX(RM34,RSQM+CTHMAX)
11533         CTH=VINTPT(IACC,13)
11534         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
11535         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/MAX(RM34,RSQM-CTH)
11536         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/MAX(RM34,RSQM+CTH)
11537         WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/MAX(RM34,RSQM-CTH)**2
11538         WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/MAX(RM34,RSQM+CTH)**2
11539       ENDIF
11540   140 CONTINUE
11541
11542 C...Check that equation system solvable; else trivial way out.
11543       IF(MSTP(122).GE.2) WRITE(MSTU(11),1300) CVAR(IVAR)
11544       MSOLV=1
11545       DO 150 IBIN=1,NBIN
11546       IF(MSTP(122).GE.2) WRITE(MSTU(11),1400) (WTMAT(IBIN,IRED),
11547      &IRED=1,NBIN),WTREL(IBIN)
11548   150 IF(NAREL(IBIN).EQ.0) MSOLV=0
11549       IF(MSOLV.EQ.0) THEN
11550         DO 160 IBIN=1,NBIN
11551   160   COEFU(IBIN)=1.
11552
11553 C...Solve to find relative importance of cross-section pieces.
11554       ELSE
11555         DO 170 IRED=1,NBIN-1
11556         DO 170 IBIN=IRED+1,NBIN
11557         RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
11558         WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
11559         DO 170 ICOE=IRED,NBIN
11560   170   WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
11561         DO 190 IRED=NBIN,1,-1
11562         DO 180 ICOE=IRED+1,NBIN
11563   180   WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
11564   190   COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
11565       ENDIF
11566
11567 C...Normalize coefficients, with piece shared democratically.
11568       COEFSU=0.
11569       DO 200 IBIN=1,NBIN
11570       COEFU(IBIN)=MAX(0.,COEFU(IBIN))
11571   200 COEFSU=COEFSU+COEFU(IBIN)
11572       IF(IVAR.EQ.1) IOFF=0
11573       IF(IVAR.EQ.2) IOFF=14
11574       IF(IVAR.EQ.3) IOFF=6
11575       IF(IVAR.EQ.4) IOFF=9
11576       IF(COEFSU.GT.0.) THEN
11577         DO 210 IBIN=1,NBIN
11578   210   COEF(ISUB,IOFF+IBIN)=PARP(121)/NBIN+(1.-PARP(121))*COEFU(IBIN)/
11579      &  COEFSU
11580       ELSE
11581         DO 220 IBIN=1,NBIN
11582   220   COEF(ISUB,IOFF+IBIN)=1./NBIN
11583       ENDIF
11584       IF(MSTP(122).GE.2) WRITE(MSTU(11),1500) CVAR(IVAR),
11585      &(COEF(ISUB,IOFF+IBIN),IBIN=1,NBIN)
11586   230 CONTINUE
11587
11588 C...Find two most promising maxima among points previously determined.
11589       DO 240 J=1,4
11590       IACCMX(J)=0
11591   240 SIGSMX(J)=0.
11592       NMAX=0
11593       DO 290 IACC=1,NACC
11594       DO 250 J=1,30
11595   250 VINT(10+J)=VINTPT(IACC,J)
11596       CALL PYSIGH(NCHN,SIGS)
11597       IEQ=0
11598       DO 260 IMV=1,NMAX
11599   260 IF(ABS(SIGS-SIGSMX(IMV)).LT.1E-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
11600       IF(IEQ.EQ.0) THEN
11601         DO 270 IMV=NMAX,1,-1
11602         IIN=IMV+1
11603         IF(SIGS.LE.SIGSMX(IMV)) GOTO 280
11604         IACCMX(IMV+1)=IACCMX(IMV)
11605   270   SIGSMX(IMV+1)=SIGSMX(IMV)
11606         IIN=1
11607   280   IACCMX(IIN)=IACC
11608         SIGSMX(IIN)=SIGS
11609         IF(NMAX.LE.1) NMAX=NMAX+1
11610       ENDIF
11611   290 CONTINUE
11612
11613 C...Read out starting position for search.
11614       IF(MSTP(122).GE.2) WRITE(MSTU(11),1600)
11615       SIGSAM=SIGSMX(1)
11616       DO 330 IMAX=1,NMAX
11617       IACC=IACCMX(IMAX)
11618       MTAU=MVARPT(IACC,1)
11619       MTAUP=MVARPT(IACC,2)
11620       MYST=MVARPT(IACC,3)
11621       MCTH=MVARPT(IACC,4)
11622       VTAU=0.5
11623       VYST=0.5
11624       VCTH=0.5
11625       VTAUP=0.5
11626
11627 C...Starting point and step size in parameter space.
11628       DO 320 IRPT=1,2
11629       DO 310 IVAR=1,4
11630       IF(NPTS(IVAR).EQ.1) GOTO 310
11631       IF(IVAR.EQ.1) VVAR=VTAU
11632       IF(IVAR.EQ.2) VVAR=VTAUP
11633       IF(IVAR.EQ.3) VVAR=VYST
11634       IF(IVAR.EQ.4) VVAR=VCTH
11635       IF(IVAR.EQ.1) MVAR=MTAU
11636       IF(IVAR.EQ.2) MVAR=MTAUP
11637       IF(IVAR.EQ.3) MVAR=MYST
11638       IF(IVAR.EQ.4) MVAR=MCTH
11639       IF(IRPT.EQ.1) VDEL=0.1
11640       IF(IRPT.EQ.2) VDEL=MAX(0.01,MIN(0.05,VVAR-0.02,0.98-VVAR))
11641       IF(IRPT.EQ.1) VMAR=0.02
11642       IF(IRPT.EQ.2) VMAR=0.002
11643       IMOV0=1
11644       IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
11645       DO 300 IMOV=IMOV0,8
11646
11647 C...Define new point in parameter space.
11648       IF(IMOV.EQ.0) THEN
11649         INEW=2
11650         VNEW=VVAR
11651       ELSEIF(IMOV.EQ.1) THEN
11652         INEW=3
11653         VNEW=VVAR+VDEL
11654       ELSEIF(IMOV.EQ.2) THEN
11655         INEW=1
11656         VNEW=VVAR-VDEL
11657       ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
11658      &VVAR+2.*VDEL.LT.1.-VMAR) THEN
11659         VVAR=VVAR+VDEL
11660         SIGSSM(1)=SIGSSM(2)
11661         SIGSSM(2)=SIGSSM(3)
11662         INEW=3
11663         VNEW=VVAR+VDEL
11664       ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
11665      &VVAR-2.*VDEL.GT.VMAR) THEN
11666         VVAR=VVAR-VDEL
11667         SIGSSM(3)=SIGSSM(2)
11668         SIGSSM(2)=SIGSSM(1)
11669         INEW=1
11670         VNEW=VVAR-VDEL
11671       ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
11672         VDEL=0.5*VDEL
11673         VVAR=VVAR+VDEL
11674         SIGSSM(1)=SIGSSM(2)
11675         INEW=2
11676         VNEW=VVAR
11677       ELSE
11678         VDEL=0.5*VDEL
11679         VVAR=VVAR-VDEL
11680         SIGSSM(3)=SIGSSM(2)
11681         INEW=2
11682         VNEW=VVAR
11683       ENDIF
11684
11685 C...Convert to relevant variables and find derived new limits.
11686       IF(IVAR.EQ.1) THEN
11687         VTAU=VNEW
11688         CALL PYKMAP(1,MTAU,VTAU)
11689         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4)
11690       ENDIF
11691       IF(IVAR.LE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) THEN
11692         IF(IVAR.EQ.2) VTAUP=VNEW
11693         CALL PYKMAP(4,MTAUP,VTAUP)
11694       ENDIF
11695       IF(IVAR.LE.2) CALL PYKLIM(2)
11696       IF(IVAR.LE.3) THEN
11697         IF(IVAR.EQ.3) VYST=VNEW
11698         CALL PYKMAP(2,MYST,VYST)
11699         CALL PYKLIM(3)
11700       ENDIF
11701       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
11702         IF(IVAR.EQ.4) VCTH=VNEW
11703         CALL PYKMAP(3,MCTH,VCTH)
11704       ENDIF
11705       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
11706
11707 C...Evaluate cross-section. Save new maximum. Final maximum.
11708       CALL PYSIGH(NCHN,SIGS)
11709       SIGSSM(INEW)=SIGS
11710       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
11711       IF(MSTP(122).GE.2) WRITE(MSTU(11),1700) IMAX,IVAR,MVAR,IMOV,
11712      &VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
11713   300 CONTINUE
11714   310 CONTINUE
11715   320 CONTINUE
11716       IF(IMAX.EQ.1) SIGS11=SIGSAM
11717   330 CONTINUE
11718       XSEC(ISUB,1)=1.05*SIGSAM
11719   340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
11720   350 CONTINUE
11721
11722 C...Print summary table.
11723       IF(MSTP(122).GE.1) THEN
11724         WRITE(MSTU(11),1800)
11725         WRITE(MSTU(11),1900)
11726         DO 360 ISUB=1,200
11727         IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 360
11728         IF(ISUB.EQ.96.AND.MINT(43).NE.4) GOTO 360
11729         IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 360
11730         IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.
11731      &  ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 360
11732         WRITE(MSTU(11),2000) ISUB,PROC(ISUB),XSEC(ISUB,1)
11733   360   CONTINUE
11734         WRITE(MSTU(11),2100)
11735       ENDIF
11736
11737 C...Format statements for maximization results.
11738  1000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
11739      &'subprocess no',I4/1X,'Coefficient modes     tau',10X,'y*',9X,
11740      &'cth',9X,'tau''',7X,'sigma')
11741  1100 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,E12.4)
11742  1200 FORMAT(1X,'Error: requested subprocess ',I3,' has vanishing ',
11743      &'cross-section.'/1X,'Execution stopped!')
11744  1300 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
11745  1400 FORMAT(1X,1P,7E11.3)
11746  1500 FORMAT(1X,'Result for ',A4,':',6F9.4)
11747  1600 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
11748      &'MOD MOV   VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
11749  1700 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,E12.4)
11750  1800 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
11751      &'cross-section maximum search',1X,8('*'))
11752  1900 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I  ISUB  ',
11753      &'Subprocess name',15X,'I  Maximum value  I'/11X,'I',38X,'I',
11754      &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
11755  2000 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,E12.4,3X,'I')
11756  2100 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
11757
11758       RETURN
11759       END
11760
11761 C*********************************************************************
11762
11763       SUBROUTINE PYOVLY(MOVLY)
11764
11765 C...Initializes multiplicity distribution and selects mutliplicity
11766 C...of overlayed events, i.e. several events occuring at the same
11767 C...beam crossing.
11768       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11769       SAVE /LUDAT1/
11770       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11771       SAVE /PYPARS/
11772       COMMON/PYINT1/MINT(400),VINT(400)
11773       SAVE /PYINT1/
11774       DIMENSION WTI(0:100)
11775       SAVE IMAX,WTI,WTS
11776
11777 C...Sum of allowed cross-sections for overlayed events.
11778       IF(MOVLY.EQ.1) THEN
11779         VINT(131)=VINT(106)
11780         IF(MSTP(132).GE.2) VINT(131)=VINT(131)+VINT(104)
11781         IF(MSTP(132).GE.3) VINT(131)=VINT(131)+VINT(103)
11782         IF(MSTP(132).GE.4) VINT(131)=VINT(131)+VINT(102)
11783
11784 C...Initialize multiplicity distribution for unbiased events.
11785         IF(MSTP(133).EQ.1) THEN
11786           XNAVE=VINT(131)*PARP(131)
11787           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
11788           WTI(0)=EXP(-MIN(50.,XNAVE))
11789           WTS=0.
11790           WTN=0.
11791           DO 100 I=1,100
11792           WTI(I)=WTI(I-1)*XNAVE/I
11793           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 110
11794           WTS=WTS+WTI(I)
11795           WTN=WTN+WTI(I)*I
11796   100     IMAX=I
11797   110     VINT(132)=XNAVE
11798           VINT(133)=WTN/WTS
11799           VINT(134)=WTS
11800
11801 C...Initialize mutiplicity distribution for biased events.
11802         ELSEIF(MSTP(133).EQ.2) THEN
11803           XNAVE=VINT(131)*PARP(131)
11804           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
11805           WTI(1)=EXP(-MIN(50.,XNAVE))*XNAVE
11806           WTS=WTI(1)
11807           WTN=WTI(1)
11808           DO 120 I=2,100
11809           WTI(I)=WTI(I-1)*XNAVE/(I-1)
11810           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 130
11811           WTS=WTS+WTI(I)
11812           WTN=WTN+WTI(I)*I
11813   120     IMAX=I
11814   130     VINT(132)=XNAVE
11815           VINT(133)=WTN/WTS
11816           VINT(134)=WTS
11817         ENDIF
11818
11819 C...Pick multiplicity of overlayed events.
11820       ELSE
11821         IF(MSTP(133).EQ.0) THEN
11822           MINT(81)=MAX(1,MSTP(134))
11823         ELSE
11824           WTR=WTS*RLU(0)
11825           DO 140 I=1,IMAX
11826           MINT(81)=I
11827           WTR=WTR-WTI(I)
11828           IF(WTR.LE.0.) GOTO 150
11829   140     CONTINUE
11830   150     CONTINUE
11831         ENDIF
11832       ENDIF
11833
11834 C...Format statement for error message.
11835  1000 FORMAT(1X,'Warning: requested average number of events per bunch',
11836      &'crossing too large, ',1P,E12.4)
11837
11838       RETURN
11839       END
11840
11841 C*********************************************************************
11842
11843       SUBROUTINE PYRAND
11844
11845 C...Generates quantities characterizing the high-pT scattering at the
11846 C...parton level according to the matrix elements. Chooses incoming,
11847 C...reacting partons, their momentum fractions and one of the possible
11848 C...subprocesses.
11849       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11850       SAVE /LUDAT1/
11851       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11852       SAVE /LUDAT2/
11853       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11854       SAVE /PYSUBS/
11855       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11856       SAVE /PYPARS/
11857       COMMON/PYINT1/MINT(400),VINT(400)
11858       SAVE /PYINT1/
11859       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11860       SAVE /PYINT2/
11861       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11862       SAVE /PYINT3/
11863       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11864       SAVE /PYINT4/
11865       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
11866       SAVE /PYINT5/
11867
11868 C...Initial values, specifically for (first) semihard interaction.
11869       MINT(17)=0
11870       MINT(18)=0
11871       VINT(143)=1.
11872       VINT(144)=1.
11873       IF(MSUB(95).EQ.1.OR.MINT(82).GE.2) CALL PYMULT(2)
11874       ISUB=0
11875   100 MINT(51)=0
11876
11877 C...Choice of process type - first event of overlay.
11878       IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
11879         RSUB=XSEC(0,1)*RLU(0)
11880         DO 110 I=1,200
11881         IF(MSUB(I).NE.1) GOTO 110
11882         ISUB=I
11883         RSUB=RSUB-XSEC(I,1)
11884         IF(RSUB.LE.0.) GOTO 120
11885   110   CONTINUE
11886   120   IF(ISUB.EQ.95) ISUB=96
11887
11888 C...Choice of inclusive process type - overlayed events.
11889       ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
11890         RSUB=VINT(131)*RLU(0)
11891         ISUB=96
11892         IF(RSUB.GT.VINT(106)) ISUB=93
11893         IF(RSUB.GT.VINT(106)+VINT(104)) ISUB=92
11894         IF(RSUB.GT.VINT(106)+VINT(104)+VINT(103)) ISUB=91
11895       ENDIF
11896       IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
11897       IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
11898       MINT(1)=ISUB
11899
11900 C...Find resonances (explicit or implicit in cross-section).
11901       MINT(72)=0
11902       KFR1=0
11903       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
11904         KFR1=KFPR(ISUB,1)
11905       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
11906         KFR1=25
11907       ENDIF
11908       IF(KFR1.NE.0) THEN
11909         TAUR1=PMAS(KFR1,1)**2/VINT(2)
11910         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
11911         MINT(72)=1
11912         MINT(73)=KFR1
11913         VINT(73)=TAUR1
11914         VINT(74)=GAMR1
11915       ENDIF
11916       IF(ISUB.EQ.141) THEN
11917         KFR2=23
11918         TAUR2=PMAS(KFR2,1)**2/VINT(2)
11919         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
11920         MINT(72)=2
11921         MINT(74)=KFR2
11922         VINT(75)=TAUR2
11923         VINT(76)=GAMR2
11924       ENDIF
11925
11926 C...Find product masses and minimum pT of process,
11927 C...optionally with broadening according to a truncated Breit-Wigner.
11928       VINT(63)=0.
11929       VINT(64)=0.
11930       MINT(71)=0
11931       VINT(71)=CKIN(3)
11932       IF(MINT(82).GE.2) VINT(71)=0.
11933       IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
11934         DO 130 I=1,2
11935         IF(KFPR(ISUB,I).EQ.0) THEN
11936         ELSEIF(MSTP(42).LE.0) THEN
11937           VINT(62+I)=PMAS(KFPR(ISUB,I),1)**2
11938         ELSE
11939           VINT(62+I)=ULMASS(KFPR(ISUB,I))**2
11940         ENDIF
11941   130   CONTINUE
11942         IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
11943         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
11944       ENDIF
11945
11946       IF(ISET(ISUB).EQ.0) THEN
11947 C...Double or single diffractive, or elastic scattering:
11948 C...choose m^2 according to 1/m^2 (diffractive), constant (elastic)
11949         IS=INT(1.5+RLU(0))
11950         VINT(63)=VINT(3)**2
11951         VINT(64)=VINT(4)**2
11952         IF(ISUB.EQ.92.OR.ISUB.EQ.93) VINT(62+IS)=PARP(111)**2
11953         IF(ISUB.EQ.93) VINT(65-IS)=PARP(111)**2
11954         SH=VINT(2)
11955         SQM1=VINT(3)**2
11956         SQM2=VINT(4)**2
11957         SQM3=VINT(63)
11958         SQM4=VINT(64)
11959         SQLA12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2
11960         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
11961         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
11962         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
11963         THL=0.5*(THTER1-THTER2)
11964         THU=0.5*(THTER1+THTER2)
11965         THM=MIN(MAX(THL,PARP(101)),THU)
11966         JTMAX=0
11967         IF(ISUB.EQ.92.OR.ISUB.EQ.93) JTMAX=ISUB-91
11968         DO 140 JT=1,JTMAX
11969         MINT(13+3*JT-IS*(2*JT-3))=1
11970         SQMMIN=VINT(59+3*JT-IS*(2*JT-3))
11971         SQMI=VINT(8-3*JT+IS*(2*JT-3))**2
11972         SQMJ=VINT(3*JT-1-IS*(2*JT-3))**2
11973         SQMF=VINT(68-3*JT+IS*(2*JT-3))
11974         SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-
11975      &  SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)
11976         QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+
11977      &  SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))
11978         SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))
11979         IF(ABS(QUAR/SQUA**2).LT.1.E-06) SQMMAX=0.5*QUAR/SQUA
11980         SQMMAX=MIN(SQMMAX,(VINT(1)-SQRT(SQMF))**2)
11981         VINT(59+3*JT-IS*(2*JT-3))=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)
11982   140   CONTINUE
11983 C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).
11984         SQM3=VINT(63)
11985         SQM4=VINT(64)
11986         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
11987         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
11988         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
11989         THL=0.5*(THTER1-THTER2)
11990         THU=0.5*(THTER1+THTER2)
11991         B=VINT(121)
11992         C=VINT(122)
11993         IF(ISUB.EQ.92.OR.ISUB.EQ.93) THEN
11994           B=0.5*B
11995           C=0.5*C
11996         ENDIF
11997         THM=MIN(MAX(THL,PARP(101)),THU)
11998         EXPTH=0.
11999         THARG=B*(THM-THU)
12000         IF(THARG.GT.-20.) EXPTH=EXP(THARG)
12001   150   TH=THU+LOG(EXPTH+(1.-EXPTH)*RLU(0))/B
12002         TH=MAX(THM,MIN(THU,TH))
12003         RATLOG=MIN((B+C*(TH+THM))*(TH-THM),(B+C*(TH+THU))*(TH-THU))
12004         IF(RATLOG.LT.LOG(RLU(0))) GOTO 150
12005         VINT(21)=1.
12006         VINT(22)=0.
12007         VINT(23)=MIN(1.,MAX(-1.,(2.*TH-THTER1)/THTER2))
12008
12009 C...Note: in the following, by In is meant the integral over the
12010 C...quantity multiplying coefficient cn.
12011 C...Choose tau according to h1(tau)/tau, where
12012 C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +
12013 C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
12014 C...I0/I4*c4*1/(tau+tau_R') +
12015 C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and
12016 C...c0 + c1 + c2 + c3 + c4 + c5 = 1
12017       ELSEIF(ISET(ISUB).GE.1.AND.ISET(ISUB).LE.4) THEN
12018         CALL PYKLIM(1)
12019         IF(MINT(51).NE.0) GOTO 100
12020         RTAU=RLU(0)
12021         MTAU=1
12022         IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
12023         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
12024         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
12025         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
12026      &  MTAU=5
12027         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
12028      &  COEF(ISUB,5)) MTAU=6
12029         CALL PYKMAP(1,MTAU,RLU(0))
12030
12031 C...2 -> 3, 4 processes:
12032 C...Choose tau' according to h4(tau,tau')/tau', where
12033 C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and
12034 C...c0 + c1 = 1.
12035         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
12036           CALL PYKLIM(4)
12037           IF(MINT(51).NE.0) GOTO 100
12038           RTAUP=RLU(0)
12039           MTAUP=1
12040           IF(RTAUP.GT.COEF(ISUB,15)) MTAUP=2
12041           CALL PYKMAP(4,MTAUP,RLU(0))
12042         ENDIF
12043
12044 C...Choose y* according to h2(y*), where
12045 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
12046 C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.
12047         CALL PYKLIM(2)
12048         IF(MINT(51).NE.0) GOTO 100
12049         RYST=RLU(0)
12050         MYST=1
12051         IF(RYST.GT.COEF(ISUB,7)) MYST=2
12052         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
12053         CALL PYKMAP(2,MYST,RLU(0))
12054
12055 C...2 -> 2 processes:
12056 C...Choose cos(theta-hat) (cth) according to h3(cth), where
12057 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
12058 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
12059 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
12060 C...and c0 + c1 + c2 + c3 + c4 = 1.
12061         CALL PYKLIM(3)
12062         IF(MINT(51).NE.0) GOTO 100
12063         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12064           RCTH=RLU(0)
12065           MCTH=1
12066           IF(RCTH.GT.COEF(ISUB,10)) MCTH=2
12067           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)) MCTH=3
12068           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)) MCTH=4
12069           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)+
12070      &    COEF(ISUB,13)) MCTH=5
12071           CALL PYKMAP(3,MCTH,RLU(0))
12072         ENDIF
12073
12074 C...Low-pT or multiple interactions (first semihard interaction).
12075       ELSEIF(ISET(ISUB).EQ.5) THEN
12076         CALL PYMULT(3)
12077         ISUB=MINT(1)
12078       ENDIF
12079
12080 C...Choose azimuthal angle.
12081       VINT(24)=PARU(2)*RLU(0)
12082
12083 C...Check against user cuts on kinematics at parton level.
12084       MINT(51)=0
12085       IF(ISUB.LE.90.OR.ISUB.GT.100) CALL PYKLIM(0)
12086       IF(MINT(51).NE.0) GOTO 100
12087       IF(MINT(82).EQ.1.AND.MSTP(141).GE.1) THEN
12088         MCUT=0
12089         IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
12090      &  CALL PYKCUT(MCUT)
12091         IF(MCUT.NE.0) GOTO 100
12092       ENDIF
12093
12094 C...Calculate differential cross-section for different subprocesses.
12095       CALL PYSIGH(NCHN,SIGS)
12096
12097 C...Calculations for Monte Carlo estimate of all cross-sections.
12098       IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
12099         XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
12100       ELSEIF(MINT(82).EQ.1) THEN
12101         XSEC(ISUB,2)=XSEC(ISUB,2)+XSEC(ISUB,1)
12102       ENDIF
12103
12104 C...Multiple interactions: store results of cross-section calculation.
12105       IF(MINT(43).EQ.4.AND.MSTP(82).GE.3) THEN
12106         VINT(153)=SIGS
12107         CALL PYMULT(4)
12108       ENDIF
12109
12110 C...Weighting using estimate of maximum of differential cross-section.
12111       VIOL=SIGS/XSEC(ISUB,1)
12112       IF(VIOL.LT.RLU(0)) GOTO 100
12113
12114 C...Check for possible violation of estimated maximum of differential
12115 C...cross-section used in weighting.
12116       IF(MSTP(123).LE.0) THEN
12117         IF(VIOL.GT.1.) THEN
12118           WRITE(MSTU(11),1000) VIOL,NGEN(0,3)+1
12119           WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
12120           STOP
12121         ENDIF
12122       ELSEIF(MSTP(123).EQ.1) THEN
12123         IF(VIOL.GT.VINT(108)) THEN
12124           VINT(108)=VIOL
12125 C          IF(VIOL.GT.1.) THEN
12126 C            WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
12127 C            WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),
12128 C     &      VINT(26)
12129 C          ENDIF
12130         ENDIF
12131       ELSEIF(VIOL.GT.VINT(108)) THEN
12132         VINT(108)=VIOL
12133         IF(VIOL.GT.1.) THEN
12134           XDIF=XSEC(ISUB,1)*(VIOL-1.)
12135           XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
12136           IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
12137      &    XSEC(0,1)=XSEC(0,1)+XDIF
12138 C          WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
12139 C          WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
12140 C          IF(ISUB.LE.9) THEN
12141 C            WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)
12142 C          ELSEIF(ISUB.LE.99) THEN
12143 C            WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)
12144 C          ELSE
12145 C            WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)
12146 C          ENDIF
12147           VINT(108)=1.
12148         ENDIF
12149       ENDIF
12150
12151 C...Multiple interactions: choose impact parameter.
12152       VINT(148)=1.
12153       IF(MINT(43).EQ.4.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.MSTP(82).GE.3)
12154      &THEN
12155         CALL PYMULT(5)
12156         IF(VINT(150).LT.RLU(0)) GOTO 100
12157       ENDIF
12158       IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
12159         IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
12160         IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
12161       ENDIF
12162       IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
12163
12164 C...Choose flavour of reacting partons (and subprocess).
12165       RSIGS=SIGS*RLU(0)
12166       QT2=VINT(48)
12167       RQQBAR=PARP(87)*(1.-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
12168       IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
12169      &RLU(0).GT.RQQBAR)) THEN
12170         DO 190 ICHN=1,NCHN
12171         KFL1=ISIG(ICHN,1)
12172         KFL2=ISIG(ICHN,2)
12173         MINT(2)=ISIG(ICHN,3)
12174         RSIGS=RSIGS-SIGH(ICHN)
12175         IF(RSIGS.LE.0.) GOTO 210
12176   190   CONTINUE
12177
12178 C...Multiple interactions: choose qqbar preferentially at small pT.
12179       ELSEIF(ISUB.EQ.96) THEN
12180         CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
12181         CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
12182         MINT(1)=11
12183         MINT(2)=1
12184         IF(KFL1.EQ.KFL2.AND.RLU(0).LT.0.5) MINT(2)=2
12185
12186 C...Low-pT: choose string drawing configuration.
12187       ELSE
12188         KFL1=21
12189         KFL2=21
12190         RSIGS=6.*RLU(0)
12191         MINT(2)=1
12192         IF(RSIGS.GT.1.) MINT(2)=2
12193         IF(RSIGS.GT.2.) MINT(2)=3
12194       ENDIF
12195
12196 C...Reassign QCD process. Partons before initial state radiation.
12197   210 IF(MINT(2).GT.10) THEN
12198         MINT(1)=MINT(2)/10
12199         MINT(2)=MOD(MINT(2),10)
12200       ENDIF
12201       MINT(15)=KFL1
12202       MINT(16)=KFL2
12203       MINT(13)=MINT(15)
12204       MINT(14)=MINT(16)
12205       VINT(141)=VINT(41)
12206       VINT(142)=VINT(42)
12207
12208 C...Format statements for differential cross-section maximum violations.
12209  1000 FORMAT(1X,'Error: maximum violated by',1P,E11.3,1X,
12210      &'in event',1X,I7,'.'/1X,'Execution stopped!')
12211  1100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
12212      &E11.3,', y* =',E11.3,', cthe = ',0P,F11.7,', tau'' =',1P,E11.3)
12213  1200 FORMAT(1X,'Warning: maximum violated by',1P,E11.3,1X,
12214      &'in event',1X,I7)
12215  1300 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,E11.3)
12216  1400 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,E11.3)
12217  1500 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,E11.3)
12218
12219       RETURN
12220       END
12221
12222 C*********************************************************************
12223
12224       SUBROUTINE PYSCAT
12225
12226 C...Finds outgoing flavours and event type; sets up the kinematics
12227 C...and colour flow of the hard scattering.
12228       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
12229       SAVE /LUJETS/
12230       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12231       SAVE /LUDAT1/
12232       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
12233       SAVE /LUDAT2/
12234       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
12235       SAVE /LUDAT3/
12236       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
12237       SAVE /PYSUBS/
12238       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12239       SAVE /PYPARS/
12240       COMMON/PYINT1/MINT(400),VINT(400)
12241       SAVE /PYINT1/
12242       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
12243       SAVE /PYINT2/
12244       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12245       SAVE /PYINT3/
12246       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
12247       SAVE /PYINT4/
12248       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
12249       SAVE /PYINT5/
12250       DIMENSION WDTP(0:40),WDTE(0:40,0:5),PMQ(2),Z(2),CTHE(2),PHI(2)
12251
12252 C...Choice of subprocess, number of documentation lines.
12253       ISUB=MINT(1)
12254       IDOC=6+ISET(ISUB)
12255       IF(ISUB.EQ.95) IDOC=8
12256       MINT(3)=IDOC-6
12257       IF(IDOC.GE.9) IDOC=IDOC+2
12258       MINT(4)=IDOC
12259       IPU1=MINT(84)+1
12260       IPU2=MINT(84)+2
12261       IPU3=MINT(84)+3
12262       IPU4=MINT(84)+4
12263       IPU5=MINT(84)+5
12264       IPU6=MINT(84)+6
12265
12266 C...Reset K, P and V vectors. Store incoming particles.
12267       DO 100 JT=1,MSTP(126)+10
12268       I=MINT(83)+JT
12269       DO 100 J=1,5
12270       K(I,J)=0
12271       P(I,J)=0.
12272   100 V(I,J)=0.
12273       DO 110 JT=1,2
12274       I=MINT(83)+JT
12275       K(I,1)=21
12276       K(I,2)=MINT(10+JT)
12277       P(I,1)=0.
12278       P(I,2)=0.
12279       P(I,5)=VINT(2+JT)
12280       P(I,3)=VINT(5)*(-1)**(JT+1)
12281   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
12282       MINT(6)=2
12283       KFRES=0
12284
12285 C...Store incoming partons in their CM-frame.
12286       SH=VINT(44)
12287       SHR=SQRT(SH)
12288       SHP=VINT(26)*VINT(2)
12289       SHPR=SQRT(SHP)
12290       SHUSER=SHR
12291       IF(ISET(ISUB).GE.3) SHUSER=SHPR
12292       DO 120 JT=1,2
12293       I=MINT(84)+JT
12294       K(I,1)=14
12295       K(I,2)=MINT(14+JT)
12296       K(I,3)=MINT(83)+2+JT
12297   120 P(I,5)=ULMASS(K(I,2))
12298       IF(P(IPU1,5)+P(IPU2,5).GE.SHUSER) THEN
12299         P(IPU1,5)=0.
12300         P(IPU2,5)=0.
12301       ENDIF
12302       P(IPU1,4)=0.5*(SHUSER+(P(IPU1,5)**2-P(IPU2,5)**2)/SHUSER)
12303       P(IPU1,3)=SQRT(MAX(0.,P(IPU1,4)**2-P(IPU1,5)**2))
12304       P(IPU2,4)=SHUSER-P(IPU1,4)
12305       P(IPU2,3)=-P(IPU1,3)
12306
12307 C...Copy incoming partons to documentation lines.
12308       DO 130 JT=1,2
12309       I1=MINT(83)+4+JT
12310       I2=MINT(84)+JT
12311       K(I1,1)=21
12312       K(I1,2)=K(I2,2)
12313       K(I1,3)=I1-2
12314       DO 130 J=1,5
12315   130 P(I1,J)=P(I2,J)
12316
12317 C...Choose new quark flavour for relevant annihilation graphs.
12318       IF(ISUB.EQ.12.OR.ISUB.EQ.53) THEN
12319         CALL PYWIDT(21,SHR,WDTP,WDTE)
12320         RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*RLU(0)
12321         DO 140 I=1,2*MSTP(1)
12322         KFLQ=I
12323         RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
12324         IF(RKFL.LE.0.) GOTO 150
12325   140   CONTINUE
12326   150   CONTINUE
12327       ENDIF
12328
12329 C...Final state flavours and colour flow: default values.
12330       JS=1
12331       MINT(21)=MINT(15)
12332       MINT(22)=MINT(16)
12333       MINT(23)=0
12334       MINT(24)=0
12335       KCC=20
12336       KCS=ISIGN(1,MINT(15))
12337
12338       IF(ISUB.LE.10) THEN
12339       IF(ISUB.EQ.1) THEN
12340 C...f + fb -> gamma*/Z0.
12341         KFRES=23
12342
12343       ELSEIF(ISUB.EQ.2) THEN
12344 C...f + fb' -> W+/- .
12345         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12346         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12347         KFRES=ISIGN(24,KCH1+KCH2)
12348
12349       ELSEIF(ISUB.EQ.3) THEN
12350 C...f + fb -> H0.
12351         KFRES=25
12352
12353       ELSEIF(ISUB.EQ.4) THEN
12354 C...gamma + W+/- -> W+/-.
12355
12356       ELSEIF(ISUB.EQ.5) THEN
12357 C...Z0 + Z0 -> H0.
12358         XH=SH/SHP
12359         MINT(21)=MINT(15)
12360         MINT(22)=MINT(16)
12361         PMQ(1)=ULMASS(MINT(21))
12362         PMQ(2)=ULMASS(MINT(22))
12363   240   JT=INT(1.5+RLU(0))
12364         ZMIN=2.*PMQ(JT)/SHPR
12365         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12366         ZMAX=MIN(1.-XH,ZMAX)
12367         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12368         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12369      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 240
12370         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12371         IF(SQC1.LT.1.E-8) GOTO 240
12372         C1=SQRT(SQC1)
12373         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12374         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12375         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12376         Z(3-JT)=1.-XH/(1.-Z(JT))
12377         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12378         IF(SQC1.LT.1.E-8) GOTO 240
12379         C1=SQRT(SQC1)
12380         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12381         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12382         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12383         PHIR=PARU(2)*RLU(0)
12384         CPHI=COS(PHIR)
12385         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12386         Z1=2.-Z(JT)
12387         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12388         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12389         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12390      &  PMQ(3-JT)**2/SHP))
12391         ZMIN=2.*PMQ(3-JT)/SHPR
12392         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12393         ZMAX=MIN(1.-XH,ZMAX)
12394         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 240
12395         KCC=22
12396         KFRES=25
12397
12398       ELSEIF(ISUB.EQ.6) THEN
12399 C...Z0 + W+/- -> W+/-.
12400
12401       ELSEIF(ISUB.EQ.7) THEN
12402 C...W+ + W- -> Z0.
12403
12404       ELSEIF(ISUB.EQ.8) THEN
12405 C...W+ + W- -> H0.
12406         XH=SH/SHP
12407   250   DO 280 JT=1,2
12408         I=MINT(14+JT)
12409         IA=IABS(I)
12410         IF(IA.LE.10) THEN
12411           RVCKM=VINT(180+I)*RLU(0)
12412           DO 270 J=1,MSTP(1)
12413           IB=2*J-1+MOD(IA,2)
12414           IPM=(5-ISIGN(1,I))/2
12415           IDC=J+MDCY(IA,2)+2
12416           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
12417           MINT(20+JT)=ISIGN(IB,I)
12418           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12419           IF(RVCKM.LE.0.) GOTO 280
12420   270     CONTINUE
12421         ELSE
12422           IB=2*((IA+1)/2)-1+MOD(IA,2)
12423           MINT(20+JT)=ISIGN(IB,I)
12424         ENDIF
12425   280   PMQ(JT)=ULMASS(MINT(20+JT))
12426         JT=INT(1.5+RLU(0))
12427         ZMIN=2.*PMQ(JT)/SHPR
12428         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12429         ZMAX=MIN(1.-XH,ZMAX)
12430         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12431         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12432      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 250
12433         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12434         IF(SQC1.LT.1.E-8) GOTO 250
12435         C1=SQRT(SQC1)
12436         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12437         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12438         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12439         Z(3-JT)=1.-XH/(1.-Z(JT))
12440         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12441         IF(SQC1.LT.1.E-8) GOTO 250
12442         C1=SQRT(SQC1)
12443         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12444         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12445         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12446         PHIR=PARU(2)*RLU(0)
12447         CPHI=COS(PHIR)
12448         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12449         Z1=2.-Z(JT)
12450         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12451         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12452         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12453      &  PMQ(3-JT)**2/SHP))
12454         ZMIN=2.*PMQ(3-JT)/SHPR
12455         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12456         ZMAX=MIN(1.-XH,ZMAX)
12457         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 250
12458         KCC=22
12459         KFRES=25
12460       ENDIF
12461
12462       ELSEIF(ISUB.LE.20) THEN
12463       IF(ISUB.EQ.11) THEN
12464 C...f + f' -> f + f'; th = (p(f)-p(f))**2.
12465         KCC=MINT(2)
12466         IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12467
12468       ELSEIF(ISUB.EQ.12) THEN
12469 C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.
12470         MINT(21)=ISIGN(KFLQ,MINT(15))
12471         MINT(22)=-MINT(21)
12472         KCC=4
12473
12474       ELSEIF(ISUB.EQ.13) THEN
12475 C...f + fb -> g + g; th arbitrary.
12476         MINT(21)=21
12477         MINT(22)=21
12478         KCC=MINT(2)+4
12479
12480       ELSEIF(ISUB.EQ.14) THEN
12481 C...f + fb -> g + gam; th arbitrary.
12482         IF(RLU(0).GT.0.5) JS=2
12483         MINT(20+JS)=21
12484         MINT(23-JS)=22
12485         KCC=17+JS
12486
12487       ELSEIF(ISUB.EQ.15) THEN
12488 C...f + fb -> g + Z0; th arbitrary.
12489         IF(RLU(0).GT.0.5) JS=2
12490         MINT(20+JS)=21
12491         MINT(23-JS)=23
12492         KCC=17+JS
12493
12494       ELSEIF(ISUB.EQ.16) THEN
12495 C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12496         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12497         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12498         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12499         MINT(20+JS)=21
12500         MINT(23-JS)=ISIGN(24,KCH1+KCH2)
12501         KCC=17+JS
12502
12503       ELSEIF(ISUB.EQ.17) THEN
12504 C...f + fb -> g + H0; th arbitrary.
12505         IF(RLU(0).GT.0.5) JS=2
12506         MINT(20+JS)=21
12507         MINT(23-JS)=25
12508         KCC=17+JS
12509
12510       ELSEIF(ISUB.EQ.18) THEN
12511 C...f + fb -> gamma + gamma; th arbitrary.
12512         MINT(21)=22
12513         MINT(22)=22
12514
12515       ELSEIF(ISUB.EQ.19) THEN
12516 C...f + fb -> gamma + Z0; th arbitrary.
12517         IF(RLU(0).GT.0.5) JS=2
12518         MINT(20+JS)=22
12519         MINT(23-JS)=23
12520
12521       ELSEIF(ISUB.EQ.20) THEN
12522 C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12523         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12524         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12525         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12526         MINT(20+JS)=22
12527         MINT(23-JS)=ISIGN(24,KCH1+KCH2)
12528       ENDIF
12529
12530       ELSEIF(ISUB.LE.30) THEN
12531       IF(ISUB.EQ.21) THEN
12532 C...f + fb -> gamma + H0; th arbitrary.
12533         IF(RLU(0).GT.0.5) JS=2
12534         MINT(20+JS)=22
12535         MINT(23-JS)=25
12536
12537       ELSEIF(ISUB.EQ.22) THEN
12538 C...f + fb -> Z0 + Z0; th arbitrary.
12539         MINT(21)=23
12540         MINT(22)=23
12541
12542       ELSEIF(ISUB.EQ.23) THEN
12543 C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12544         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12545         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12546         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12547         MINT(20+JS)=23
12548         MINT(23-JS)=ISIGN(24,KCH1+KCH2)
12549
12550       ELSEIF(ISUB.EQ.24) THEN
12551 C...f + fb -> Z0 + H0; th arbitrary.
12552         IF(RLU(0).GT.0.5) JS=2
12553         MINT(20+JS)=23
12554         MINT(23-JS)=25
12555
12556       ELSEIF(ISUB.EQ.25) THEN
12557 C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.
12558         MINT(21)=-ISIGN(24,MINT(15))
12559         MINT(22)=-MINT(21)
12560
12561       ELSEIF(ISUB.EQ.26) THEN
12562 C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12563         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12564         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12565         IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12566         MINT(20+JS)=ISIGN(24,KCH1+KCH2)
12567         MINT(23-JS)=25
12568
12569       ELSEIF(ISUB.EQ.27) THEN
12570 C...f + fb -> H0 + H0.
12571
12572       ELSEIF(ISUB.EQ.28) THEN
12573 C...f + g -> f + g; th = (p(f)-p(f))**2.
12574         KCC=MINT(2)+6
12575         IF(MINT(15).EQ.21) KCC=KCC+2
12576         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12577         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12578
12579       ELSEIF(ISUB.EQ.29) THEN
12580 C...f + g -> f + gamma; th = (p(f)-p(f))**2.
12581         IF(MINT(15).EQ.21) JS=2
12582         MINT(23-JS)=22
12583         KCC=15+JS
12584         KCS=ISIGN(1,MINT(14+JS))
12585
12586       ELSEIF(ISUB.EQ.30) THEN
12587 C...f + g -> f + Z0; th = (p(f)-p(f))**2.
12588         IF(MINT(15).EQ.21) JS=2
12589         MINT(23-JS)=23
12590         KCC=15+JS
12591         KCS=ISIGN(1,MINT(14+JS))
12592       ENDIF
12593
12594       ELSEIF(ISUB.LE.40) THEN
12595       IF(ISUB.EQ.31) THEN
12596 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.
12597         IF(MINT(15).EQ.21) JS=2
12598         I=MINT(14+JS)
12599         IA=IABS(I)
12600         MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
12601         RVCKM=VINT(180+I)*RLU(0)
12602         DO 220 J=1,MSTP(1)
12603         IB=2*J-1+MOD(IA,2)
12604         IPM=(5-ISIGN(1,I))/2
12605         IDC=J+MDCY(IA,2)+2
12606         IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 220
12607         MINT(20+JS)=ISIGN(IB,I)
12608         RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12609         IF(RVCKM.LE.0.) GOTO 230
12610   220   CONTINUE
12611   230   KCC=15+JS
12612         KCS=ISIGN(1,MINT(14+JS))
12613
12614       ELSEIF(ISUB.EQ.32) THEN
12615 C...f + g -> f + H0; th = (p(f)-p(f))**2.
12616         IF(MINT(15).EQ.21) JS=2
12617         MINT(23-JS)=25
12618         KCC=15+JS
12619         KCS=ISIGN(1,MINT(14+JS))
12620
12621       ELSEIF(ISUB.EQ.33) THEN
12622 C...f + gamma -> f + g.
12623
12624       ELSEIF(ISUB.EQ.34) THEN
12625 C...f + gamma -> f + gamma.
12626
12627       ELSEIF(ISUB.EQ.35) THEN
12628 C...f + gamma -> f + Z0.
12629
12630       ELSEIF(ISUB.EQ.36) THEN
12631 C...f + gamma -> f' + W+/-.
12632
12633       ELSEIF(ISUB.EQ.37) THEN
12634 C...f + gamma -> f + H0.
12635
12636       ELSEIF(ISUB.EQ.38) THEN
12637 C...f + Z0 -> f + g.
12638
12639       ELSEIF(ISUB.EQ.39) THEN
12640 C...f + Z0 -> f + gamma.
12641
12642       ELSEIF(ISUB.EQ.40) THEN
12643 C...f + Z0 -> f + Z0.
12644       ENDIF
12645
12646       ELSEIF(ISUB.LE.50) THEN
12647       IF(ISUB.EQ.41) THEN
12648 C...f + Z0 -> f' + W+/-.
12649
12650       ELSEIF(ISUB.EQ.42) THEN
12651 C...f + Z0 -> f + H0.
12652
12653       ELSEIF(ISUB.EQ.43) THEN
12654 C...f + W+/- -> f' + g.
12655
12656       ELSEIF(ISUB.EQ.44) THEN
12657 C...f + W+/- -> f' + gamma.
12658
12659       ELSEIF(ISUB.EQ.45) THEN
12660 C...f + W+/- -> f' + Z0.
12661
12662       ELSEIF(ISUB.EQ.46) THEN
12663 C...f + W+/- -> f' + W+/-.
12664
12665       ELSEIF(ISUB.EQ.47) THEN
12666 C...f + W+/- -> f' + H0.
12667
12668       ELSEIF(ISUB.EQ.48) THEN
12669 C...f + H0 -> f + g.
12670
12671       ELSEIF(ISUB.EQ.49) THEN
12672 C...f + H0 -> f + gamma.
12673
12674       ELSEIF(ISUB.EQ.50) THEN
12675 C...f + H0 -> f + Z0.
12676       ENDIF
12677
12678       ELSEIF(ISUB.LE.60) THEN
12679       IF(ISUB.EQ.51) THEN
12680 C...f + H0 -> f' + W+/-.
12681
12682       ELSEIF(ISUB.EQ.52) THEN
12683 C...f + H0 -> f + H0.
12684
12685       ELSEIF(ISUB.EQ.53) THEN
12686 C...g + g -> f + fb; th arbitrary.
12687         KCS=(-1)**INT(1.5+RLU(0))
12688         MINT(21)=ISIGN(KFLQ,KCS)
12689         MINT(22)=-MINT(21)
12690         KCC=MINT(2)+10
12691
12692       ELSEIF(ISUB.EQ.54) THEN
12693 C...g + gamma -> f + fb.
12694
12695       ELSEIF(ISUB.EQ.55) THEN
12696 C...g + Z0 -> f + fb.
12697
12698       ELSEIF(ISUB.EQ.56) THEN
12699 C...g + W+/- -> f + fb'.
12700
12701       ELSEIF(ISUB.EQ.57) THEN
12702 C...g + H0 -> f + fb.
12703
12704       ELSEIF(ISUB.EQ.58) THEN
12705 C...gamma + gamma -> f + fb.
12706
12707       ELSEIF(ISUB.EQ.59) THEN
12708 C...gamma + Z0 -> f + fb.
12709
12710       ELSEIF(ISUB.EQ.60) THEN
12711 C...gamma + W+/- -> f + fb'.
12712       ENDIF
12713
12714       ELSEIF(ISUB.LE.70) THEN
12715       IF(ISUB.EQ.61) THEN
12716 C...gamma + H0 -> f + fb.
12717
12718       ELSEIF(ISUB.EQ.62) THEN
12719 C...Z0 + Z0 -> f + fb.
12720
12721       ELSEIF(ISUB.EQ.63) THEN
12722 C...Z0 + W+/- -> f + fb'.
12723
12724       ELSEIF(ISUB.EQ.64) THEN
12725 C...Z0 + H0 -> f + fb.
12726
12727       ELSEIF(ISUB.EQ.65) THEN
12728 C...W+ + W- -> f + fb.
12729
12730       ELSEIF(ISUB.EQ.66) THEN
12731 C...W+/- + H0 -> f + fb'.
12732
12733       ELSEIF(ISUB.EQ.67) THEN
12734 C...H0 + H0 -> f + fb.
12735
12736       ELSEIF(ISUB.EQ.68) THEN
12737 C...g + g -> g + g; th arbitrary.
12738         KCC=MINT(2)+12
12739         KCS=(-1)**INT(1.5+RLU(0))
12740
12741       ELSEIF(ISUB.EQ.69) THEN
12742 C...gamma + gamma -> W+ + W-.
12743
12744       ELSEIF(ISUB.EQ.70) THEN
12745 C...gamma + W+/- -> gamma + W+/-
12746       ENDIF
12747
12748       ELSEIF(ISUB.LE.80) THEN
12749       IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
12750 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-.
12751         XH=SH/SHP
12752         MINT(21)=MINT(15)
12753         MINT(22)=MINT(16)
12754         PMQ(1)=ULMASS(MINT(21))
12755         PMQ(2)=ULMASS(MINT(22))
12756   290   JT=INT(1.5+RLU(0))
12757         ZMIN=2.*PMQ(JT)/SHPR
12758         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12759         ZMAX=MIN(1.-XH,ZMAX)
12760         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12761         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12762      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 290
12763         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12764         IF(SQC1.LT.1.E-8) GOTO 290
12765         C1=SQRT(SQC1)
12766         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12767         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12768         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12769         Z(3-JT)=1.-XH/(1.-Z(JT))
12770         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12771         IF(SQC1.LT.1.E-8) GOTO 290
12772         C1=SQRT(SQC1)
12773         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12774         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12775         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12776         PHIR=PARU(2)*RLU(0)
12777         CPHI=COS(PHIR)
12778         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12779         Z1=2.-Z(JT)
12780         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12781         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12782         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12783      &  PMQ(3-JT)**2/SHP))
12784         ZMIN=2.*PMQ(3-JT)/SHPR
12785         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12786         ZMAX=MIN(1.-XH,ZMAX)
12787         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 290
12788         KCC=22
12789
12790       ELSEIF(ISUB.EQ.73) THEN
12791 C...Z0 + W+/- -> Z0 + W+/-.
12792         XH=SH/SHP
12793   300   JT=INT(1.5+RLU(0))
12794         I=MINT(14+JT)
12795         IA=IABS(I)
12796         IF(IA.LE.10) THEN
12797           RVCKM=VINT(180+I)*RLU(0)
12798           DO 320 J=1,MSTP(1)
12799           IB=2*J-1+MOD(IA,2)
12800           IPM=(5-ISIGN(1,I))/2
12801           IDC=J+MDCY(IA,2)+2
12802           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 320
12803           MINT(20+JT)=ISIGN(IB,I)
12804           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12805           IF(RVCKM.LE.0.) GOTO 330
12806   320     CONTINUE
12807         ELSE
12808           IB=2*((IA+1)/2)-1+MOD(IA,2)
12809           MINT(20+JT)=ISIGN(IB,I)
12810         ENDIF
12811   330   PMQ(JT)=ULMASS(MINT(20+JT))
12812         MINT(23-JT)=MINT(17-JT)
12813         PMQ(3-JT)=ULMASS(MINT(23-JT))
12814         JT=INT(1.5+RLU(0))
12815         ZMIN=2.*PMQ(JT)/SHPR
12816         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12817         ZMAX=MIN(1.-XH,ZMAX)
12818         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12819         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12820      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 300
12821         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12822         IF(SQC1.LT.1.E-8) GOTO 300
12823         C1=SQRT(SQC1)
12824         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12825         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12826         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12827         Z(3-JT)=1.-XH/(1.-Z(JT))
12828         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12829         IF(SQC1.LT.1.E-8) GOTO 300
12830         C1=SQRT(SQC1)
12831         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12832         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12833         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12834         PHIR=PARU(2)*RLU(0)
12835         CPHI=COS(PHIR)
12836         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12837         Z1=2.-Z(JT)
12838         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12839         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12840         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12841      &  PMQ(3-JT)**2/SHP))
12842         ZMIN=2.*PMQ(3-JT)/SHPR
12843         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12844         ZMAX=MIN(1.-XH,ZMAX)
12845         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 300
12846         KCC=22
12847
12848       ELSEIF(ISUB.EQ.74) THEN
12849 C...Z0 + H0 -> Z0 + H0.
12850
12851       ELSEIF(ISUB.EQ.75) THEN
12852 C...W+ + W- -> gamma + gamma.
12853
12854       ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
12855 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-.
12856         XH=SH/SHP
12857   340   DO 370 JT=1,2
12858         I=MINT(14+JT)
12859         IA=IABS(I)
12860         IF(IA.LE.10) THEN
12861           RVCKM=VINT(180+I)*RLU(0)
12862           DO 360 J=1,MSTP(1)
12863           IB=2*J-1+MOD(IA,2)
12864           IPM=(5-ISIGN(1,I))/2
12865           IDC=J+MDCY(IA,2)+2
12866           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 360
12867           MINT(20+JT)=ISIGN(IB,I)
12868           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12869           IF(RVCKM.LE.0.) GOTO 370
12870   360     CONTINUE
12871         ELSE
12872           IB=2*((IA+1)/2)-1+MOD(IA,2)
12873           MINT(20+JT)=ISIGN(IB,I)
12874         ENDIF
12875   370   PMQ(JT)=ULMASS(MINT(20+JT))
12876         JT=INT(1.5+RLU(0))
12877         ZMIN=2.*PMQ(JT)/SHPR
12878         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12879         ZMAX=MIN(1.-XH,ZMAX)
12880         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12881         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12882      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 340
12883         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12884         IF(SQC1.LT.1.E-8) GOTO 340
12885         C1=SQRT(SQC1)
12886         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12887         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12888         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12889         Z(3-JT)=1.-XH/(1.-Z(JT))
12890         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12891         IF(SQC1.LT.1.E-8) GOTO 340
12892         C1=SQRT(SQC1)
12893         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12894         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12895         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12896         PHIR=PARU(2)*RLU(0)
12897         CPHI=COS(PHIR)
12898         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12899         Z1=2.-Z(JT)
12900         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12901         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12902         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12903      &  PMQ(3-JT)**2/SHP))
12904         ZMIN=2.*PMQ(3-JT)/SHPR
12905         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12906         ZMAX=MIN(1.-XH,ZMAX)
12907         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
12908         KCC=22
12909
12910       ELSEIF(ISUB.EQ.78) THEN
12911 C...W+/- + H0 -> W+/- + H0.
12912
12913       ELSEIF(ISUB.EQ.79) THEN
12914 C...H0 + H0 -> H0 + H0.
12915       ENDIF
12916
12917       ELSEIF(ISUB.LE.90) THEN
12918       IF(ISUB.EQ.81) THEN
12919 C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.
12920         MINT(21)=ISIGN(MINT(46),MINT(15))
12921         MINT(22)=-MINT(21)
12922         KCC=4
12923
12924       ELSEIF(ISUB.EQ.82) THEN
12925 C...g + g -> Q + Qb; th arbitrary.
12926         KCS=(-1)**INT(1.5+RLU(0))
12927         MINT(21)=ISIGN(MINT(46),KCS)
12928         MINT(22)=-MINT(21)
12929         KCC=MINT(2)+10
12930       ENDIF
12931
12932       ELSEIF(ISUB.LE.100) THEN
12933       IF(ISUB.EQ.95) THEN
12934 C...Low-pT ( = energyless g + g -> g + g).
12935         KCC=MINT(2)+12
12936         KCS=(-1)**INT(1.5+RLU(0))
12937
12938       ELSEIF(ISUB.EQ.96) THEN
12939 C...Multiple interactions (should be reassigned to QCD process).
12940       ENDIF
12941
12942       ELSEIF(ISUB.LE.110) THEN
12943       IF(ISUB.EQ.101) THEN
12944 C...g + g -> gamma*/Z0.
12945         KCC=21
12946         KFRES=22
12947
12948       ELSEIF(ISUB.EQ.102) THEN
12949 C...g + g -> H0.
12950         KCC=21
12951         KFRES=25
12952       ENDIF
12953
12954       ELSEIF(ISUB.LE.120) THEN
12955       IF(ISUB.EQ.111) THEN
12956 C...f + fb -> g + H0; th arbitrary.
12957         IF(RLU(0).GT.0.5) JS=2
12958         MINT(20+JS)=21
12959         MINT(23-JS)=25
12960         KCC=17+JS
12961
12962       ELSEIF(ISUB.EQ.112) THEN
12963 C...f + g -> f + H0; th = (p(f) - p(f))**2.
12964         IF(MINT(15).EQ.21) JS=2
12965         MINT(23-JS)=25
12966         KCC=15+JS
12967         KCS=ISIGN(1,MINT(14+JS))
12968
12969       ELSEIF(ISUB.EQ.113) THEN
12970 C...g + g -> g + H0; th arbitrary.
12971         IF(RLU(0).GT.0.5) JS=2
12972         MINT(23-JS)=25
12973         KCC=22+JS
12974         KCS=(-1)**INT(1.5+RLU(0))
12975
12976       ELSEIF(ISUB.EQ.114) THEN
12977 C...g + g -> gamma + gamma; th arbitrary.
12978         IF(RLU(0).GT.0.5) JS=2
12979         MINT(21)=22
12980         MINT(22)=22
12981         KCC=21
12982
12983       ELSEIF(ISUB.EQ.115) THEN
12984 C...g + g -> gamma + Z0.
12985
12986       ELSEIF(ISUB.EQ.116) THEN
12987 C...g + g -> Z0 + Z0.
12988
12989       ELSEIF(ISUB.EQ.117) THEN
12990 C...g + g -> W+ + W-.
12991       ENDIF
12992
12993       ELSEIF(ISUB.LE.140) THEN
12994       IF(ISUB.EQ.121) THEN
12995 C...g + g -> f + fb + H0.
12996       ENDIF
12997
12998       ELSEIF(ISUB.LE.160) THEN
12999       IF(ISUB.EQ.141) THEN
13000 C...f + fb -> gamma*/Z0/Z'0.
13001         KFRES=32
13002
13003       ELSEIF(ISUB.EQ.142) THEN
13004 C...f + fb' -> H+/-.
13005         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
13006         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
13007         KFRES=ISIGN(37,KCH1+KCH2)
13008
13009       ELSEIF(ISUB.EQ.143) THEN
13010 C...f + fb' -> R.
13011         KFRES=ISIGN(40,MINT(15)+MINT(16))
13012       ENDIF
13013
13014       ELSE
13015       IF(ISUB.EQ.161) THEN
13016 C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.
13017         IF(MINT(16).EQ.21) JS=2
13018         IA=IABS(MINT(17-JS))
13019         MINT(20+JS)=ISIGN(37,KCHG(IA,1)*MINT(17-JS))
13020         JA=IA+MOD(IA,2)-MOD(IA+1,2)
13021         MINT(23-JS)=ISIGN(JA,MINT(17-JS))
13022         KCC=18-JS
13023         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
13024         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
13025       ENDIF
13026       ENDIF
13027
13028       IF(IDOC.EQ.7) THEN
13029 C...Resonance not decaying: store colour connection indices.
13030         I=MINT(83)+7
13031         K(IPU3,1)=1
13032         K(IPU3,2)=KFRES
13033         K(IPU3,3)=I
13034         P(IPU3,4)=SHUSER
13035         P(IPU3,5)=SHUSER
13036         K(IPU1,4)=IPU2
13037         K(IPU1,5)=IPU2
13038         K(IPU2,4)=IPU1
13039         K(IPU2,5)=IPU1
13040         K(I,1)=21
13041         K(I,2)=KFRES
13042         P(I,4)=SHUSER
13043         P(I,5)=SHUSER
13044         N=IPU3
13045         MINT(21)=KFRES
13046         MINT(22)=0
13047
13048       ELSEIF(IDOC.EQ.8) THEN
13049 C...2 -> 2 processes: store outgoing partons in their CM-frame.
13050         DO 390 JT=1,2
13051         I=MINT(84)+2+JT
13052         K(I,1)=1
13053         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
13054         K(I,2)=MINT(20+JT)
13055         K(I,3)=MINT(83)+IDOC+JT-2
13056         IF(IABS(K(I,2)).LE.10.OR.K(I,2).EQ.21) THEN
13057           P(I,5)=ULMASS(K(I,2))
13058         ELSE
13059           P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13060         ENDIF
13061   390   CONTINUE
13062         IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13063           KFA1=IABS(MINT(21))
13064           KFA2=IABS(MINT(22))
13065           IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13066      &    THEN
13067             MINT(51)=1
13068             RETURN
13069           ENDIF
13070           P(IPU3,5)=0.
13071           P(IPU4,5)=0.
13072         ENDIF
13073         P(IPU3,4)=0.5*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13074         P(IPU3,3)=SQRT(MAX(0.,P(IPU3,4)**2-P(IPU3,5)**2))
13075         P(IPU4,4)=SHR-P(IPU3,4)
13076         P(IPU4,3)=-P(IPU3,3)
13077         N=IPU4
13078         MINT(7)=MINT(83)+7
13079         MINT(8)=MINT(83)+8
13080
13081 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4).
13082         CALL LUDBRB(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13083
13084       ELSEIF(IDOC.EQ.9) THEN
13085 C'''2 -> 3 processes:
13086
13087       ELSEIF(IDOC.EQ.11) THEN
13088 C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons.
13089         PHI(1)=PARU(2)*RLU(0)
13090         PHI(2)=PHI(1)-PHIR
13091         DO 400 JT=1,2
13092         I=MINT(84)+2+JT
13093         K(I,1)=1
13094         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
13095         K(I,2)=MINT(20+JT)
13096         K(I,3)=MINT(83)+IDOC+JT-2
13097         P(I,5)=ULMASS(K(I,2))
13098         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
13099         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
13100         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
13101         P(I,1)=PTABS*COS(PHI(JT))
13102         P(I,2)=PTABS*SIN(PHI(JT))
13103         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13104         P(I,4)=0.5*SHPR*Z(JT)
13105         IZW=MINT(83)+6+JT
13106         K(IZW,1)=21
13107         K(IZW,2)=23
13108         IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT)))
13109         K(IZW,3)=IZW-2
13110         P(IZW,1)=-P(I,1)
13111         P(IZW,2)=-P(I,2)
13112         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13113         P(IZW,4)=0.5*SHPR*(1.-Z(JT))
13114   400   P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13115         I=MINT(83)+9
13116         K(IPU5,1)=1
13117         K(IPU5,2)=KFRES
13118         K(IPU5,3)=I
13119         P(IPU5,5)=SHR
13120         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13121         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13122         P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13123         P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13124         K(I,1)=21
13125         K(I,2)=KFRES
13126         DO 410 J=1,5
13127   410   P(I,J)=P(IPU5,J)
13128         N=IPU5
13129         MINT(23)=KFRES
13130
13131       ELSEIF(IDOC.EQ.12) THEN
13132 C...Z0 and W+/- scattering: store bosons and outgoing partons.
13133         PHI(1)=PARU(2)*RLU(0)
13134         PHI(2)=PHI(1)-PHIR
13135         DO 420 JT=1,2
13136         I=MINT(84)+2+JT
13137         K(I,1)=1
13138         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
13139         K(I,2)=MINT(20+JT)
13140         K(I,3)=MINT(83)+IDOC+JT-2
13141         P(I,5)=ULMASS(K(I,2))
13142         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
13143         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
13144         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
13145         P(I,1)=PTABS*COS(PHI(JT))
13146         P(I,2)=PTABS*SIN(PHI(JT))
13147         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13148         P(I,4)=0.5*SHPR*Z(JT)
13149         IZW=MINT(83)+6+JT
13150         K(IZW,1)=21
13151         IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13152           K(IZW,2)=23
13153         ELSE
13154           K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT))-LUCHGE(MINT(20+JT)))
13155         ENDIF
13156         K(IZW,3)=IZW-2
13157         P(IZW,1)=-P(I,1)
13158         P(IZW,2)=-P(I,2)
13159         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13160         P(IZW,4)=0.5*SHPR*(1.-Z(JT))
13161         P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13162         IPU=MINT(84)+4+JT
13163         K(IPU,1)=3
13164         K(IPU,2)=KFPR(ISUB,JT)
13165         K(IPU,3)=MINT(83)+8+JT
13166         IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13167           P(IPU,5)=ULMASS(K(IPU,2))
13168         ELSE
13169           P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13170         ENDIF
13171         MINT(22+JT)=K(IZW,2)
13172   420   CONTINUE
13173         IF(ISUB.EQ.72) K(MINT(84)+4+INT(1.5+RLU(0)),2)=-24
13174 C...Find rotation and boost for hard scattering subsystem.
13175         I1=MINT(83)+7
13176         I2=MINT(83)+8
13177         BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13178         BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13179         BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13180         GAMCM=(P(I1,4)+P(I2,4))/SHR
13181         BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13182         PX=P(I1,1)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEXCM
13183         PY=P(I1,2)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEYCM
13184         PZ=P(I1,3)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEZCM
13185         THECM=ULANGL(PZ,SQRT(PX**2+PY**2))
13186         PHICM=ULANGL(PX,PY)
13187 C...Store hard scattering subsystem. Rotate and boost it.
13188         SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4.*P(IPU5,5)**2*
13189      &  P(IPU6,5)**2
13190         PABS=SQRT(MAX(0.,SQLAM/(4.*SH)))
13191         CTHWZ=VINT(23)
13192         STHWZ=SQRT(MAX(0.,1.-CTHWZ**2))
13193         PHIWZ=VINT(24)-PHICM
13194         P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13195         P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13196         P(IPU5,3)=PABS*CTHWZ
13197         P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13198         P(IPU6,1)=-P(IPU5,1)
13199         P(IPU6,2)=-P(IPU5,2)
13200         P(IPU6,3)=-P(IPU5,3)
13201         P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13202         CALL LUDBRB(IPU5,IPU6,THECM,PHICM,DBLE(BEXCM),DBLE(BEYCM),
13203      &  DBLE(BEZCM))
13204         DO 430 JT=1,2
13205         I1=MINT(83)+8+JT
13206         I2=MINT(84)+4+JT
13207         K(I1,1)=21
13208         K(I1,2)=K(I2,2)
13209         DO 430 J=1,5
13210   430   P(I1,J)=P(I2,J)
13211         N=IPU6
13212         MINT(7)=MINT(83)+9
13213         MINT(8)=MINT(83)+10
13214       ENDIF
13215
13216       IF(IDOC.GE.8) THEN
13217 C...Store colour connection indices.
13218         DO 440 J=1,2
13219         JC=J
13220         IF(KCS.EQ.-1) JC=3-J
13221         IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13222      &  K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13223         IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13224      &  K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13225         IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13226      &  MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13227   440   IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13228      &  MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13229
13230 C...Copy outgoing partons to documentation lines.
13231         DO 450 I=1,2
13232         I1=MINT(83)+IDOC-2+I
13233         I2=MINT(84)+2+I
13234         K(I1,1)=21
13235         K(I1,2)=K(I2,2)
13236         IF(IDOC.LE.9) K(I1,3)=0
13237         IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13238         DO 450 J=1,5
13239   450   P(I1,J)=P(I2,J)
13240       ENDIF
13241       MINT(52)=N
13242
13243 C...Low-pT events: remove gluons used for string drawing purposes.
13244       IF(ISUB.EQ.95) THEN
13245         K(IPU3,1)=K(IPU3,1)+10
13246         K(IPU4,1)=K(IPU4,1)+10
13247         DO 460 J=41,66
13248   460   VINT(J)=0.
13249         DO 470 I=MINT(83)+5,MINT(83)+8
13250         DO 470 J=1,5
13251   470   P(I,J)=0.
13252       ENDIF
13253
13254       RETURN
13255       END
13256
13257 C*********************************************************************
13258
13259       SUBROUTINE PYSSPA(IPU1,IPU2)
13260
13261 C...Generates spacelike parton showers.
13262       IMPLICIT DOUBLE PRECISION(D)
13263       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
13264       SAVE /LUJETS/
13265       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13266       SAVE /LUDAT1/
13267       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
13268       SAVE /LUDAT2/
13269       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
13270       SAVE /PYSUBS/
13271       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13272       SAVE /PYPARS/
13273       COMMON/PYINT1/MINT(400),VINT(400)
13274       SAVE /PYINT1/
13275       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
13276       SAVE /PYINT2/
13277       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13278       SAVE /PYINT3/
13279       DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVS(2),ROBO(5),
13280      &XFS(2,-6:6),XFA(-6:6),XFB(-6:6),XFN(-6:6),WTAP(-6:6),WTSF(-6:6),
13281      &THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),DPB(4)
13282
13283 C...Calculate maximum virtuality and check that evolution possible.
13284       IPUS1=IPU1
13285       IPUS2=IPU2
13286       ISUB=MINT(1)
13287       Q2E=VINT(52)
13288       IF(ISET(ISUB).EQ.1) THEN
13289         Q2E=Q2E/PARP(67)
13290       ELSEIF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
13291         Q2E=PMAS(23,1)**2
13292         IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2E=PMAS(24,1)**2
13293       ENDIF
13294       TMAX=LOG(PARP(67)*PARP(63)*Q2E/PARP(61)**2)
13295       IF(PARP(67)*Q2E.LT.MAX(PARP(62)**2,2.*PARP(61)**2).OR.
13296      &TMAX.LT.0.2) RETURN
13297
13298 C...Common constants and initial values. Save normal Lambda value.
13299       XE0=2.*PARP(65)/VINT(1)
13300       ALAMS=PARU(111)
13301       PARU(111)=PARP(61)
13302       NS=N
13303   100 N=NS
13304       DO 110 JT=1,2
13305       KFLS(JT)=MINT(14+JT)
13306       KFLS(JT+2)=KFLS(JT)
13307       XS(JT)=VINT(40+JT)
13308       ZS(JT)=1.
13309       Q2S(JT)=PARP(67)*Q2E
13310       TEVS(JT)=TMAX
13311       ALAM(JT)=PARP(61)
13312       THE2(JT)=100.
13313       DO 110 KFL=-6,6
13314   110 XFS(JT,KFL)=XSFX(JT,KFL)
13315       DSH=VINT(44)
13316       IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) DSH=VINT(26)*VINT(2)
13317
13318 C...Pick up leg with highest virtuality.
13319   120 N=N+1
13320       JT=1
13321       IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13322       KFLB=KFLS(JT)
13323       XB=XS(JT)
13324       DO 130 KFL=-6,6
13325   130 XFB(KFL)=XFS(JT,KFL)
13326       DSHR=2D0*SQRT(DSH)
13327       DSHZ=DSH/DBLE(ZS(JT))
13328       XE=MAX(XE0,XB*(1./(1.-PARP(66))-1.))
13329       IF(XB+XE.GE.0.999) THEN
13330         Q2B=0.
13331         GOTO 220
13332       ENDIF
13333
13334 C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.
13335       IF(MSTP(62).LE.1) THEN
13336         Q2B=0.5*(1./ZS(JT)+1.)*Q2S(JT)+0.5*(1./ZS(JT)-1.)*(Q2S(3-JT)-
13337      &  SNGL(DSH)+SQRT((SNGL(DSH)+Q2S(1)+Q2S(2))**2+8.*Q2S(1)*Q2S(2)*
13338      &  ZS(JT)/(1.-ZS(JT))))
13339         TEVB=LOG(PARP(63)*Q2B/ALAM(JT)**2)
13340       ELSE
13341         Q2B=Q2S(JT)
13342         TEVB=TEVS(JT)
13343       ENDIF
13344       ALSDUM=ULALPS(PARP(63)*Q2B)
13345       TEVB=TEVB+2.*LOG(ALAM(JT)/PARU(117))
13346       TEVBSV=TEVB
13347       ALAM(JT)=PARU(117)
13348       B0=(33.-2.*MSTU(118))/6.
13349
13350 C...Calculate Altarelli-Parisi and structure function weights.
13351       DO 140 KFL=-6,6
13352       WTAP(KFL)=0.
13353   140 WTSF(KFL)=0.
13354       IF(KFLB.EQ.21) THEN
13355         WTAPQ=16.*(1.-SQRT(XB+XE))/(3.*SQRT(XB))
13356         DO 150 KFL=-MSTP(54),MSTP(54)
13357         IF(KFL.EQ.0) WTAP(KFL)=6.*LOG((1.-XB)/XE)
13358   150   IF(KFL.NE.0) WTAP(KFL)=WTAPQ
13359       ELSE
13360         WTAP(0)=0.5*XB*(1./(XB+XE)-1.)
13361         WTAP(KFLB)=8.*LOG((1.-XB)*(XB+XE)/XE)/3.
13362       ENDIF
13363   160 WTSUM=0.
13364       IF(KFLB.NE.21) XFBO=XFB(KFLB)
13365       IF(KFLB.EQ.21) XFBO=XFB(0)
13366 C***************************************************************
13367 C**********ERROR HAS OCCURED HERE
13368       IF(XFBO.EQ.0.0) THEN
13369                 WRITE(MSTU(11),1000)
13370                 WRITE(MSTU(11),1001) KFLB,XFB(KFLB)
13371                 XFBO=0.00001
13372       ENDIF
13373 C****************************************************************
13374       DO 170 KFL=-MSTP(54),MSTP(54)
13375       WTSF(KFL)=XFB(KFL)/XFBO
13376   170 WTSUM=WTSUM+WTAP(KFL)*WTSF(KFL)
13377       WTSUM=MAX(0.0001,WTSUM)
13378
13379 C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).
13380   180 IF(MSTP(64).LE.0) THEN
13381         TEVB=TEVB+LOG(RLU(0))*PARU(2)/(PARU(111)*WTSUM)
13382       ELSEIF(MSTP(64).EQ.1) THEN
13383         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/WTSUM))
13384       ELSE
13385         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/(5.*WTSUM)))
13386       ENDIF
13387   190 Q2REF=ALAM(JT)**2*EXP(TEVB)
13388       Q2B=Q2REF/PARP(63)
13389
13390 C...Evolution ended or select flavour for branching parton.
13391       IF(Q2B.LT.PARP(62)**2) THEN
13392         Q2B=0.
13393       ELSE
13394         WTRAN=RLU(0)*WTSUM
13395         KFLA=-MSTP(54)-1
13396   200   KFLA=KFLA+1
13397         WTRAN=WTRAN-WTAP(KFLA)*WTSF(KFLA)
13398         IF(KFLA.LT.MSTP(54).AND.WTRAN.GT.0.) GOTO 200
13399         IF(KFLA.EQ.0) KFLA=21
13400
13401 C...Choose z value and corrective weight.
13402         IF(KFLB.EQ.21.AND.KFLA.EQ.21) THEN
13403           Z=1./(1.+((1.-XB)/XB)*(XE/(1.-XB))**RLU(0))
13404           WTZ=(1.-Z*(1.-Z))**2
13405         ELSEIF(KFLB.EQ.21) THEN
13406           Z=XB/(1.-RLU(0)*(1.-SQRT(XB+XE)))**2
13407           WTZ=0.5*(1.+(1.-Z)**2)*SQRT(Z)
13408         ELSEIF(KFLA.EQ.21) THEN
13409           Z=XB*(1.+RLU(0)*(1./(XB+XE)-1.))
13410           WTZ=1.-2.*Z*(1.-Z)
13411         ELSE
13412           Z=1.-(1.-XB)*(XE/((XB+XE)*(1.-XB)))**RLU(0)
13413           WTZ=0.5*(1.+Z**2)
13414         ENDIF
13415
13416 C...Option with resummation of soft gluon emission as effective z shift.
13417         IF(MSTP(65).GE.1) THEN
13418           RSOFT=6.
13419           IF(KFLB.NE.21) RSOFT=8./3.
13420           Z=Z*(TEVB/TEVS(JT))**(RSOFT*XE/((XB+XE)*B0))
13421           IF(Z.LE.XB) GOTO 180
13422         ENDIF
13423
13424 C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.
13425         IF(MSTP(64).GE.2) THEN
13426           IF((1.-Z)*Q2B.LT.PARP(62)**2) GOTO 180
13427           ALPRAT=TEVB/(TEVB+LOG(1.-Z))
13428           IF(ALPRAT.LT.5.*RLU(0)) GOTO 180
13429           IF(ALPRAT.GT.5.) WTZ=WTZ*ALPRAT/5.
13430         ENDIF
13431
13432 C...Option with angular ordering requirement.
13433         IF(MSTP(62).GE.3) THEN
13434           THE2T=(4.*Z**2*Q2B)/(VINT(2)*(1.-Z)*XB**2)
13435           IF(THE2T.GT.THE2(JT)) GOTO 180
13436         ENDIF
13437
13438 C...Weighting with new structure functions.
13439         CALL PYSTFU(MINT(10+JT),XB,Q2REF,XFN,JT)
13440         IF(KFLB.NE.21) XFBN=XFN(KFLB)
13441         IF(KFLB.EQ.21) XFBN=XFN(0)
13442         IF(XFBN.LT.1E-20) THEN
13443           IF(KFLA.EQ.KFLB) THEN
13444             TEVB=TEVBSV
13445             WTAP(KFLB)=0.
13446             GOTO 160
13447           ELSEIF(TEVBSV-TEVB.GT.0.2) THEN
13448             TEVB=0.5*(TEVBSV+TEVB)
13449             GOTO 190
13450           ELSE
13451             XFBN=1E-10
13452           ENDIF
13453         ENDIF
13454         DO 210 KFL=-MSTP(54),MSTP(54)
13455   210   XFB(KFL)=XFN(KFL)
13456         XA=XB/Z
13457         CALL PYSTFU(MINT(10+JT),XA,Q2REF,XFA,JT)
13458         IF(KFLA.NE.21) XFAN=XFA(KFLA)
13459         IF(KFLA.EQ.21) XFAN=XFA(0)
13460         IF(XFAN.LT.1E-20) GOTO 160
13461         IF(KFLA.NE.21) WTSFA=WTSF(KFLA)
13462         IF(KFLA.EQ.21) WTSFA=WTSF(0)
13463         IF(WTZ*XFAN/XFBN.LT.RLU(0)*WTSFA) GOTO 160
13464       ENDIF
13465
13466 C...Define two hard scatterers in their CM-frame.
13467   220 IF(N.EQ.NS+2) THEN
13468         DQ2(JT)=Q2B
13469         DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13470         DO 240 JR=1,2
13471         I=NS+JR
13472         IF(JR.EQ.1) IPO=IPUS1
13473         IF(JR.EQ.2) IPO=IPUS2
13474         DO 230 J=1,5
13475         K(I,J)=0
13476         P(I,J)=0.
13477   230   V(I,J)=0.
13478         K(I,1)=14
13479         K(I,2)=KFLS(JR+2)
13480         K(I,4)=IPO
13481         K(I,5)=IPO
13482         P(I,3)=DPLCM*(-1)**(JR+1)
13483         P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13484         P(I,5)=-SQRT(SNGL(DQ2(JR)))
13485         K(IPO,1)=14
13486         K(IPO,3)=I
13487         K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13488   240   K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13489
13490 C...Find maximum allowed mass of timelike parton.
13491       ELSEIF(N.GT.NS+2) THEN
13492         JR=3-JT
13493         DQ2(3)=Q2B
13494         DPC(1)=P(IS(1),4)
13495         DPC(2)=P(IS(2),4)
13496         DPC(3)=0.5*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13497         DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13498         DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13499         DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13500         DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13501         IKIN=0
13502         IF(Q2S(JR).GE.(0.5*PARP(62))**2.AND.DPD(1)-DPD(3).GE.
13503      &  1D-10*DPD(1)) IKIN=1
13504         IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/DBLE(ZS(JT))-DQ2(3))*(DSH/
13505      &  (DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13506         IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/(2.*
13507      &  DQ2(JR))-DQ2(JT)-DQ2(3)
13508
13509 C...Generate timelike parton shower (if required).
13510         IT=N
13511         DO 250 J=1,5
13512         K(IT,J)=0
13513         P(IT,J)=0.
13514   250   V(IT,J)=0.
13515         K(IT,1)=3
13516         K(IT,2)=21
13517         IF(KFLB.EQ.21.AND.KFLS(JT+2).NE.21) K(IT,2)=-KFLS(JT+2)
13518         IF(KFLB.NE.21.AND.KFLS(JT+2).EQ.21) K(IT,2)=KFLB
13519         P(IT,5)=ULMASS(K(IT,2))
13520         IF(SNGL(DMSMA).LE.P(IT,5)**2) GOTO 100
13521         IF(MSTP(63).GE.1) THEN
13522           P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13523           P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13524           IF(MSTP(63).EQ.1) THEN
13525             Q2TIM=DMSMA
13526           ELSEIF(MSTP(63).EQ.2) THEN
13527             Q2TIM=MIN(SNGL(DMSMA),PARP(71)*Q2S(JT))
13528           ELSE
13529 C'''Here remains to introduce angular ordering in first branching.
13530             Q2TIM=DMSMA
13531           ENDIF
13532           CALL LUSHOW(IT,0,SQRT(Q2TIM))
13533           IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13534         ENDIF
13535
13536 C...Reconstruct kinematics of branching: timelike parton shower.
13537         DMS=P(IT,5)**2
13538         IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13539         IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5*DPD(1)*DPD(2)+0.5*DPD(3)*
13540      &  DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.*DSH*DPC(3)**2)
13541         IF(DPT2.LT.0.) GOTO 100
13542         DPB(1)=(0.5*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13543      &  DSHR)/DPC(3)-DPC(3)
13544         P(IT,1)=SQRT(SNGL(DPT2))
13545         P(IT,3)=DPB(1)*(-1)**(JT+1)
13546         P(IT,4)=(DSHZ-DSH-DMS)/DSHR
13547         IF(N.GE.IT+1) THEN
13548           DPB(1)=SQRT(DPB(1)**2+DPT2)
13549           DPB(2)=SQRT(DPB(1)**2+DMS)
13550           DPB(3)=P(IT+1,3)
13551           DPB(4)=SQRT(DPB(3)**2+DMS)
13552           DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13553      &    DPB(1))
13554           CALL LUDBRB(IT+1,N,0.,0.,0D0,0D0,DBEZ)
13555           THE=ULANGL(P(IT,3),P(IT,1))
13556           CALL LUDBRB(IT+1,N,THE,0.,0D0,0D0,0D0)
13557         ENDIF
13558
13559 C...Reconstruct kinematics of branching: spacelike parton.
13560         DO 260 J=1,5
13561         K(N+1,J)=0
13562         P(N+1,J)=0.
13563   260   V(N+1,J)=0.
13564         K(N+1,1)=14
13565         K(N+1,2)=KFLB
13566         P(N+1,1)=P(IT,1)
13567         P(N+1,3)=P(IT,3)+P(IS(JT),3)
13568         P(N+1,4)=P(IT,4)+P(IS(JT),4)
13569         P(N+1,5)=-SQRT(SNGL(DQ2(3)))
13570
13571 C...Define colour flow of branching.
13572         K(IS(JT),3)=N+1
13573         K(IT,3)=N+1
13574         ID1=IT
13575         IF((K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(ID1,2).GT.0.AND.
13576      &  K(ID1,2).NE.21).OR.(K(N+1,2).LT.0.AND.K(ID1,2).EQ.21).OR.
13577      &  (K(N+1,2).EQ.21.AND.K(ID1,2).EQ.21.AND.RLU(0).GT.0.5).OR.
13578      &  (K(N+1,2).EQ.21.AND.K(ID1,2).LT.0)) ID1=IS(JT)
13579         ID2=IT+IS(JT)-ID1
13580         K(N+1,4)=K(N+1,4)+ID1
13581         K(N+1,5)=K(N+1,5)+ID2
13582         K(ID1,4)=K(ID1,4)+MSTU(5)*(N+1)
13583         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13584         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13585         K(ID2,5)=K(ID2,5)+MSTU(5)*(N+1)
13586         N=N+1
13587
13588 C...Boost to new CM-frame.
13589         CALL LUDBRB(NS+1,N,0.,0.,-DBLE((P(N,1)+P(IS(JR),1))/(P(N,4)+
13590      &  P(IS(JR),4))),0D0,-DBLE((P(N,3)+P(IS(JR),3))/(P(N,4)+
13591      &  P(IS(JR),4))))
13592         IR=N+(JT-1)*(IS(1)-N)
13593         CALL LUDBRB(NS+1,N,-ULANGL(P(IR,3),P(IR,1)),PARU(2)*RLU(0),
13594      &  0D0,0D0,0D0)
13595       ENDIF
13596
13597 C...Save quantities, loop back.
13598       IS(JT)=N
13599       Q2S(JT)=Q2B
13600       DQ2(JT)=Q2B
13601       IF(MSTP(62).GE.3) THE2(JT)=THE2T
13602       DSH=DSHZ
13603       IF(Q2B.GE.(0.5*PARP(62))**2) THEN
13604         KFLS(JT+2)=KFLS(JT)
13605         KFLS(JT)=KFLA
13606         XS(JT)=XA
13607         ZS(JT)=Z
13608         DO 270 KFL=-6,6
13609   270   XFS(JT,KFL)=XFA(KFL)
13610         TEVS(JT)=TEVB
13611       ELSE
13612         IF(JT.EQ.1) IPU1=N
13613         IF(JT.EQ.2) IPU2=N
13614       ENDIF
13615       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13616         CALL LUERRM(11,'(PYSSPA:) no more memory left in LUJETS')
13617         IF(MSTU(21).GE.1) N=NS
13618         IF(MSTU(21).GE.1) RETURN
13619       ENDIF
13620       IF(MAX(Q2S(1),Q2S(2)).GE.(0.5*PARP(62))**2.OR.N.LE.NS+1) GOTO 120
13621
13622 C...Boost hard scattering partons to frame of shower initiators.
13623       DO 280 J=1,3
13624   280 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13625       DO 290 J=1,5
13626   290 P(N+2,J)=P(NS+1,J)
13627       ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
13628       IF(ROBOT.GE.0.999999) THEN
13629         ROBOT=1.00001*SQRT(ROBOT)
13630         ROBO(3)=ROBO(3)/ROBOT
13631         ROBO(4)=ROBO(4)/ROBOT
13632         ROBO(5)=ROBO(5)/ROBOT
13633       ENDIF
13634       CALL LUDBRB(N+2,N+2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),
13635      &-DBLE(ROBO(5)))
13636       ROBO(2)=ULANGL(P(N+2,1),P(N+2,2))
13637       ROBO(1)=ULANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
13638       CALL LUDBRB(MINT(83)+5,NS,ROBO(1),ROBO(2),DBLE(ROBO(3)),
13639      &DBLE(ROBO(4)),DBLE(ROBO(5)))
13640
13641 C...Store user information. Reset Lambda value.
13642       K(IPU1,3)=MINT(83)+3
13643       K(IPU2,3)=MINT(83)+4
13644       DO 300 JT=1,2
13645       MINT(12+JT)=KFLS(JT)
13646   300 VINT(140+JT)=XS(JT)
13647       PARU(111)=ALAMS
13648  1000 FORMAT(5X,'structure function has a zero point here')
13649  1001 FORMAT(5X,'xf(x,i=',I5,')=',F10.5)
13650
13651       RETURN
13652       END
13653
13654 C*********************************************************************
13655
13656       SUBROUTINE PYMULT(MMUL)
13657
13658 C...Initializes treatment of multiple interactions, selects kinematics
13659 C...of hardest interaction if low-pT physics included in run, and
13660 C...generates all non-hardest interactions.
13661       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
13662       SAVE /LUJETS/
13663       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13664       SAVE /LUDAT1/
13665       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
13666       SAVE /LUDAT2/
13667       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
13668       SAVE /PYSUBS/
13669       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13670       SAVE /PYPARS/
13671       COMMON/PYINT1/MINT(400),VINT(400)
13672       SAVE /PYINT1/
13673       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
13674       SAVE /PYINT2/
13675       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13676       SAVE /PYINT3/
13677       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
13678       SAVE /PYINT5/
13679       DIMENSION NMUL(20),SIGM(20),KSTR(500,2)
13680       SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
13681
13682 C...Initialization of multiple interaction treatment.
13683       IF(MMUL.EQ.1) THEN
13684         IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(82)
13685         ISUB=96
13686         MINT(1)=96
13687         VINT(63)=0.
13688         VINT(64)=0.
13689         VINT(143)=1.
13690         VINT(144)=1.
13691
13692 C...Loop over phase space points: xT2 choice in 20 bins.
13693   100   SIGSUM=0.
13694         DO 120 IXT2=1,20
13695         NMUL(IXT2)=MSTP(83)
13696         SIGM(IXT2)=0.
13697         DO 110 ITRY=1,MSTP(83)
13698         RSCA=0.05*((21-IXT2)-RLU(0))
13699         XT2=VINT(149)*(1.+VINT(149))/(VINT(149)+RSCA)-VINT(149)
13700         XT2=MAX(0.01*VINT(149),XT2)
13701         VINT(25)=XT2
13702
13703 C...Choose tau and y*. Calculate cos(theta-hat).
13704         IF(RLU(0).LE.COEF(ISUB,1)) THEN
13705           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
13706           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
13707         ELSE
13708           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
13709         ENDIF
13710         VINT(21)=TAU
13711         CALL PYKLIM(2)
13712         RYST=RLU(0)
13713         MYST=1
13714         IF(RYST.GT.COEF(ISUB,7)) MYST=2
13715         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
13716         CALL PYKMAP(2,MYST,RLU(0))
13717         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
13718
13719 C...Calculate differential cross-section.
13720         VINT(71)=0.5*VINT(1)*SQRT(XT2)
13721         CALL PYSIGH(NCHN,SIGS)
13722   110   SIGM(IXT2)=SIGM(IXT2)+SIGS
13723   120   SIGSUM=SIGSUM+SIGM(IXT2)
13724         SIGSUM=SIGSUM/(20.*MSTP(83))
13725
13726 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
13727         IF(SIGSUM.LT.1.1*VINT(106)) THEN
13728           IF(MSTP(122).GE.1) WRITE(MSTU(11),1100) PARP(82),SIGSUM
13729           PARP(82)=0.9*PARP(82)
13730           VINT(149)=4.*PARP(82)**2/VINT(2)
13731           GOTO 100
13732         ENDIF
13733         IF(MSTP(122).GE.1) WRITE(MSTU(11),1200) PARP(82), SIGSUM
13734
13735 C...Start iteration to find k factor.
13736         YKE=SIGSUM/VINT(106)
13737         SO=0.5
13738         XI=0.
13739         YI=0.
13740         XK=0.5
13741         IIT=0
13742   130   IF(IIT.EQ.0) THEN
13743           XK=2.*XK
13744         ELSEIF(IIT.EQ.1) THEN
13745           XK=0.5*XK
13746         ELSE
13747           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
13748         ENDIF
13749
13750 C...Evaluate overlap integrals.
13751         IF(MSTP(82).EQ.2) THEN
13752           SP=0.5*PARU(1)*(1.-EXP(-XK))
13753           SOP=SP/PARU(1)
13754         ELSE
13755           IF(MSTP(82).EQ.3) DELTAB=0.02
13756           IF(MSTP(82).EQ.4) DELTAB=MIN(0.01,0.05*PARP(84))
13757           SP=0.
13758           SOP=0.
13759           B=-0.5*DELTAB
13760   140     B=B+DELTAB
13761           IF(MSTP(82).EQ.3) THEN
13762             OV=EXP(-B**2)/PARU(2)
13763           ELSE
13764             CQ2=PARP(84)**2
13765             OV=((1.-PARP(83))**2*EXP(-MIN(100.,B**2))+2.*PARP(83)*
13766      &      (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B**2*2./(1.+CQ2)))+
13767      &      PARP(83)**2/CQ2*EXP(-MIN(100.,B**2/CQ2)))/PARU(2)
13768           ENDIF
13769           PACC=1.-EXP(-MIN(100.,PARU(1)*XK*OV))
13770           SP=SP+PARU(2)*B*DELTAB*PACC
13771           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
13772           IF(B.LT.1..OR.B*PACC.GT.1E-6) GOTO 140
13773         ENDIF
13774         YK=PARU(1)*XK*SO/SP
13775
13776 C...Continue iteration until convergence.
13777         IF(YK.LT.YKE) THEN
13778           XI=XK
13779           YI=YK
13780           IF(IIT.EQ.1) IIT=2
13781         ELSE
13782           XF=XK
13783           YF=YK
13784           IF(IIT.EQ.0) IIT=1
13785         ENDIF
13786         IF(ABS(YK-YKE).GE.1E-5*YKE) GOTO 130
13787
13788 C...Store some results for subsequent use.
13789         VINT(145)=SIGSUM
13790         VINT(146)=SOP/SO
13791         VINT(147)=SOP/SP
13792
13793 C...Initialize iteration in xT2 for hardest interaction.
13794       ELSEIF(MMUL.EQ.2) THEN
13795         IF(MSTP(82).LE.0) THEN
13796         ELSEIF(MSTP(82).EQ.1) THEN
13797           XT2=1.
13798           XT2FAC=XSEC(96,1)/VINT(106)*VINT(149)/(1.-VINT(149))
13799         ELSEIF(MSTP(82).EQ.2) THEN
13800           XT2=1.
13801           XT2FAC=VINT(146)*XSEC(96,1)/VINT(106)*VINT(149)*(1.+VINT(149))
13802         ELSE
13803           XC2=4.*CKIN(3)**2/VINT(2)
13804           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0.
13805         ENDIF
13806
13807       ELSEIF(MMUL.EQ.3) THEN
13808 C...Low-pT or multiple interactions (first semihard interaction):
13809 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
13810 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
13811         ISUB=MINT(1)
13812         IF(MSTP(82).LE.0) THEN
13813           XT2=0.
13814         ELSEIF(MSTP(82).EQ.1) THEN
13815           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
13816         ELSEIF(MSTP(82).EQ.2) THEN
13817           IF(XT2.LT.1..AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
13818      &    VINT(149)))).GT.RLU(0)) XT2=1.
13819           IF(XT2.GE.1.) THEN
13820             XT2=(1.+VINT(149))*XT2FAC/(XT2FAC-(1.+VINT(149))*LOG(1.-
13821      &      RLU(0)*(1.-EXP(-XT2FAC/(VINT(149)*(1.+VINT(149)))))))-
13822      &      VINT(149)
13823           ELSE
13824             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+RLU(0)*
13825      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
13826      &      VINT(149)
13827           ENDIF
13828           XT2=MAX(0.01*VINT(149),XT2)
13829         ELSE
13830           XT2=(XC2+VINT(149))*(1.+VINT(149))/(1.+VINT(149)-
13831      &    RLU(0)*(1.-XC2))-VINT(149)
13832           XT2=MAX(0.01*VINT(149),XT2)
13833         ENDIF
13834         VINT(25)=XT2
13835
13836 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
13837         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
13838           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
13839           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
13840           ISUB=95
13841           MINT(1)=ISUB
13842           VINT(21)=0.01*VINT(149)
13843           VINT(22)=0.
13844           VINT(23)=0.
13845           VINT(25)=0.01*VINT(149)
13846
13847         ELSE
13848 C...Multiple interactions (first semihard interaction).
13849 C...Choose tau and y*. Calculate cos(theta-hat).
13850           IF(RLU(0).LE.COEF(ISUB,1)) THEN
13851             TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
13852             TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
13853           ELSE
13854             TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
13855           ENDIF
13856           VINT(21)=TAU
13857           CALL PYKLIM(2)
13858           RYST=RLU(0)
13859           MYST=1
13860           IF(RYST.GT.COEF(ISUB,7)) MYST=2
13861           IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
13862           CALL PYKMAP(2,MYST,RLU(0))
13863           VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
13864         ENDIF
13865         VINT(71)=0.5*VINT(1)*SQRT(VINT(25))
13866
13867 C...Store results of cross-section calculation.
13868       ELSEIF(MMUL.EQ.4) THEN
13869         ISUB=MINT(1)
13870         XTS=VINT(25)
13871         IF(ISET(ISUB).EQ.1) XTS=VINT(21)
13872         IF(ISET(ISUB).EQ.2) XTS=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
13873      &  VINT(2)
13874         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XTS=VINT(26)
13875         RBIN=MAX(0.000001,MIN(0.999999,XTS*(1.+VINT(149))/
13876      &  (XTS+VINT(149))))
13877         IRBIN=INT(1.+20.*RBIN)
13878         IF(ISUB.EQ.96) NMUL(IRBIN)=NMUL(IRBIN)+1
13879         IF(ISUB.EQ.96) SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
13880
13881 C...Choose impact parameter.
13882       ELSEIF(MMUL.EQ.5) THEN
13883         IF(MSTP(82).EQ.3) THEN
13884           VINT(148)=RLU(0)/(PARU(2)*VINT(147))
13885         ELSE
13886           RTYPE=RLU(0)
13887           CQ2=PARP(84)**2
13888           IF(RTYPE.LT.(1.-PARP(83))**2) THEN
13889             B2=-LOG(RLU(0))
13890           ELSEIF(RTYPE.LT.1.-PARP(83)**2) THEN
13891             B2=-0.5*(1.+CQ2)*LOG(RLU(0))
13892           ELSE
13893             B2=-CQ2*LOG(RLU(0))
13894           ENDIF
13895           VINT(148)=((1.-PARP(83))**2*EXP(-MIN(100.,B2))+2.*PARP(83)*
13896      &    (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B2*2./(1.+CQ2)))+
13897      &    PARP(83)**2/CQ2*EXP(-MIN(100.,B2/CQ2)))/(PARU(2)*VINT(147))
13898         ENDIF
13899
13900 C...Multiple interactions (variable impact parameter) : reject with
13901 C...probability exp(-overlap*cross-section above pT/normalization).
13902         RNCOR=(IRBIN-20.*RBIN)*NMUL(IRBIN)
13903         SIGCOR=(IRBIN-20.*RBIN)*SIGM(IRBIN)
13904         DO 150 IBIN=IRBIN+1,20
13905         RNCOR=RNCOR+NMUL(IBIN)
13906   150   SIGCOR=SIGCOR+SIGM(IBIN)
13907         SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1.-XTS)/(XTS+VINT(149))
13908         VINT(150)=EXP(-MIN(100.,VINT(146)*VINT(148)*SIGABV/VINT(106)))
13909
13910 C...Generate additional multiple semihard interactions.
13911       ELSEIF(MMUL.EQ.6) THEN
13912
13913 C...Reconstruct strings in hard scattering.
13914         ISUB=MINT(1)
13915         NMAX=MINT(84)+4
13916         IF(ISET(ISUB).EQ.1) NMAX=MINT(84)+2
13917         NSTR=0
13918         DO 170 I=MINT(84)+1,NMAX
13919         KCS=KCHG(LUCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
13920         IF(KCS.EQ.0) GOTO 170
13921         DO 160 J=1,4
13922         IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 160
13923         IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 160
13924         IF(J.LE.2) THEN
13925           IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
13926         ELSE
13927           IST=MOD(K(I,J+1),MSTU(5))
13928         ENDIF
13929         IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 160
13930         IF(KCHG(LUCOMP(K(IST,2)),2).EQ.0) GOTO 160
13931         NSTR=NSTR+1
13932         IF(J.EQ.1.OR.J.EQ.4) THEN
13933           KSTR(NSTR,1)=I
13934           KSTR(NSTR,2)=IST
13935         ELSE
13936           KSTR(NSTR,1)=IST
13937           KSTR(NSTR,2)=I
13938         ENDIF
13939   160   CONTINUE
13940   170   CONTINUE
13941
13942 C...Set up starting values for iteration in xT2.
13943         XT2=VINT(25)
13944         IF(ISET(ISUB).EQ.1) XT2=VINT(21)
13945         IF(ISET(ISUB).EQ.2) XT2=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
13946      &  VINT(2)
13947         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XT2=VINT(26)
13948         ISUB=96
13949         MINT(1)=96
13950         IF(MSTP(82).LE.1) THEN
13951           XT2FAC=XSEC(ISUB,1)*VINT(149)/((1.-VINT(149))*VINT(106))
13952         ELSE
13953           XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/VINT(106)*
13954      &    VINT(149)*(1.+VINT(149))
13955         ENDIF
13956         VINT(63)=0.
13957         VINT(64)=0.
13958         VINT(151)=0.
13959         VINT(152)=0.
13960         VINT(143)=1.-VINT(141)
13961         VINT(144)=1.-VINT(142)
13962
13963 C...Iterate downwards in xT2.
13964   180   IF(MSTP(82).LE.1) THEN
13965           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
13966           IF(XT2.LT.VINT(149)) GOTO 220
13967         ELSE
13968           IF(XT2.LE.0.01*VINT(149)) GOTO 220
13969           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
13970      &    LOG(RLU(0)))-VINT(149)
13971           IF(XT2.LE.0.) GOTO 220
13972           XT2=MAX(0.01*VINT(149),XT2)
13973         ENDIF
13974         VINT(25)=XT2
13975
13976 C...Choose tau and y*. Calculate cos(theta-hat).
13977         IF(RLU(0).LE.COEF(ISUB,1)) THEN
13978           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
13979           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
13980         ELSE
13981           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
13982         ENDIF
13983         VINT(21)=TAU
13984         CALL PYKLIM(2)
13985         RYST=RLU(0)
13986         MYST=1
13987         IF(RYST.GT.COEF(ISUB,7)) MYST=2
13988         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
13989         CALL PYKMAP(2,MYST,RLU(0))
13990         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
13991
13992 C...Check that x not used up. Accept or reject kinematical variables.
13993         X1M=SQRT(TAU)*EXP(VINT(22))
13994         X2M=SQRT(TAU)*EXP(-VINT(22))
13995         IF(VINT(143)-X1M.LT.0.01.OR.VINT(144)-X2M.LT.0.01) GOTO 180
13996         VINT(71)=0.5*VINT(1)*SQRT(XT2)
13997         CALL PYSIGH(NCHN,SIGS)
13998         IF(SIGS.LT.XSEC(ISUB,1)*RLU(0)) GOTO 180
13999
14000 C...Reset K, P and V vectors. Select some variables.
14001         DO 190 I=N+1,N+2
14002         DO 190 J=1,5
14003         K(I,J)=0
14004         P(I,J)=0.
14005   190   V(I,J)=0.
14006         RFLAV=RLU(0)
14007         PT=0.5*VINT(1)*SQRT(XT2)
14008         PHI=PARU(2)*RLU(0)
14009         CTH=VINT(23)
14010
14011 C...Add first parton to event record.
14012         K(N+1,1)=3
14013         K(N+1,2)=21
14014         IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14015      &  1+INT((2.+PARJ(2))*RLU(0))
14016         P(N+1,1)=PT*COS(PHI)
14017         P(N+1,2)=PT*SIN(PHI)
14018         P(N+1,3)=0.25*VINT(1)*(VINT(41)*(1.+CTH)-VINT(42)*(1.-CTH))
14019         P(N+1,4)=0.25*VINT(1)*(VINT(41)*(1.+CTH)+VINT(42)*(1.-CTH))
14020         P(N+1,5)=0.
14021
14022 C...Add second parton to event record.
14023         K(N+2,1)=3
14024         K(N+2,2)=21
14025         IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14026         P(N+2,1)=-P(N+1,1)
14027         P(N+2,2)=-P(N+1,2)
14028         P(N+2,3)=0.25*VINT(1)*(VINT(41)*(1.-CTH)-VINT(42)*(1.+CTH))
14029         P(N+2,4)=0.25*VINT(1)*(VINT(41)*(1.-CTH)+VINT(42)*(1.+CTH))
14030         P(N+2,5)=0.
14031
14032         IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14033 C....Choose relevant string pieces to place gluons on.
14034           DO 210 I=N+1,N+2
14035           DMIN=1E8
14036           DO 200 ISTR=1,NSTR
14037           I1=KSTR(ISTR,1)
14038           I2=KSTR(ISTR,2)
14039           DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14040      &    P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14041      &    P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1.,P(I1,4)*P(I2,4)-
14042      &    P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14043           IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14044             DMIN=DIST
14045             IST1=I1
14046             IST2=I2
14047             ISTM=ISTR
14048           ENDIF
14049   200     CONTINUE
14050
14051 C....Colour flow adjustments, new string pieces.
14052           IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14053      &    MOD(K(IST1,4),MSTU(5))
14054           IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14055      &    MSTU(5)*(K(IST1,5)/MSTU(5))+I
14056           K(I,5)=MSTU(5)*IST1
14057           K(I,4)=MSTU(5)*IST2
14058           IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14059      &    MOD(K(IST2,5),MSTU(5))
14060           IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14061      &    MSTU(5)*(K(IST2,4)/MSTU(5))+I
14062           KSTR(ISTM,2)=I
14063           KSTR(NSTR+1,1)=I
14064           KSTR(NSTR+1,2)=IST2
14065   210     NSTR=NSTR+1
14066
14067 C...String drawing and colour flow for gluon loop.
14068         ELSEIF(K(N+1,2).EQ.21) THEN
14069           K(N+1,4)=MSTU(5)*(N+2)
14070           K(N+1,5)=MSTU(5)*(N+2)
14071           K(N+2,4)=MSTU(5)*(N+1)
14072           K(N+2,5)=MSTU(5)*(N+1)
14073           KSTR(NSTR+1,1)=N+1
14074           KSTR(NSTR+1,2)=N+2
14075           KSTR(NSTR+2,1)=N+2
14076           KSTR(NSTR+2,2)=N+1
14077           NSTR=NSTR+2
14078
14079 C...String drawing and colour flow for q-qbar pair.
14080         ELSE
14081           K(N+1,4)=MSTU(5)*(N+2)
14082           K(N+2,5)=MSTU(5)*(N+1)
14083           KSTR(NSTR+1,1)=N+1
14084           KSTR(NSTR+1,2)=N+2
14085           NSTR=NSTR+1
14086         ENDIF
14087
14088 C...Update remaining energy; iterate.
14089         N=N+2
14090         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14091           CALL LUERRM(11,'(PYMULT:) no more memory left in LUJETS')
14092           IF(MSTU(21).GE.1) RETURN
14093         ENDIF
14094         MINT(31)=MINT(31)+1
14095         VINT(151)=VINT(151)+VINT(41)
14096         VINT(152)=VINT(152)+VINT(42)
14097         VINT(143)=VINT(143)-VINT(41)
14098         VINT(144)=VINT(144)-VINT(42)
14099         IF(MINT(31).LT.240) GOTO 180
14100   220   CONTINUE
14101       ENDIF
14102
14103 C...Format statements for printout.
14104  1000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14105      &'actions for MSTP(82) =',I2,' ******')
14106  1100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14107      &E9.2,' mb: rejected')
14108  1200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14109      &E9.2,' mb: accepted')
14110
14111       RETURN
14112       END
14113
14114 C*********************************************************************
14115
14116       SUBROUTINE PYREMN(IPU1,IPU2)
14117
14118 C...Adds on target remnants (one or two from each side) and
14119 C...includes primordial kT.
14120       COMMON/HIPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
14121       SAVE  /HIPARNT/
14122       COMMON/HISTRNG/NFP(300,15),PPHI(300,15),NFT(300,15),PTHI(300,15)
14123       SAVE  /HISTRNG/
14124 C...COMMON BLOCK FROM HIJING
14125       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
14126       SAVE /LUJETS/
14127       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14128       SAVE /LUDAT1/
14129       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
14130       SAVE /LUDAT2/
14131       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14132       SAVE /PYPARS/
14133       COMMON/PYINT1/MINT(400),VINT(400)
14134       SAVE /PYINT1/
14135       DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)
14136
14137 C...Special case for lepton-lepton interaction.
14138       IF(MINT(43).EQ.1) THEN
14139         DO 100 JT=1,2
14140         I=MINT(83)+JT+2
14141         K(I,1)=21
14142         K(I,2)=K(I-2,2)
14143         K(I,3)=I-2
14144         DO 100 J=1,5
14145   100   P(I,J)=P(I-2,J)
14146       ENDIF
14147
14148 C...Find event type, set pointers.
14149       IF(IPU1.EQ.0.AND.IPU2.EQ.0) RETURN
14150       ISUB=MINT(1)
14151       ILEP=0
14152       IF(IPU1.EQ.0) ILEP=1
14153       IF(IPU2.EQ.0) ILEP=2
14154       IF(ISUB.EQ.95) ILEP=-1
14155       IF(ILEP.EQ.1) IQ=MINT(84)+1
14156       IF(ILEP.EQ.2) IQ=MINT(84)+2
14157       IP=MAX(IPU1,IPU2)
14158       ILEPR=MINT(83)+5-ILEP
14159       NS=N
14160
14161 C...Define initial partons, including primordial kT.
14162   110 DO 130 JT=1,2
14163       I=MINT(83)+JT+2
14164       IF(JT.EQ.1) IPU=IPU1
14165       IF(JT.EQ.2) IPU=IPU2
14166       K(I,1)=21
14167       K(I,3)=I-2
14168       IF(ISUB.EQ.95) THEN
14169         K(I,2)=21
14170         SHS=0.
14171       ELSEIF(MINT(40+JT).EQ.1.AND.IPU.NE.0) THEN
14172         K(I,2)=K(IPU,2)
14173         P(I,5)=P(IPU,5)
14174         P(I,1)=0.
14175         P(I,2)=0.
14176         PMS(JT)=P(I,5)**2
14177       ELSEIF(IPU.NE.0) THEN
14178         K(I,2)=K(IPU,2)
14179         P(I,5)=P(IPU,5)
14180 C...No primordial kT or chosen according to truncated Gaussian or
14181 C...exponential.
14182 C
14183 c     X.N. Wang (7.22.97)
14184 c
14185         RPT1=0.0
14186         RPT2=0.0
14187         SS_W2=(PPHI(IHNT2(11),4)+PTHI(IHNT2(12),4))**2
14188      &       -(PPHI(IHNT2(11),1)+PTHI(IHNT2(12),1))**2
14189      &       -(PPHI(IHNT2(11),2)+PTHI(IHNT2(12),2))**2
14190      &       -(PPHI(IHNT2(11),3)+PTHI(IHNT2(12),3))**2
14191 C
14192 C********this is s of the current NN collision
14193         IF(SS_W2.LE.4.0*PARP(93)**2) GOTO 1211
14194 c
14195         IF(IHPR2(5).LE.0) THEN
14196 120          IF(MSTP(91).LE.0) THEN
14197                PT=0.
14198              ELSEIF(MSTP(91).EQ.1) THEN
14199                PT=PARP(91)*SQRT(-LOG(RLU(0)))
14200              ELSE
14201                RPT1=RLU(0)
14202                RPT2=RLU(0)
14203                PT=-PARP(92)*LOG(RPT1*RPT2)
14204              ENDIF
14205              IF(PT.GT.PARP(93)) GOTO 120
14206              PHI=PARU(2)*RLU(0)
14207              RPT1=PT*COS(PHI)
14208              RPT2=PT*SIN(PHI)
14209         ELSE IF(IHPR2(5).EQ.1) THEN
14210              IF(JT.EQ.1) JPT=NFP(IHNT2(11),11)
14211              IF(JT.EQ.2) JPT=NFT(IHNT2(12),11)
14212 1205         PTGS=PARP(91)*SQRT(-LOG(RLU(0)))
14213              IF(PTGS.GT.PARP(93)) GO TO 1205
14214              PHI=2.0*HIPR1(40)*RLU(0)
14215              RPT1=PTGS*COS(PHI)
14216              RPT2=PTGS*SIN(PHI)
14217              DO 1210 I_INT=1,JPT-1
14218                 PKCSQ=PARP(91)*SQRT(-LOG(RLU(0)))
14219                 PHI=2.0*HIPR1(40)*RLU(0)
14220                 RPT1=RPT1+PKCSQ*COS(PHI)
14221                 RPT2=RPT2+PKCSQ*SIN(PHI)
14222 1210         CONTINUE
14223              IF(RPT1**2+RPT2**2.GE.SS_W2/4.0) GO TO 1205
14224         ENDIF
14225 C     X.N. Wang
14226 C                       ********When initial interaction among soft partons is
14227 C                               assumed the primordial pt comes from the sum of
14228 C                               pt of JPT-1 number of initial interaction, JPT
14229 C                               is the number of interaction including present
14230 C                               one that nucleon hassuffered
14231 1211    P(I,1)=RPT1
14232         P(I,2)=RPT2
14233         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14234       ELSE
14235         K(I,2)=K(IQ,2)
14236         Q2=VINT(52)
14237         P(I,5)=-SQRT(Q2)
14238         PMS(JT)=-Q2
14239         SHS=(1.-VINT(43-JT))*Q2/VINT(43-JT)+VINT(5-JT)**2
14240       ENDIF
14241   130 CONTINUE
14242
14243 C...Kinematics construction for initial partons.
14244       I1=MINT(83)+3
14245       I2=MINT(83)+4
14246       IF(ILEP.EQ.0) SHS=VINT(141)*VINT(142)*VINT(2)+
14247      &(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2
14248       SHR=SQRT(MAX(0.,SHS))
14249       IF(ILEP.EQ.0) THEN
14250         IF((SHS-PMS(1)-PMS(2))**2-4.*PMS(1)*PMS(2).LE.0.) GOTO 110
14251         P(I1,4)=0.5*(SHR+(PMS(1)-PMS(2))/SHR)
14252         P(I1,3)=SQRT(MAX(0.,P(I1,4)**2-PMS(1)))
14253         P(I2,4)=SHR-P(I1,4)
14254         P(I2,3)=-P(I1,3)
14255       ELSEIF(ILEP.EQ.1) THEN
14256         P(I1,4)=P(IQ,4)
14257         P(I1,3)=P(IQ,3)
14258         P(I2,4)=P(IP,4)
14259         P(I2,3)=P(IP,3)
14260       ELSEIF(ILEP.EQ.2) THEN
14261         P(I1,4)=P(IP,4)
14262         P(I1,3)=P(IP,3)
14263         P(I2,4)=P(IQ,4)
14264         P(I2,3)=P(IQ,3)
14265       ENDIF
14266       IF(MINT(43).EQ.1) RETURN
14267
14268 C...Transform partons to overall CM-frame (not for leptoproduction).
14269       IF(ILEP.EQ.0) THEN
14270         ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14271         ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14272         CALL LUDBRB(I1,I2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),0D0)
14273         ROBO(2)=ULANGL(P(I1,1),P(I1,2))
14274         CALL LUDBRB(I1,I2,0.,-ROBO(2),0D0,0D0,0D0)
14275         ROBO(1)=ULANGL(P(I1,3),P(I1,1))
14276         CALL LUDBRB(I1,I2,-ROBO(1),0.,0D0,0D0,0D0)
14277         NMAX=MAX(MINT(52),IPU1,IPU2)
14278         CALL LUDBRB(I1,NMAX,ROBO(1),ROBO(2),DBLE(ROBO(3)),DBLE(ROBO(4)),
14279      &  0D0)
14280         ROBO(5)=MAX(-0.999999,MIN(0.999999,(VINT(141)-VINT(142))/
14281      &  (VINT(141)+VINT(142))))
14282         CALL LUDBRB(I1,NMAX,0.,0.,0D0,0D0,DBLE(ROBO(5)))
14283       ENDIF
14284
14285 C...Check invariant mass of remnant system:
14286 C...hadronic events or leptoproduction.
14287       IF(ILEP.LE.0) THEN
14288         IF(MSTP(81).LE.0.OR.MSTP(82).LE.0.OR.ISUB.EQ.95) THEN
14289           VINT(151)=0.
14290           VINT(152)=0.
14291         ENDIF
14292         PEH=P(I1,4)+P(I2,4)+0.5*VINT(1)*(VINT(151)+VINT(152))
14293         PZH=P(I1,3)+P(I2,3)+0.5*VINT(1)*(VINT(151)-VINT(152))
14294         SHH=(VINT(1)-PEH)**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+P(I2,2))**2-
14295      &  PZH**2
14296         PMMIN=P(MINT(83)+1,5)+P(MINT(83)+2,5)+ULMASS(K(I1,2))+
14297      &  ULMASS(K(I2,2))
14298         IF(SHR.GE.VINT(1).OR.SHH.LE.(PMMIN+PARP(111))**2) THEN
14299           MINT(51)=1
14300           RETURN
14301         ENDIF
14302         SHR=SQRT(SHH+(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2)
14303       ELSE
14304         PEI=P(IQ,4)+P(IP,4)
14305         PZI=P(IQ,3)+P(IP,3)
14306         PMS(ILEP)=MAX(0.,PEI**2-PZI**2)
14307         PMMIN=P(ILEPR-2,5)+ULMASS(K(ILEPR,2))+SQRT(PMS(ILEP))
14308         IF(SHR.LE.PMMIN+PARP(111)) THEN
14309           MINT(51)=1
14310           RETURN
14311         ENDIF
14312       ENDIF
14313
14314 C...Subdivide remnant if necessary, store first parton.
14315   140 I=NS
14316       DO 190 JT=1,2
14317       IF(JT.EQ.ILEP) GOTO 190
14318       IF(JT.EQ.1) IPU=IPU1
14319       IF(JT.EQ.2) IPU=IPU2
14320       CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14321       I=I+1
14322       IS(JT)=I
14323       DO 150 J=1,5
14324       K(I,J)=0
14325       P(I,J)=0.
14326   150 V(I,J)=0.
14327       K(I,1)=3
14328       K(I,2)=KFLSP(JT)
14329       K(I,3)=MINT(83)+JT
14330       P(I,5)=ULMASS(K(I,2))
14331
14332 C...First parton colour connections and transverse mass.
14333       KFLS=(3-KCHG(LUCOMP(KFLSP(JT)),2)*ISIGN(1,KFLSP(JT)))/2
14334       K(I,KFLS+3)=IPU
14335       K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14336       IF(KFLCH(JT).EQ.0) THEN
14337         P(I,1)=-P(MINT(83)+JT+2,1)
14338         P(I,2)=-P(MINT(83)+JT+2,2)
14339         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14340
14341 C...When extra remnant parton or hadron: find relative pT, store.
14342       ELSE
14343         CALL LUPTDI(1,P(I,1),P(I,2))
14344         PMS(JT+2)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14345         I=I+1
14346         DO 160 J=1,5
14347         K(I,J)=0
14348         P(I,J)=0.
14349   160   V(I,J)=0.
14350         K(I,1)=1
14351         K(I,2)=KFLCH(JT)
14352         K(I,3)=MINT(83)+JT
14353         P(I,5)=ULMASS(K(I,2))
14354         P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14355         P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14356         PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14357 C...Relative distribution of energy for particle into two jets.
14358         IMB=1
14359         IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14360         IF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14361           CHIK=PARP(92+2*IMB)
14362           IF(MSTP(92).LE.1) THEN
14363             IF(IMB.EQ.1) CHI(JT)=RLU(0)
14364             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
14365           ELSEIF(MSTP(92).EQ.2) THEN
14366             CHI(JT)=1.-RLU(0)**(1./(1.+CHIK))
14367           ELSEIF(MSTP(92).EQ.3) THEN
14368             CUT=2.*0.3/VINT(1)
14369   170       CHI(JT)=RLU(0)**2
14370             IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25*(1.-CHI(JT))**CHIK
14371      &      .LT.RLU(0)) GOTO 170
14372           ELSE
14373             CUT=2.*0.3/VINT(1)
14374             CUTR=(1.+SQRT(1.+CUT**2))/CUT
14375   180       CHIR=CUT*CUTR**RLU(0)
14376             CHI(JT)=(CHIR**2-CUT**2)/(2.*CHIR)
14377             IF((1.-CHI(JT))**CHIK.LT.RLU(0)) GOTO 180
14378           ENDIF
14379 C...Relative distribution of energy for particle into jet plus particle.
14380         ELSE
14381           IF(MSTP(92).LE.1) THEN
14382             IF(IMB.EQ.1) CHI(JT)=RLU(0)
14383             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
14384           ELSE
14385             CHI(JT)=1.-RLU(0)**(1./(1.+PARP(93+2*IMB)))
14386           ENDIF
14387           IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1.-CHI(JT)
14388         ENDIF
14389         PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1.-CHI(JT))
14390         KFLS=KCHG(LUCOMP(KFLCH(JT)),2)*ISIGN(1,KFLCH(JT))
14391         IF(KFLS.NE.0) THEN
14392           K(I,1)=3
14393           KFLS=(3-KFLS)/2
14394           K(I,KFLS+3)=IPU
14395           K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14396         ENDIF
14397       ENDIF
14398   190 CONTINUE
14399       IF(SHR.LE.SQRT(PMS(1))+SQRT(PMS(2))) GOTO 140
14400       N=I
14401
14402 C...Reconstruct kinematics of remnants.
14403       DO 200 JT=1,2
14404       IF(JT.EQ.ILEP) GOTO 200
14405       PE=0.5*(SHR+(PMS(JT)-PMS(3-JT))/SHR)
14406       PZ=SQRT(PE**2-PMS(JT))
14407       IF(KFLCH(JT).EQ.0) THEN
14408         P(IS(JT),4)=PE
14409         P(IS(JT),3)=PZ*(-1)**(JT-1)
14410       ELSE
14411         PW1=CHI(JT)*(PE+PZ)
14412         P(IS(JT)+1,4)=0.5*(PW1+PMS(JT+4)/PW1)
14413         P(IS(JT)+1,3)=0.5*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
14414         P(IS(JT),4)=PE-P(IS(JT)+1,4)
14415         P(IS(JT),3)=PZ*(-1)**(JT-1)-P(IS(JT)+1,3)
14416       ENDIF
14417   200 CONTINUE
14418
14419 C...Hadronic events: boost remnants to correct longitudinal frame.
14420       IF(ILEP.LE.0) THEN
14421         CALL LUDBRB(NS+1,N,0.,0.,0D0,0D0,-DBLE(PZH/(VINT(1)-PEH)))
14422 C...Leptoproduction events: boost colliding subsystem.
14423       ELSE
14424         NMAX=MAX(IP,MINT(52))
14425         PEF=SHR-PE
14426         PZF=PZ*(-1)**(ILEP-1)
14427         PT2=P(ILEPR,1)**2+P(ILEPR,2)**2
14428         PHIPT=ULANGL(P(ILEPR,1),P(ILEPR,2))
14429         CALL LUDBRB(MINT(84)+1,NMAX,0.,-PHIPT,0D0,0D0,0D0)
14430         RQP=P(IQ,3)*(PT2+PEI**2)-P(IQ,4)*PEI*PZI
14431         SINTH=P(IQ,4)*SQRT(PT2*(PT2+PEI**2)/(RQP**2+PT2*
14432      &  P(IQ,4)**2*PZI**2))*SIGN(1.,-RQP)
14433         CALL LUDBRB(MINT(84)+1,NMAX,ASIN(SINTH),0.,0D0,0D0,0D0)
14434         BETAX=(-PEI*PZI*SINTH+SQRT(PT2*(PT2+PEI**2-(PZI*SINTH)**2)))/
14435      &  (PT2+PEI**2)
14436         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,DBLE(BETAX),0D0,0D0)
14437         CALL LUDBRB(MINT(84)+1,NMAX,0.,PHIPT,0D0,0D0,0D0)
14438         PEM=P(IQ,4)+P(IP,4)
14439         PZM=P(IQ,3)+P(IP,3)
14440         BETAZ=(-PEM*PZM+PZF*SQRT(PZF**2+PEM**2-PZM**2))/(PZF**2+PEM**2)
14441         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,0D0,0D0,DBLE(BETAZ))
14442         CALL LUDBRB(I1,I2,ASIN(SINTH),0.,DBLE(BETAX),0D0,0D0)
14443         CALL LUDBRB(I1,I2,0.,PHIPT,0D0,0D0,DBLE(BETAZ))
14444       ENDIF
14445
14446       RETURN
14447       END
14448
14449 C*********************************************************************
14450
14451       SUBROUTINE PYRESD
14452
14453 C...Allows resonances to decay (including parton showers for hadronic
14454 C...channels).
14455       IMPLICIT DOUBLE PRECISION(D)
14456       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
14457       SAVE /LUJETS/
14458       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14459       SAVE /LUDAT1/
14460       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
14461       SAVE /LUDAT2/
14462       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
14463       SAVE /LUDAT3/
14464       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
14465       SAVE /PYSUBS/
14466       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14467       SAVE /PYPARS/
14468       COMMON/PYINT1/MINT(400),VINT(400)
14469       SAVE /PYINT1/
14470       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
14471       SAVE /PYINT2/
14472       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
14473       SAVE /PYINT4/
14474       DIMENSION IREF(10,6),KDCY(2),KFL1(2),KFL2(2),NSD(2),ILIN(6),
14475      &COUP(6,4),PK(6,4),PKK(6,6),CTHE(2),PHI(2),WDTP(0:40),
14476      &WDTE(0:40,0:5)
14477       COMPLEX FGK,HA(6,6),HC(6,6)
14478
14479 C...The F, Xi and Xj functions of Gunion and Kunszt
14480 C...(Phys. Rev. D33, 665, plus errata from the authors).
14481       FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
14482      &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
14483       DIGK(DT,DU)=-4.*D34*D56+DT*(3.*DT+4.*DU)+DT**2*(DT*DU/(D34*D56)-
14484      &2.*(1./D34+1./D56)*(DT+DU)+2.*(D34/D56+D56/D34))
14485       DJGK(DT,DU)=8.*(D34+D56)**2-8.*(D34+D56)*(DT+DU)-6.*DT*DU-
14486      &2.*DT*DU*(DT*DU/(D34*D56)-2.*(1./D34+1./D56)*(DT+DU)+
14487      &2.*(D34/D56+D56/D34))
14488
14489 C...Define initial two objects, initialize loop.
14490       ISUB=MINT(1)
14491       SH=VINT(44)
14492       IREF(1,5)=0
14493       IREF(1,6)=0
14494       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
14495         IREF(1,1)=MINT(84)+2+ISET(ISUB)
14496         IREF(1,2)=0
14497         IREF(1,3)=MINT(83)+6+ISET(ISUB)
14498         IREF(1,4)=0
14499       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
14500         IREF(1,1)=MINT(84)+1+ISET(ISUB)
14501         IREF(1,2)=MINT(84)+2+ISET(ISUB)
14502         IREF(1,3)=MINT(83)+5+ISET(ISUB)
14503         IREF(1,4)=MINT(83)+6+ISET(ISUB)
14504       ENDIF
14505       NP=1
14506       IP=0
14507   100 IP=IP+1
14508       NINH=0
14509
14510 C...Loop over one/two resonances; reset decay rates.
14511       JTMAX=2
14512       IF(IP.EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3)) JTMAX=1
14513       DO 140 JT=1,JTMAX
14514       KDCY(JT)=0
14515       KFL1(JT)=0
14516       KFL2(JT)=0
14517       NSD(JT)=IREF(IP,JT)
14518       ID=IREF(IP,JT)
14519       IF(ID.EQ.0) GOTO 140
14520       KFA=IABS(K(ID,2))
14521       IF(KFA.LT.23.OR.KFA.GT.40) GOTO 140
14522       IF(MDCY(KFA,1).NE.0) THEN
14523         IF(ISUB.EQ.1.OR.ISUB.EQ.141) MINT(61)=1
14524         CALL PYWIDT(KFA,P(ID,5),WDTP,WDTE)
14525         IF(KCHG(KFA,3).EQ.0) THEN
14526           IPM=2
14527         ELSE
14528           IPM=(5+ISIGN(1,K(ID,2)))/2
14529         ENDIF
14530         IF(JTMAX.EQ.1.OR.IABS(K(IREF(IP,1),2)).NE.IABS(K(IREF(IP,2),2)))
14531      &  THEN
14532           I12=4
14533         ELSE
14534           IF(JT.EQ.1) I12=INT(4.5+RLU(0))
14535           I12=9-I12
14536         ENDIF
14537         RKFL=(WDTE(0,1)+WDTE(0,IPM)+WDTE(0,I12))*RLU(0)
14538         DO 120 I=1,MDCY(KFA,3)
14539         IDC=I+MDCY(KFA,2)-1
14540         KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
14541         KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
14542         RKFL=RKFL-(WDTE(I,1)+WDTE(I,IPM)+WDTE(I,I12))
14543         IF(RKFL.LE.0.) GOTO 130
14544   120   CONTINUE
14545   130   CONTINUE
14546       ENDIF
14547
14548 C...Summarize result on decay channel chosen.
14549       IF((KFA.EQ.23.OR.KFA.EQ.24).AND.KFL1(JT).EQ.0) NINH=NINH+1
14550       IF(KFL1(JT).EQ.0) GOTO 140
14551       KDCY(JT)=2
14552       IF(IABS(KFL1(JT)).LE.10.OR.KFL1(JT).EQ.21) KDCY(JT)=1
14553       IF((IABS(KFL1(JT)).GE.23.AND.IABS(KFL1(JT)).LE.25).OR.
14554      &(IABS(KFL1(JT)).EQ.37)) KDCY(JT)=3
14555       NSD(JT)=N
14556
14557 C...Fill decay products, prepared for parton showers for quarks.
14558       IF(KDCY(JT).EQ.1) THEN
14559         CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),P(ID,5))
14560       ELSE
14561         CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
14562       ENDIF
14563       IF(JTMAX.EQ.1) THEN
14564         CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*RLU(0)
14565         IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
14566         PHI(JT)=VINT(24)
14567       ELSE
14568         CTHE(JT)=2.*RLU(0)-1.
14569         PHI(JT)=PARU(2)*RLU(0)
14570       ENDIF
14571   140 CONTINUE
14572       IF(MINT(3).EQ.1.AND.IP.EQ.1) THEN
14573         MINT(25)=KFL1(1)
14574         MINT(26)=KFL2(1)
14575       ENDIF
14576       IF(JTMAX.EQ.1.AND.KDCY(1).EQ.0) GOTO 530
14577       IF(JTMAX.EQ.2.AND.KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 530
14578       IF(MSTP(45).LE.0.OR.IREF(IP,2).EQ.0.OR.NINH.GE.1) GOTO 500
14579       IF(K(IREF(1,1),2).EQ.25.AND.IP.EQ.1) GOTO 500
14580       IF(K(IREF(1,1),2).EQ.25.AND.KDCY(1)*KDCY(2).EQ.0) GOTO 500
14581
14582 C...Order incoming partons and outgoing resonances.
14583       ILIN(1)=MINT(84)+1
14584       IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
14585       IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
14586       ILIN(2)=2*MINT(84)+3-ILIN(1)
14587       IMIN=1
14588       IF(IREF(IP,5).EQ.25) IMIN=3
14589       IMAX=2
14590       IORD=1
14591       IF(K(IREF(IP,1),2).EQ.23) IORD=2
14592       IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
14593       IF(IABS(K(IREF(IP,IORD),2)).EQ.25) IORD=3-IORD
14594       IF(KDCY(IORD).EQ.0) IORD=3-IORD
14595
14596 C...Order decay products of resonances.
14597       DO 390 JT=IORD,3-IORD,3-2*IORD
14598       IF(KDCY(JT).EQ.0) THEN
14599         ILIN(IMAX+1)=NSD(JT)
14600         IMAX=IMAX+1
14601       ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
14602         ILIN(IMAX+1)=N+2*JT-1
14603         ILIN(IMAX+2)=N+2*JT
14604         IMAX=IMAX+2
14605         K(N+2*JT-1,2)=K(NSD(JT)+1,2)
14606         K(N+2*JT,2)=K(NSD(JT)+2,2)
14607       ELSE
14608         ILIN(IMAX+1)=N+2*JT
14609         ILIN(IMAX+2)=N+2*JT-1
14610         IMAX=IMAX+2
14611         K(N+2*JT-1,2)=K(NSD(JT)+1,2)
14612         K(N+2*JT,2)=K(NSD(JT)+2,2)
14613       ENDIF
14614   390 CONTINUE
14615
14616 C...Find charge, isospin, left- and righthanded couplings.
14617       XW=PARU(102)
14618       DO 410 I=IMIN,IMAX
14619       DO 400 J=1,4
14620   400 COUP(I,J)=0.
14621       KFA=IABS(K(ILIN(I),2))
14622       IF(KFA.GT.20) GOTO 410
14623       COUP(I,1)=LUCHGE(KFA)/3.
14624       COUP(I,2)=(-1)**MOD(KFA,2)
14625       COUP(I,4)=-2.*COUP(I,1)*XW
14626       COUP(I,3)=COUP(I,2)+COUP(I,4)
14627   410 CONTINUE
14628       SQMZ=PMAS(23,1)**2
14629       GZMZ=PMAS(23,1)*PMAS(23,2)
14630       SQMW=PMAS(24,1)**2
14631       GZMW=PMAS(24,1)*PMAS(24,2)
14632       SQMZP=PMAS(32,1)**2
14633       GZMZP=PMAS(32,1)*PMAS(32,2)
14634
14635 C...Select random angles; construct massless four-vectors.
14636   420 DO 430 I=N+1,N+4
14637       K(I,1)=1
14638       DO 430 J=1,5
14639   430 P(I,J)=0.
14640       DO 440 JT=1,JTMAX
14641       IF(KDCY(JT).EQ.0) GOTO 440
14642       ID=IREF(IP,JT)
14643       P(N+2*JT-1,3)=0.5*P(ID,5)
14644       P(N+2*JT-1,4)=0.5*P(ID,5)
14645       P(N+2*JT,3)=-0.5*P(ID,5)
14646       P(N+2*JT,4)=0.5*P(ID,5)
14647       CTHE(JT)=2.*RLU(0)-1.
14648       PHI(JT)=PARU(2)*RLU(0)
14649       CALL LUDBRB(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
14650      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
14651   440 CONTINUE
14652
14653 C...Store incoming and outgoing momenta, with random rotation to
14654 C...avoid accidental zeroes in HA expressions.
14655       DO 450 I=1,IMAX
14656       K(N+4+I,1)=1
14657       P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+
14658      &P(ILIN(I),5)**2)
14659       P(N+4+I,5)=P(ILIN(I),5)
14660       DO 450 J=1,3
14661   450 P(N+4+I,J)=P(ILIN(I),J)
14662       THERR=ACOS(2.*RLU(0)-1.)
14663       PHIRR=PARU(2)*RLU(0)
14664       CALL LUDBRB(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
14665       DO 460 I=1,IMAX
14666       DO 460 J=1,4
14667   460 PK(I,J)=P(N+4+I,J)
14668
14669 C...Calculate internal products.
14670       IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25) THEN
14671         DO 470 I1=IMIN,IMAX-1
14672         DO 470 I2=I1+1,IMAX
14673         HA(I1,I2)=SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+PK(I2,3))/
14674      &  (1E-20+PK(I1,1)**2+PK(I1,2)**2))*CMPLX(PK(I1,1),PK(I1,2))-
14675      &  SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
14676      &  (1E-20+PK(I2,1)**2+PK(I2,2)**2))*CMPLX(PK(I2,1),PK(I2,2))
14677         HC(I1,I2)=CONJG(HA(I1,I2))
14678         IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
14679         IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
14680         HA(I2,I1)=-HA(I1,I2)
14681   470   HC(I2,I1)=-HC(I1,I2)
14682       ENDIF
14683       DO 480 I=1,2
14684       DO 480 J=1,4
14685   480 PK(I,J)=-PK(I,J)
14686       DO 490 I1=IMIN,IMAX-1
14687       DO 490 I2=I1+1,IMAX
14688       PKK(I1,I2)=2.*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
14689      &PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
14690   490 PKK(I2,I1)=PKK(I1,I2)
14691
14692       IF(IREF(IP,5).EQ.25) THEN
14693 C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons
14694         WT=16.*PKK(3,5)*PKK(4,6)
14695         IF(IP.EQ.1) WTMAX=SH**2
14696         IF(IP.GE.2) WTMAX=P(IREF(IP,6),5)**4
14697
14698       ELSEIF(ISUB.EQ.1) THEN
14699         IF(KFA.NE.37) THEN
14700 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons
14701           EI=KCHG(IABS(MINT(15)),1)/3.
14702           AI=SIGN(1.,EI+0.1)
14703           VI=AI-4.*EI*XW
14704           EF=KCHG(KFA,1)/3.
14705           AF=SIGN(1.,EF+0.1)
14706           VF=AF-4.*EF*XW
14707           GG=1.
14708           GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
14709           ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
14710           IF(MSTP(43).EQ.1) THEN
14711 C...Only gamma* production included
14712             GZ=0.
14713             ZZ=0.
14714           ELSEIF(MSTP(43).EQ.2) THEN
14715 C...Only Z0 production included
14716             GG=0.
14717             GZ=0.
14718           ENDIF
14719           ASYM=2.*(EI*AI*GZ*EF*AF+4.*VI*AI*ZZ*VF*AF)/(EI**2*GG*EF**2+
14720      &    EI*VI*GZ*EF*VF+(VI**2+AI**2)*ZZ*(VF**2+AF**2))
14721           WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
14722           WTMAX=2.+ABS(ASYM)
14723         ELSE
14724 C...Angular weight for gamma*/Z0 -> H+ + H-
14725           WT=1.-CTHE(JT)**2
14726           WTMAX=1.
14727         ENDIF
14728
14729       ELSEIF(ISUB.EQ.2) THEN
14730 C...Angular weight for W+/- -> 2 quarks/leptons
14731         WT=(1.+CTHE(JT))**2
14732         WTMAX=4.
14733
14734       ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
14735 C...Angular weight for f + fb -> gluon/gamma + Z0 ->
14736 C...-> gluon/gamma + 2 quarks/leptons
14737         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
14738      &  (PKK(1,3)**2+PKK(2,4)**2)+((COUP(1,3)*COUP(3,4))**2+
14739      &  (COUP(1,4)*COUP(3,3))**2)*(PKK(1,4)**2+PKK(2,3)**2)
14740         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
14741      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
14742
14743       ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
14744 C...Angular weight for f + fb' -> gluon/gamma + W+/- ->
14745 C...-> gluon/gamma + 2 quarks/leptons
14746         WT=PKK(1,3)**2+PKK(2,4)**2
14747         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
14748
14749       ELSEIF(ISUB.EQ.22) THEN
14750 C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons
14751         S34=P(IREF(IP,IORD),5)**2
14752         S56=P(IREF(IP,3-IORD),5)**2
14753         TI=PKK(1,3)+PKK(1,4)+S34
14754         UI=PKK(1,5)+PKK(1,6)+S56
14755         WT=COUP(1,3)**4*((COUP(3,3)*COUP(5,3)*ABS(FGK(1,2,3,4,5,6)/
14756      &  TI+FGK(1,2,5,6,3,4)/UI))**2+(COUP(3,4)*COUP(5,3)*ABS(
14757      &  FGK(1,2,4,3,5,6)/TI+FGK(1,2,5,6,4,3)/UI))**2+(COUP(3,3)*
14758      &  COUP(5,4)*ABS(FGK(1,2,3,4,6,5)/TI+FGK(1,2,6,5,3,4)/UI))**2+
14759      &  (COUP(3,4)*COUP(5,4)*ABS(FGK(1,2,4,3,6,5)/TI+FGK(1,2,6,5,4,3)/
14760      &  UI))**2)+COUP(1,4)**4*((COUP(3,3)*COUP(5,3)*ABS(
14761      &  FGK(2,1,5,6,3,4)/TI+FGK(2,1,3,4,5,6)/UI))**2+(COUP(3,4)*
14762      &  COUP(5,3)*ABS(FGK(2,1,6,5,3,4)/TI+FGK(2,1,3,4,6,5)/UI))**2+
14763      &  (COUP(3,3)*COUP(5,4)*ABS(FGK(2,1,5,6,4,3)/TI+FGK(2,1,4,3,5,6)/
14764      &  UI))**2+(COUP(3,4)*COUP(5,4)*ABS(FGK(2,1,6,5,4,3)/TI+
14765      &  FGK(2,1,4,3,6,5)/UI))**2)
14766         WTMAX=4.*S34*S56*(COUP(1,3)**4+COUP(1,4)**4)*(COUP(3,3)**2+
14767      &  COUP(3,4)**2)*(COUP(5,3)**2+COUP(5,4)**2)*4.*(TI/UI+UI/TI+
14768      &  2.*SH*(S34+S56)/(TI*UI)-S34*S56*(1./TI**2+1./UI**2))
14769
14770       ELSEIF(ISUB.EQ.23) THEN
14771 C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons
14772         D34=P(IREF(IP,IORD),5)**2
14773         D56=P(IREF(IP,3-IORD),5)**2
14774         DT=PKK(1,3)+PKK(1,4)+D34
14775         DU=PKK(1,5)+PKK(1,6)+D56
14776         CAWZ=COUP(2,3)/SNGL(DT)-2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
14777         CBWZ=COUP(1,3)/SNGL(DU)+2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
14778         WT=COUP(5,3)**2*ABS(CAWZ*FGK(1,2,3,4,5,6)+CBWZ*
14779      &  FGK(1,2,5,6,3,4))**2+COUP(5,4)**2*ABS(CAWZ*
14780      &  FGK(1,2,3,4,6,5)+CBWZ*FGK(1,2,6,5,3,4))**2
14781         WTMAX=4.*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
14782      &  DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
14783
14784       ELSEIF(ISUB.EQ.24) THEN
14785 C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0
14786         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
14787      &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
14788      &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
14789         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
14790      &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
14791
14792       ELSEIF(ISUB.EQ.25) THEN
14793 C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons
14794         D34=P(IREF(IP,IORD),5)**2
14795         D56=P(IREF(IP,3-IORD),5)**2
14796         DT=PKK(1,3)+PKK(1,4)+D34
14797         DU=PKK(1,5)+PKK(1,6)+D56
14798         CDWW=(COUP(1,3)*SQMZ/(SH-SQMZ)+COUP(1,2))/SH
14799         CAWW=CDWW+0.5*(COUP(1,2)+1.)/SNGL(DT)
14800         CBWW=CDWW+0.5*(COUP(1,2)-1.)/SNGL(DU)
14801         CCWW=COUP(1,4)*SQMZ/(SH-SQMZ)/SH
14802         WT=ABS(CAWW*FGK(1,2,3,4,5,6)-CBWW*FGK(1,2,5,6,3,4))**2+
14803      &  CCWW**2*ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))**2
14804         WTMAX=4.*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
14805      &  CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
14806
14807       ELSEIF(ISUB.EQ.26) THEN
14808 C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0
14809         WT=PKK(1,3)*PKK(2,4)
14810         WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
14811
14812       ELSEIF(ISUB.EQ.30) THEN
14813 C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons
14814         IF(K(ILIN(1),2).GT.0) WT=((COUP(1,3)*COUP(3,3))**2+
14815      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,4)**2+PKK(3,5)**2)+
14816      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
14817      &  (PKK(1,3)**2+PKK(4,5)**2)
14818         IF(K(ILIN(1),2).LT.0) WT=((COUP(1,3)*COUP(3,3))**2+
14819      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,3)**2+PKK(4,5)**2)+
14820      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
14821      &  (PKK(1,4)**2+PKK(3,5)**2)
14822         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
14823      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
14824
14825       ELSEIF(ISUB.EQ.31) THEN
14826 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons
14827         IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
14828         IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
14829         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
14830
14831       ELSEIF(ISUB.EQ.141) THEN
14832 C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons
14833         EI=KCHG(IABS(MINT(15)),1)/3.
14834         AI=SIGN(1.,EI+0.1)
14835         VI=AI-4.*EI*XW
14836         API=SIGN(1.,EI+0.1)
14837         VPI=API-4.*EI*XW
14838         EF=KCHG(KFA,1)/3.
14839         AF=SIGN(1.,EF+0.1)
14840         VF=AF-4.*EF*XW
14841         APF=SIGN(1.,EF+0.1)
14842         VPF=APF-4.*EF*XW
14843         GG=1.
14844         GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
14845         GZP=1./(8.*XW*(1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GZMZP**2)
14846         ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
14847         ZZP=2./(16.*XW*(1.-XW))**2*
14848      &  SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/
14849      &  (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))
14850         ZPZP=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZP)**2+GZMZP**2)
14851         IF(MSTP(44).EQ.1) THEN
14852 C...Only gamma* production included
14853           GZ=0.
14854           GZP=0.
14855           ZZ=0.
14856           ZZP=0.
14857           ZPZP=0.
14858         ELSEIF(MSTP(44).EQ.2) THEN
14859 C...Only Z0 production included
14860           GG=0.
14861           GZ=0.
14862           GZP=0.
14863           ZZP=0.
14864           ZPZP=0.
14865         ELSEIF(MSTP(44).EQ.3) THEN
14866 C...Only Z'0 production included
14867           GG=0.
14868           GZ=0.
14869           GZP=0.
14870           ZZ=0.
14871           ZZP=0.
14872         ELSEIF(MSTP(44).EQ.4) THEN
14873 C...Only gamma*/Z0 production included
14874           GZP=0.
14875           ZZP=0.
14876           ZPZP=0.
14877         ELSEIF(MSTP(44).EQ.5) THEN
14878 C...Only gamma*/Z'0 production included
14879           GZ=0.
14880           ZZ=0.
14881           ZZP=0.
14882         ELSEIF(MSTP(44).EQ.6) THEN
14883 C...Only Z0/Z'0 production included
14884           GG=0.
14885           GZ=0.
14886           GZP=0.
14887         ENDIF
14888         ASYM=2.*(EI*AI*GZ*EF*AF+EI*API*GZP*EF*APF+4.*VI*AI*ZZ*VF*AF+
14889      &  (VI*API+VPI*AI)*ZZP*(VF*APF+VPF*AF)+4.*VPI*API*ZPZP*VPF*APF)/
14890      &  (EI**2*GG*EF**2+EI*VI*GZ*EF*VF+EI*VPI*GZP*EF*VPF+
14891      &  (VI**2+AI**2)*ZZ*(VF**2+AF**2)+(VI*VPI+AI*API)*ZZP*
14892      &  (VF*VPF+AF*APF)+(VPI**2+API**2)*ZPZP*(VPF**2+APF**2))
14893         WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
14894         WTMAX=2.+ABS(ASYM)
14895
14896       ELSE
14897         WT=1.
14898         WTMAX=1.
14899       ENDIF
14900 C...Obtain correct angular distribution by rejection techniques.
14901       IF(WT.LT.RLU(0)*WTMAX) GOTO 420
14902
14903 C...Construct massive four-vectors using angles chosen. Mark decayed
14904 C...resonances, add documentation lines. Shower evolution.
14905   500 DO 520 JT=1,JTMAX
14906       IF(KDCY(JT).EQ.0) GOTO 520
14907       ID=IREF(IP,JT)
14908       CALL LUDBRB(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
14909      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
14910       K(ID,1)=K(ID,1)+10
14911       K(ID,4)=NSD(JT)+1
14912       K(ID,5)=NSD(JT)+2
14913       IDOC=MINT(83)+MINT(4)
14914       DO 510 I=NSD(JT)+1,NSD(JT)+2
14915       MINT(4)=MINT(4)+1
14916       I1=MINT(83)+MINT(4)
14917       K(I,3)=I1
14918       K(I1,1)=21
14919       K(I1,2)=K(I,2)
14920       K(I1,3)=IREF(IP,JT+2)
14921       DO 510 J=1,5
14922   510 P(I1,J)=P(I,J)
14923       IF(JTMAX.EQ.1) THEN
14924         MINT(7)=MINT(83)+6+2*ISET(ISUB)
14925         MINT(8)=MINT(83)+7+2*ISET(ISUB)
14926       ENDIF
14927       IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,
14928      &NSD(JT)+2,P(ID,5))
14929
14930 C...Check if new resonances were produced, loop back if needed.
14931       IF(KDCY(JT).NE.3) GOTO 520
14932       NP=NP+1
14933       IREF(NP,1)=NSD(JT)+1
14934       IREF(NP,2)=NSD(JT)+2
14935       IREF(NP,3)=IDOC+1
14936       IREF(NP,4)=IDOC+2
14937       IREF(NP,5)=K(IREF(IP,JT),2)
14938       IREF(NP,6)=IREF(IP,JT)
14939   520 CONTINUE
14940   530 IF(IP.LT.NP) GOTO 100
14941
14942       RETURN
14943       END
14944
14945 C*********************************************************************
14946
14947       SUBROUTINE PYDIFF
14948
14949 C...Handles diffractive and elastic scattering.
14950       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
14951       SAVE /LUJETS/
14952       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14953       SAVE /LUDAT1/
14954       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14955       SAVE /PYPARS/
14956       COMMON/PYINT1/MINT(400),VINT(400)
14957       SAVE /PYINT1/
14958
14959 C...Reset K, P and V vectors. Store incoming particles.
14960       DO 100 JT=1,MSTP(126)+10
14961       I=MINT(83)+JT
14962       DO 100 J=1,5
14963       K(I,J)=0
14964       P(I,J)=0.
14965   100 V(I,J)=0.
14966       N=MINT(84)
14967       MINT(3)=0
14968       MINT(21)=0
14969       MINT(22)=0
14970       MINT(23)=0
14971       MINT(24)=0
14972       MINT(4)=4
14973       DO 110 JT=1,2
14974       I=MINT(83)+JT
14975       K(I,1)=21
14976       K(I,2)=MINT(10+JT)
14977       P(I,5)=VINT(2+JT)
14978       P(I,3)=VINT(5)*(-1)**(JT+1)
14979   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
14980       MINT(6)=2
14981
14982 C...Subprocess; kinematics.
14983       ISUB=MINT(1)
14984       SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4.*VINT(63)*VINT(64)
14985       PZ=SQRT(SQLAM)/(2.*VINT(1))
14986       DO 150 JT=1,2
14987       I=MINT(83)+JT
14988       PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2.*VINT(1))
14989
14990 C...Elastically scattered particle.
14991       IF(MINT(16+JT).LE.0) THEN
14992         N=N+1
14993         K(N,1)=1
14994         K(N,2)=K(I,2)
14995         K(N,3)=I+2
14996         P(N,3)=PZ*(-1)**(JT+1)
14997         P(N,4)=PE
14998         P(N,5)=P(I,5)
14999
15000 C...Diffracted particle: valence quark kicked out.
15001       ELSEIF(MSTP(101).EQ.1) THEN
15002         N=N+2
15003         K(N-1,1)=2
15004         K(N,1)=1
15005         K(N-1,3)=I+2
15006         K(N,3)=I+2
15007         CALL PYSPLI(K(I,2),21,K(N,2),K(N-1,2))
15008         P(N-1,5)=ULMASS(K(N-1,2))
15009         P(N,5)=ULMASS(K(N,2))
15010         SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
15011      &  4.*P(N-1,5)**2*P(N,5)**2
15012         P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
15013      &  P(N,5)**2))/(2.*VINT(62+JT))*(-1)**(JT+1)
15014         P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
15015         P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
15016         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15017
15018 C...Diffracted particle: gluon kicked out.
15019       ELSE
15020         N=N+3
15021         K(N-2,1)=2
15022         K(N-1,1)=2
15023         K(N,1)=1
15024         K(N-2,3)=I+2
15025         K(N-1,3)=I+2
15026         K(N,3)=I+2
15027         CALL PYSPLI(K(I,2),21,K(N,2),K(N-2,2))
15028         K(N-1,2)=21
15029         P(N-2,5)=ULMASS(K(N-2,2))
15030         P(N-1,5)=0.
15031         P(N,5)=ULMASS(K(N,2))
15032 C...Energy distribution for particle into two jets.
15033   120   IMB=1
15034         IF(MOD(K(I,2)/1000,10).NE.0) IMB=2
15035         CHIK=PARP(92+2*IMB)
15036         IF(MSTP(92).LE.1) THEN
15037           IF(IMB.EQ.1) CHI=RLU(0)
15038           IF(IMB.EQ.2) CHI=1.-SQRT(RLU(0))
15039         ELSEIF(MSTP(92).EQ.2) THEN
15040           CHI=1.-RLU(0)**(1./(1.+CHIK))
15041         ELSEIF(MSTP(92).EQ.3) THEN
15042           CUT=2.*0.3/VINT(1)
15043   130     CHI=RLU(0)**2
15044           IF((CHI**2/(CHI**2+CUT**2))**0.25*(1.-CHI)**CHIK.LT.
15045      &    RLU(0)) GOTO 130
15046         ELSE
15047           CUT=2.*0.3/VINT(1)
15048           CUTR=(1.+SQRT(1.+CUT**2))/CUT
15049   140     CHIR=CUT*CUTR**RLU(0)
15050           CHI=(CHIR**2-CUT**2)/(2.*CHIR)
15051           IF((1.-CHI)**CHIK.LT.RLU(0)) GOTO 140
15052         ENDIF
15053         IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1.-P(N-2,5)**2/
15054      &  VINT(62+JT)) GOTO 120
15055         SQM=P(N-2,5)**2/(1.-CHI)+P(N,5)**2/CHI
15056         IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 120
15057         PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15058      &  (2.*VINT(62+JT))
15059         PEI=SQRT(PZI**2+SQM)
15060         PQQP=(1.-CHI)*(PEI+PZI)
15061         P(N-2,3)=0.5*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15062         P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15063         P(N-1,3)=(PZ-PZI)*(-1)**(JT+1)
15064         P(N-1,4)=ABS(P(N-1,3))
15065         P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15066         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15067       ENDIF
15068
15069 C...Documentation lines.
15070       K(I+2,1)=21
15071       IF(MINT(16+JT).EQ.0) K(I+2,2)=MINT(10+JT)
15072       IF(MINT(16+JT).NE.0) K(I+2,2)=10*(MINT(10+JT)/10)
15073       K(I+2,3)=I
15074       P(I+2,3)=PZ*(-1)**(JT+1)
15075       P(I+2,4)=PE
15076       P(I+2,5)=SQRT(VINT(62+JT))
15077   150 CONTINUE
15078
15079 C...Rotate outgoing partons/particles using cos(theta).
15080       CALL LUDBRB(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15081
15082       RETURN
15083       END
15084
15085 C*********************************************************************
15086
15087       SUBROUTINE PYFRAM(IFRAME)
15088
15089 C...Performs transformations between different coordinate frames.
15090       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15091       SAVE /LUDAT1/
15092       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15093       SAVE /PYPARS/
15094       COMMON/PYINT1/MINT(400),VINT(400)
15095       SAVE /PYINT1/
15096
15097       IF(IFRAME.LT.1.OR.IFRAME.GT.2) THEN
15098         WRITE(MSTU(11),1000) IFRAME,MINT(6)
15099         RETURN
15100       ENDIF
15101       IF(IFRAME.EQ.MINT(6)) RETURN
15102
15103       IF(MINT(6).EQ.1) THEN
15104 C...Transform from fixed target or user specified frame to
15105 C...CM-frame of incoming particles.
15106         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
15107         CALL LUROBO(0.,-VINT(7),0.,0.,0.)
15108         CALL LUROBO(-VINT(6),0.,0.,0.,0.)
15109         MINT(6)=2
15110
15111       ELSE
15112 C...Transform from particle CM-frame to fixed target or user specified
15113 C...frame.
15114         CALL LUROBO(VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15115         MINT(6)=1
15116       ENDIF
15117       MSTI(6)=MINT(6)
15118
15119  1000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15120      &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
15121      &1X,I5)
15122
15123       RETURN
15124       END
15125
15126 C*********************************************************************
15127
15128       SUBROUTINE PYWIDT(KFLR,RMAS,WDTP,WDTE)
15129
15130 C...Calculates full and partial widths of resonances.
15131       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15132       SAVE /LUDAT1/
15133       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
15134       SAVE /LUDAT2/
15135       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
15136       SAVE /LUDAT3/
15137       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15138       SAVE /PYPARS/
15139       COMMON/PYINT1/MINT(400),VINT(400)
15140       SAVE /PYINT1/
15141       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
15142       SAVE /PYINT4/
15143       DIMENSION WDTP(0:40),WDTE(0:40,0:5)
15144
15145 C...Some common constants.
15146       KFLA=IABS(KFLR)
15147       SQM=RMAS**2
15148       AS=ULALPS(SQM)
15149       AEM=PARU(101)
15150       XW=PARU(102)
15151       RADC=1.+AS/PARU(1)
15152
15153 C...Reset width information.
15154       DO 100 I=0,40
15155       WDTP(I)=0.
15156       DO 100 J=0,5
15157   100 WDTE(I,J)=0.
15158
15159       IF(KFLA.EQ.21) THEN
15160 C...QCD:
15161         DO 110 I=1,MDCY(21,3)
15162         IDC=I+MDCY(21,2)-1
15163         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15164         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15165         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 110
15166         IF(I.LE.8) THEN
15167 C...QCD -> q + qb
15168           WDTP(I)=(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15169           WID2=1.
15170         ENDIF
15171         WDTP(0)=WDTP(0)+WDTP(I)
15172         IF(MDME(IDC,1).GT.0) THEN
15173           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15174           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15175           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15176           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15177         ENDIF
15178   110   CONTINUE
15179
15180       ELSEIF(KFLA.EQ.23) THEN
15181 C...Z0:
15182         IF(MINT(61).EQ.1) THEN
15183           EI=KCHG(IABS(MINT(15)),1)/3.
15184           AI=SIGN(1.,EI)
15185           VI=AI-4.*EI*XW
15186           SQMZ=PMAS(23,1)**2
15187           GZMZ=PMAS(23,2)*PMAS(23,1)
15188           GGI=EI**2
15189           GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
15190      &    ((SQM-SQMZ)**2+GZMZ**2)
15191           ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
15192      &    ((SQM-SQMZ)**2+GZMZ**2)
15193           IF(MSTP(43).EQ.1) THEN
15194 C...Only gamma* production included
15195             GZI=0.
15196             ZZI=0.
15197           ELSEIF(MSTP(43).EQ.2) THEN
15198 C...Only Z0 production included
15199             GGI=0.
15200             GZI=0.
15201           ENDIF
15202         ELSEIF(MINT(61).EQ.2) THEN
15203           VINT(111)=0.
15204           VINT(112)=0.
15205           VINT(114)=0.
15206         ENDIF
15207         DO 120 I=1,MDCY(23,3)
15208         IDC=I+MDCY(23,2)-1
15209         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15210         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15211         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 120
15212         IF(I.LE.8) THEN
15213 C...Z0 -> q + qb
15214           EF=KCHG(I,1)/3.
15215           AF=SIGN(1.,EF+0.1)
15216           VF=AF-4.*EF*XW
15217           IF(MINT(61).EQ.0) THEN
15218             WDTP(I)=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15219      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15220           ELSEIF(MINT(61).EQ.1) THEN
15221             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
15222      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
15223      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15224           ELSEIF(MINT(61).EQ.2) THEN
15225             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15226             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15227             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15228      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15229           ENDIF
15230           WID2=1.
15231         ELSEIF(I.LE.16) THEN
15232 C...Z0 -> l+ + l-, nu + nub
15233           EF=KCHG(I+2,1)/3.
15234           AF=SIGN(1.,EF+0.1)
15235           VF=AF-4.*EF*XW
15236           WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15237      &    SQRT(MAX(0.,1.-4.*RM1))
15238           IF(MINT(61).EQ.0) THEN
15239             WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15240      &      SQRT(MAX(0.,1.-4.*RM1))
15241           ELSEIF(MINT(61).EQ.1) THEN
15242             WDTP(I)=((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
15243      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
15244      &      SQRT(MAX(0.,1.-4.*RM1))
15245           ELSEIF(MINT(61).EQ.2) THEN
15246             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15247             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15248             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15249      &      SQRT(MAX(0.,1.-4.*RM1))
15250           ENDIF
15251           WID2=1.
15252         ELSE
15253 C...Z0 -> H+ + H-
15254           CF=2.*(1.-2.*XW)
15255           IF(MINT(61).EQ.0) THEN
15256             WDTP(I)=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15257           ELSEIF(MINT(61).EQ.1) THEN
15258             WDTP(I)=0.25*(GGI+GZI*CF+ZZI*CF**2)*(1.-4.*RM1)*
15259      &      SQRT(MAX(0.,1.-4.*RM1))
15260           ELSEIF(MINT(61).EQ.2) THEN
15261             GGF=0.25*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15262             GZF=0.25*CF*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15263             ZZF=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15264           ENDIF
15265           WID2=WIDS(37,1)
15266         ENDIF
15267         WDTP(0)=WDTP(0)+WDTP(I)
15268         IF(MDME(IDC,1).GT.0) THEN
15269           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15270           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15271           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15272           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15273           VINT(111)=VINT(111)+GGF*WID2
15274           VINT(112)=VINT(112)+GZF*WID2
15275           VINT(114)=VINT(114)+ZZF*WID2
15276         ENDIF
15277   120   CONTINUE
15278         IF(MSTP(43).EQ.1) THEN
15279 C...Only gamma* production included
15280           VINT(112)=0.
15281           VINT(114)=0.
15282         ELSEIF(MSTP(43).EQ.2) THEN
15283 C...Only Z0 production included
15284           VINT(111)=0.
15285           VINT(112)=0.
15286         ENDIF
15287
15288       ELSEIF(KFLA.EQ.24) THEN
15289 C...W+/-:
15290         DO 130 I=1,MDCY(24,3)
15291         IDC=I+MDCY(24,2)-1
15292         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15293         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15294         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 130
15295         IF(I.LE.16) THEN
15296 C...W+/- -> q + qb'
15297           WDTP(I)=3.*(2.-RM1-RM2-(RM1-RM2)**2)*
15298      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*
15299      &    VCKM((I-1)/4+1,MOD(I-1,4)+1)*RADC
15300           WID2=1.
15301         ELSE
15302 C...W+/- -> l+/- + nu
15303           WDTP(I)=(2.-RM1-RM2-(RM1-RM2)**2)*
15304      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
15305           WID2=1.
15306         ENDIF
15307         WDTP(0)=WDTP(0)+WDTP(I)
15308         IF(MDME(IDC,1).GT.0) THEN
15309           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15310           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15311           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15312           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15313         ENDIF
15314   130   CONTINUE
15315
15316       ELSEIF(KFLA.EQ.25) THEN
15317 C...H0:
15318         DO 170 I=1,MDCY(25,3)
15319         IDC=I+MDCY(25,2)-1
15320         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15321         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15322         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 170
15323         IF(I.LE.8) THEN
15324 C...H0 -> q + qb
15325           WDTP(I)=3.*RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15326           WID2=1.
15327         ELSEIF(I.LE.12) THEN
15328 C...H0 -> l+ + l-
15329           WDTP(I)=RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15330           WID2=1.
15331         ELSEIF(I.EQ.13) THEN
15332 C...H0 -> g + g; quark loop contribution only
15333           ETARE=0.
15334           ETAIM=0.
15335           DO 140 J=1,2*MSTP(1)
15336           EPS=(2.*PMAS(J,1)/RMAS)**2
15337           IF(EPS.LE.1.) THEN
15338             IF(EPS.GT.1.E-4) THEN
15339               ROOT=SQRT(1.-EPS)
15340               RLN=LOG((1.+ROOT)/(1.-ROOT))
15341             ELSE
15342               RLN=LOG(4./EPS-2.)
15343             ENDIF
15344             PHIRE=0.25*(RLN**2-PARU(1)**2)
15345             PHIIM=0.5*PARU(1)*RLN
15346           ELSE
15347             PHIRE=-(ASIN(1./SQRT(EPS)))**2
15348             PHIIM=0.
15349           ENDIF
15350           ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
15351           ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
15352   140     CONTINUE
15353           ETA2=ETARE**2+ETAIM**2
15354           WDTP(I)=(AS/PARU(1))**2*ETA2
15355           WID2=1.
15356         ELSEIF(I.EQ.14) THEN
15357 C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions
15358           ETARE=0.
15359           ETAIM=0.
15360           DO 150 J=1,3*MSTP(1)+1
15361           IF(J.LE.2*MSTP(1)) THEN
15362             EJ=KCHG(J,1)/3.
15363             EPS=(2.*PMAS(J,1)/RMAS)**2
15364           ELSEIF(J.LE.3*MSTP(1)) THEN
15365             JL=2*(J-2*MSTP(1))-1
15366             EJ=KCHG(10+JL,1)/3.
15367             EPS=(2.*PMAS(10+JL,1)/RMAS)**2
15368           ELSE
15369             EPS=(2.*PMAS(24,1)/RMAS)**2
15370           ENDIF
15371           IF(EPS.LE.1.) THEN
15372             IF(EPS.GT.1.E-4) THEN
15373               ROOT=SQRT(1.-EPS)
15374               RLN=LOG((1.+ROOT)/(1.-ROOT))
15375             ELSE
15376               RLN=LOG(4./EPS-2.)
15377             ENDIF
15378             PHIRE=0.25*(RLN**2-PARU(1)**2)
15379             PHIIM=0.5*PARU(1)*RLN
15380           ELSE
15381             PHIRE=-(ASIN(1./SQRT(EPS)))**2
15382             PHIIM=0.
15383           ENDIF
15384           IF(J.LE.2*MSTP(1)) THEN
15385             ETARE=ETARE+0.5*3.*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
15386             ETAIM=ETAIM+0.5*3.*EJ**2*EPS*(EPS-1.)*PHIIM
15387           ELSEIF(J.LE.3*MSTP(1)) THEN
15388             ETARE=ETARE+0.5*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
15389             ETAIM=ETAIM+0.5*EJ**2*EPS*(EPS-1.)*PHIIM
15390           ELSE
15391             ETARE=ETARE-0.5-0.75*EPS*(1.+(EPS-2.)*PHIRE)
15392             ETAIM=ETAIM+0.75*EPS*(EPS-2.)*PHIIM
15393           ENDIF
15394   150     CONTINUE
15395           ETA2=ETARE**2+ETAIM**2
15396           WDTP(I)=(AEM/PARU(1))**2*0.5*ETA2
15397           WID2=1.
15398         ELSEIF(I.EQ.15) THEN
15399 C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions
15400           ETARE=0.
15401           ETAIM=0.
15402           DO 160 J=1,3*MSTP(1)+1
15403           IF(J.LE.2*MSTP(1)) THEN
15404             EJ=KCHG(J,1)/3.
15405             AJ=SIGN(1.,EJ+0.1)
15406             VJ=AJ-4.*EJ*XW
15407             EPS=(2.*PMAS(J,1)/RMAS)**2
15408             EPSP=(2.*PMAS(J,1)/PMAS(23,1))**2
15409           ELSEIF(J.LE.3*MSTP(1)) THEN
15410             JL=2*(J-2*MSTP(1))-1
15411             EJ=KCHG(10+JL,1)/3.
15412             AJ=SIGN(1.,EJ+0.1)
15413             VJ=AI-4.*EJ*XW
15414             EPS=(2.*PMAS(10+JL,1)/RMAS)**2
15415             EPSP=(2.*PMAS(10+JL,1)/PMAS(23,1))**2
15416           ELSE
15417             EPS=(2.*PMAS(24,1)/RMAS)**2
15418             EPSP=(2.*PMAS(24,1)/PMAS(23,1))**2
15419           ENDIF
15420           IF(EPS.LE.1.) THEN
15421             ROOT=SQRT(1.-EPS)
15422             IF(EPS.GT.1.E-4) THEN
15423               RLN=LOG((1.+ROOT)/(1.-ROOT))
15424             ELSE
15425               RLN=LOG(4./EPS-2.)
15426             ENDIF
15427             PHIRE=0.25*(RLN**2-PARU(1)**2)
15428             PHIIM=0.5*PARU(1)*RLN
15429             PSIRE=-(1.+0.5*ROOT*RLN)
15430             PSIIM=0.5*PARU(1)*ROOT
15431           ELSE
15432             PHIRE=-(ASIN(1./SQRT(EPS)))**2
15433             PHIIM=0.
15434             PSIRE=-(1.+SQRT(EPS-1.)*ASIN(1./SQRT(EPS)))
15435             PSIIM=0.
15436           ENDIF
15437           IF(EPSP.LE.1.) THEN
15438             ROOT=SQRT(1.-EPSP)
15439             IF(EPSP.GT.1.E-4) THEN
15440               RLN=LOG((1.+ROOT)/(1.-ROOT))
15441             ELSE
15442               RLN=LOG(4./EPSP-2.)
15443             ENDIF
15444             PHIREP=0.25*(RLN**2-PARU(1)**2)
15445             PHIIMP=0.5*PARU(1)*RLN
15446             PSIREP=-(1.+0.5*ROOT*RLN)
15447             PSIIMP=0.5*PARU(1)*ROOT
15448           ELSE
15449             PHIREP=-(ASIN(1./SQRT(EPSP)))**2
15450             PHIIMP=0.
15451             PSIREP=-(1.+SQRT(EPSP-1.)*ASIN(1./SQRT(EPSP)))
15452             PSIIMP=0.
15453           ENDIF
15454           FXYRE=EPS*EPSP/(8.*(EPS-EPSP))*(1.-EPS*EPSP/(EPS-EPSP)*(PHIRE-
15455      &    PHIREP)+2.*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
15456           FXYIM=EPS*EPSP/(8.*(EPS-EPSP))*(-EPS*EPSP/(EPS-EPSP)*(PHIIM-
15457      &    PHIIMP)+2.*EPS/(EPS-EPSP)*(PSIIM-PSIIMP))
15458           F1RE=EPS*EPSP/(2.*(EPS-EPSP))*(PHIRE-PHIREP)
15459           F1IM=EPS*EPSP/(2.*(EPS-EPSP))*(PHIIM-PHIIMP)
15460           IF(J.LE.2*MSTP(1)) THEN
15461             ETARE=ETARE-3.*EJ*VJ*(FXYRE-0.25*F1RE)
15462             ETAIM=ETAIM-3.*EJ*VJ*(FXYIM-0.25*F1IM)
15463           ELSEIF(J.LE.3*MSTP(1)) THEN
15464             ETARE=ETARE-EJ*VJ*(FXYRE-0.25*F1RE)
15465             ETAIM=ETAIM-EJ*VJ*(FXYIM-0.25*F1IM)
15466           ELSE
15467             ETARE=ETARE-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
15468      &      (5.+2./EPS))*FXYRE+(3.-XW/SQRT(1.-XW))*F1RE)
15469             ETAIM=ETAIM-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
15470      &      (5.+2./EPS))*FXYIM+(3.-XW/SQRT(1.-XW))*F1IM)
15471           ENDIF
15472   160     CONTINUE
15473           ETA2=ETARE**2+ETAIM**2
15474           WDTP(I)=(AEM/PARU(1))**2*(1.-(PMAS(23,1)/RMAS)**2)**3/XW*ETA2
15475           WID2=WIDS(23,2)
15476         ELSE
15477 C...H0 -> Z0 + Z0, W+ + W-
15478           WDTP(I)=(1.-4.*RM1+12.*RM1**2)*SQRT(MAX(0.,1.-4.*RM1))/
15479      &    (2.*(18-I))
15480           WID2=WIDS(7+I,1)
15481         ENDIF
15482         WDTP(0)=WDTP(0)+WDTP(I)
15483         IF(MDME(IDC,1).GT.0) THEN
15484           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15485           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15486           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15487           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15488         ENDIF
15489   170   CONTINUE
15490
15491       ELSEIF(KFLA.EQ.32) THEN
15492 C...Z'0:
15493         IF(MINT(61).EQ.1) THEN
15494           EI=KCHG(IABS(MINT(15)),1)/3.
15495           AI=SIGN(1.,EI)
15496           VI=AI-4.*EI*XW
15497           SQMZ=PMAS(23,1)**2
15498           GZMZ=PMAS(23,2)*PMAS(23,1)
15499           API=SIGN(1.,EI)
15500           VPI=API-4.*EI*XW
15501           SQMZP=PMAS(32,1)**2
15502           GZPMZP=PMAS(32,2)*PMAS(32,1)
15503           GGI=EI**2
15504           GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
15505      &    ((SQM-SQMZ)**2+GZMZ**2)
15506           GZPI=EI*VPI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZP)/
15507      &    ((SQM-SQMZP)**2+GZPMZP**2)
15508           ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
15509      &    ((SQM-SQMZ)**2+GZMZ**2)
15510           ZZPI=2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*
15511      &    SQM**2*((SQM-SQMZ)*(SQM-SQMZP)+GZMZ*GZPMZP)/
15512      &    (((SQM-SQMZ)**2+GZMZ**2)*((SQM-SQMZP)**2+GZPMZP**2))
15513           ZPZPI=(VPI**2+API**2)/(16.*XW*(1.-XW))**2*SQM**2/
15514      &    ((SQM-SQMZP)**2+GZPMZP**2)
15515           IF(MSTP(44).EQ.1) THEN
15516 C...Only gamma* production included
15517             GZI=0.
15518             GZPI=0.
15519             ZZI=0.
15520             ZZPI=0.
15521             ZPZPI=0.
15522           ELSEIF(MSTP(44).EQ.2) THEN
15523 C...Only Z0 production included
15524             GGI=0.
15525             GZI=0.
15526             GZPI=0.
15527             ZZPI=0.
15528             ZPZPI=0.
15529           ELSEIF(MSTP(44).EQ.3) THEN
15530 C...Only Z'0 production included
15531             GGI=0.
15532             GZI=0.
15533             GZPI=0.
15534             ZZI=0.
15535             ZZPI=0.
15536           ELSEIF(MSTP(44).EQ.4) THEN
15537 C...Only gamma*/Z0 production included
15538             GZPI=0.
15539             ZZPI=0.
15540             ZPZPI=0.
15541           ELSEIF(MSTP(44).EQ.5) THEN
15542 C...Only gamma*/Z'0 production included
15543             GZI=0.
15544             ZZI=0.
15545             ZZPI=0.
15546           ELSEIF(MSTP(44).EQ.6) THEN
15547 C...Only Z0/Z'0 production included
15548             GGI=0.
15549             GZI=0.
15550             GZPI=0.
15551           ENDIF
15552         ELSEIF(MINT(61).EQ.2) THEN
15553           VINT(111)=0.
15554           VINT(112)=0.
15555           VINT(113)=0.
15556           VINT(114)=0.
15557           VINT(115)=0.
15558           VINT(116)=0.
15559         ENDIF
15560         DO 180 I=1,MDCY(32,3)
15561         IDC=I+MDCY(32,2)-1
15562         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15563         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15564         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 180
15565         IF(I.LE.8) THEN
15566 C...Z'0 -> q + qb
15567           EF=KCHG(I,1)/3.
15568           AF=SIGN(1.,EF+0.1)
15569           VF=AF-4.*EF*XW
15570           APF=SIGN(1.,EF+0.1)
15571           VPF=APF-4.*EF*XW
15572           IF(MINT(61).EQ.0) THEN
15573             WDTP(I)=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15574      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15575           ELSEIF(MINT(61).EQ.1) THEN
15576             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
15577      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
15578      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
15579      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15580           ELSEIF(MINT(61).EQ.2) THEN
15581             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15582             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15583             GZPF=3.*EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15584             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15585      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15586             ZZPF=3.*(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
15587      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15588             ZPZPF=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15589      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15590           ENDIF
15591           WID2=1.
15592         ELSE
15593 C...Z'0 -> l+ + l-, nu + nub
15594           EF=KCHG(I+2,1)/3.
15595           AF=SIGN(1.,EF+0.1)
15596           VF=AF-4.*EF*XW
15597           APF=SIGN(1.,EF+0.1)
15598           VPF=API-4.*EF*XW
15599           IF(MINT(61).EQ.0) THEN
15600             WDTP(I)=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15601      &      SQRT(MAX(0.,1.-4.*RM1))
15602           ELSEIF(MINT(61).EQ.1) THEN
15603             WDTP(I)=((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
15604      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
15605      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
15606      &      SQRT(MAX(0.,1.-4.*RM1))
15607           ELSEIF(MINT(61).EQ.2) THEN
15608             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15609             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15610             GZPF=EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15611             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15612      &      SQRT(MAX(0.,1.-4.*RM1))
15613             ZZPF=(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
15614      &      SQRT(MAX(0.,1.-4.*RM1))
15615             ZPZPF=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15616      &      SQRT(MAX(0.,1.-4.*RM1))
15617           ENDIF
15618           WID2=1.
15619         ENDIF
15620         WDTP(0)=WDTP(0)+WDTP(I)
15621         IF(MDME(IDC,1).GT.0) THEN
15622           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15623           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15624           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15625           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15626           VINT(111)=VINT(111)+GGF
15627           VINT(112)=VINT(112)+GZF
15628           VINT(113)=VINT(113)+GZPF
15629           VINT(114)=VINT(114)+ZZF
15630           VINT(115)=VINT(115)+ZZPF
15631           VINT(116)=VINT(116)+ZPZPF
15632         ENDIF
15633   180   CONTINUE
15634         IF(MSTP(44).EQ.1) THEN
15635 C...Only gamma* production included
15636           VINT(112)=0.
15637           VINT(113)=0.
15638           VINT(114)=0.
15639           VINT(115)=0.
15640           VINT(116)=0.
15641         ELSEIF(MSTP(44).EQ.2) THEN
15642 C...Only Z0 production included
15643           VINT(111)=0.
15644           VINT(112)=0.
15645           VINT(113)=0.
15646           VINT(115)=0.
15647           VINT(116)=0.
15648         ELSEIF(MSTP(44).EQ.3) THEN
15649 C...Only Z'0 production included
15650           VINT(111)=0.
15651           VINT(112)=0.
15652           VINT(113)=0.
15653           VINT(114)=0.
15654           VINT(115)=0.
15655         ELSEIF(MSTP(44).EQ.4) THEN
15656 C...Only gamma*/Z0 production included
15657           VINT(113)=0.
15658           VINT(115)=0.
15659           VINT(116)=0.
15660         ELSEIF(MSTP(44).EQ.5) THEN
15661 C...Only gamma*/Z'0 production included
15662           VINT(112)=0.
15663           VINT(114)=0.
15664           VINT(115)=0.
15665         ELSEIF(MSTP(44).EQ.6) THEN
15666 C...Only Z0/Z'0 production included
15667           VINT(111)=0.
15668           VINT(112)=0.
15669           VINT(113)=0.
15670         ENDIF
15671
15672       ELSEIF(KFLA.EQ.37) THEN
15673 C...H+/-:
15674         DO 190 I=1,MDCY(37,3)
15675         IDC=I+MDCY(37,2)-1
15676         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15677         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15678         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 190
15679         IF(I.LE.4) THEN
15680 C...H+/- -> q + qb'
15681           WDTP(I)=3.*((RM1*PARU(121)+RM2/PARU(121))*
15682      &    (1.-RM1-RM2)-4.*RM1*RM2)*
15683      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*RADC
15684           WID2=1.
15685         ELSE
15686 C...H+/- -> l+/- + nu
15687           WDTP(I)=((RM1*PARU(121)+RM2/PARU(121))*
15688      &    (1.-RM1-RM2)-4.*RM1*RM2)*
15689      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
15690           WID2=1.
15691         ENDIF
15692         WDTP(0)=WDTP(0)+WDTP(I)
15693         IF(MDME(IDC,1).GT.0) THEN
15694           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15695           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15696           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15697           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15698         ENDIF
15699   190   CONTINUE
15700
15701       ELSEIF(KFLA.EQ.40) THEN
15702 C...R:
15703         DO 200 I=1,MDCY(40,3)
15704         IDC=I+MDCY(40,2)-1
15705         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15706         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15707         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 200
15708         IF(I.LE.4) THEN
15709 C...R -> q + qb'
15710           WDTP(I)=3.*RADC
15711           WID2=1.
15712         ELSE
15713 C...R -> l+ + l'-
15714           WDTP(I)=1.
15715           WID2=1.
15716         ENDIF
15717         WDTP(0)=WDTP(0)+WDTP(I)
15718         IF(MDME(IDC,1).GT.0) THEN
15719           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15720           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15721           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15722           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15723         ENDIF
15724   200   CONTINUE
15725
15726       ENDIF
15727       MINT(61)=0
15728
15729       RETURN
15730       END
15731
15732 C***********************************************************************
15733
15734       SUBROUTINE PYKLIM(ILIM)
15735
15736 C...Checks generated variables against pre-set kinematical limits;
15737 C...also calculates limits on variables used in generation.
15738       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15739       SAVE /LUDAT1/
15740       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
15741       SAVE /LUDAT2/
15742       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
15743       SAVE /LUDAT3/
15744       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15745       SAVE /PYPARS/
15746       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
15747       SAVE /PYSUBS/
15748       COMMON/PYINT1/MINT(400),VINT(400)
15749       SAVE /PYINT1/
15750       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
15751       SAVE /PYINT2/
15752
15753 C...Common kinematical expressions.
15754       ISUB=MINT(1)
15755       IF(ISUB.EQ.96) GOTO 110
15756       SQM3=VINT(63)
15757       SQM4=VINT(64)
15758       IF(ILIM.NE.1) THEN
15759         TAU=VINT(21)
15760         RM3=SQM3/(TAU*VINT(2))
15761         RM4=SQM4/(TAU*VINT(2))
15762         BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
15763       ENDIF
15764       PTHMIN=CKIN(3)
15765       IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) PTHMIN=MAX(CKIN(3),CKIN(5))
15766
15767       IF(ILIM.EQ.0) THEN
15768 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15769 C...pre-set kinematical limits.
15770         YST=VINT(22)
15771         CTH=VINT(23)
15772         TAUP=VINT(26)
15773         IF(ISET(ISUB).LE.2) THEN
15774           X1=SQRT(TAU)*EXP(YST)
15775           X2=SQRT(TAU)*EXP(-YST)
15776         ELSE
15777           X1=SQRT(TAUP)*EXP(YST)
15778           X2=SQRT(TAUP)*EXP(-YST)
15779         ENDIF
15780         XF=X1-X2
15781         IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
15782         IF(CKIN(2).GE.0..AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
15783         IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
15784         IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
15785         IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
15786         IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
15787         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
15788           PTH=0.5*BE34*SQRT(TAU*VINT(2)*(1.-CTH**2))
15789           Y3=YST+0.5*LOG((1.+RM3-RM4+BE34*CTH)/(1.+RM3-RM4-BE34*CTH))
15790           Y4=YST+0.5*LOG((1.+RM4-RM3-BE34*CTH)/(1.+RM4-RM3+BE34*CTH))
15791           YLARGE=MAX(Y3,Y4)
15792           YSMALL=MIN(Y3,Y4)
15793           ETALAR=10.
15794           ETASMA=-10.
15795           STH=SQRT(1.-CTH**2)
15796           IF(STH.LT.1.E-6) GOTO 100
15797           EXPET3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+
15798      &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3))/
15799      &    (BE34*STH)
15800           EXPET4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+
15801      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4))/
15802      &    (BE34*STH)
15803           ETA3=LOG(MIN(1.E10,MAX(1.E-10,EXPET3)))
15804           ETA4=LOG(MIN(1.E10,MAX(1.E-10,EXPET4)))
15805           ETALAR=MAX(ETA3,ETA4)
15806           ETASMA=MIN(ETA3,ETA4)
15807   100     CTS3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/
15808      &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3)
15809           CTS4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/
15810      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4)
15811           CTSLAR=MAX(CTS3,CTS4)
15812           CTSSMA=MIN(CTS3,CTS4)
15813           IF(PTH.LT.PTHMIN) MINT(51)=1
15814           IF(CKIN(4).GE.0..AND.PTH.GT.CKIN(4)) MINT(51)=1
15815           IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
15816           IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
15817           IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
15818           IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
15819           IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
15820           IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
15821           IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
15822         ENDIF
15823         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
15824           IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
15825           IF(CKIN(32).GE.0..AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
15826         ENDIF
15827
15828       ELSEIF(ILIM.EQ.1) THEN
15829 C...Calculate limits on tau
15830 C...0) due to definition
15831         TAUMN0=0.
15832         TAUMX0=1.
15833 C...1) due to limits on subsystem mass
15834         TAUMN1=CKIN(1)**2/VINT(2)
15835         TAUMX1=1.
15836         IF(CKIN(2).GE.0.) TAUMX1=CKIN(2)**2/VINT(2)
15837 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15838         TM3=SQRT(SQM3+PTHMIN**2)
15839         TM4=SQRT(SQM4+PTHMIN**2)
15840         YDCOSH=1.
15841         IF(CKIN(9).GT.CKIN(12)) YDCOSH=COSH(CKIN(9)-CKIN(12))
15842         TAUMN2=(TM3**2+2.*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
15843         TAUMX2=1.
15844 C...3) due to limits on pT-hat and cos(theta-hat)
15845         CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
15846         CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
15847         TAUMN3=0.
15848         IF(CKIN(27)*CKIN(28).GT.0.) TAUMN3=
15849      &  (SQRT(SQM3+PTHMIN**2/(1.-CTH2MN))+
15850      &  SQRT(SQM4+PTHMIN**2/(1.-CTH2MN)))**2/VINT(2)
15851         TAUMX3=1.
15852         IF(CKIN(4).GE.0..AND.CTH2MX.LT.1.) TAUMX3=
15853      &  (SQRT(SQM3+CKIN(4)**2/(1.-CTH2MX))+
15854      &  SQRT(SQM4+CKIN(4)**2/(1.-CTH2MX)))**2/VINT(2)
15855 C...4) due to limits on x1 and x2
15856         TAUMN4=CKIN(21)*CKIN(23)
15857         TAUMX4=CKIN(22)*CKIN(24)
15858 C...5) due to limits on xF
15859         TAUMN5=0.
15860         TAUMX5=MAX(1.-CKIN(25),1.+CKIN(26))
15861         VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5)
15862         VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5)
15863         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
15864           VINT(11)=0.99999
15865           VINT(31)=1.00001
15866         ENDIF
15867         IF(VINT(31).LE.VINT(11)) MINT(51)=1
15868
15869       ELSEIF(ILIM.EQ.2) THEN
15870 C...Calculate limits on y*
15871         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) TAU=VINT(26)
15872         TAURT=SQRT(TAU)
15873 C...0) due to kinematics
15874         YSTMN0=LOG(TAURT)
15875         YSTMX0=-YSTMN0
15876 C...1) due to explicit limits
15877         YSTMN1=CKIN(7)
15878         YSTMX1=CKIN(8)
15879 C...2) due to limits on x1
15880         YSTMN2=LOG(MAX(TAU,CKIN(21))/TAURT)
15881         YSTMX2=LOG(MAX(TAU,CKIN(22))/TAURT)
15882 C...3) due to limits on x2
15883         YSTMN3=-LOG(MAX(TAU,CKIN(24))/TAURT)
15884         YSTMX3=-LOG(MAX(TAU,CKIN(23))/TAURT)
15885 C...4) due to limits on xF
15886         YEPMN4=0.5*ABS(CKIN(25))/TAURT
15887         YSTMN4=SIGN(LOG(SQRT(1.+YEPMN4**2)+YEPMN4),CKIN(25))
15888         YEPMX4=0.5*ABS(CKIN(26))/TAURT
15889         YSTMX4=SIGN(LOG(SQRT(1.+YEPMX4**2)+YEPMX4),CKIN(26))
15890 C...5) due to simultaneous limits on y-large and y-small
15891         YEPSMN=(RM3-RM4)*SINH(CKIN(9)-CKIN(11))
15892         YEPSMX=(RM3-RM4)*SINH(CKIN(10)-CKIN(12))
15893         YDIFMN=ABS(LOG(SQRT(1.+YEPSMN**2)-YEPSMN))
15894         YDIFMX=ABS(LOG(SQRT(1.+YEPSMX**2)-YEPSMX))
15895         YSTMN5=0.5*(CKIN(9)+CKIN(11)-YDIFMN)
15896         YSTMX5=0.5*(CKIN(10)+CKIN(12)+YDIFMX)
15897 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15898 C...   y-small
15899         CTHLIM=SQRT(1.-4.*PTHMIN**2/(BE34*TAU*VINT(2)))
15900         RZMN=BE34*MAX(CKIN(27),-CTHLIM)
15901         RZMX=BE34*MIN(CKIN(28),CTHLIM)
15902         YEX3MX=(1.+RM3-RM4+RZMX)/MAX(1E-10,1.+RM3-RM4-RZMX)
15903         YEX4MX=(1.+RM4-RM3-RZMN)/MAX(1E-10,1.+RM4-RM3+RZMN)
15904         YEX3MN=MAX(1E-10,1.+RM3-RM4+RZMN)/(1.+RM3-RM4-RZMN)
15905         YEX4MN=MAX(1E-10,1.+RM4-RM3-RZMX)/(1.+RM4-RM3+RZMX)
15906         YSTMN6=CKIN(9)-0.5*LOG(MAX(YEX3MX,YEX4MX))
15907         YSTMX6=CKIN(12)-0.5*LOG(MIN(YEX3MN,YEX4MN))
15908         VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
15909         VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
15910         IF(MINT(43).EQ.1) THEN
15911           VINT(12)=-0.00001
15912           VINT(32)=0.00001
15913         ELSEIF(MINT(43).EQ.2) THEN
15914           VINT(12)=0.99999*YSTMX0
15915           VINT(32)=1.00001*YSTMX0
15916         ELSEIF(MINT(43).EQ.3) THEN
15917           VINT(12)=-1.00001*YSTMX0
15918           VINT(32)=-0.99999*YSTMX0
15919         ENDIF
15920         IF(VINT(32).LE.VINT(12)) MINT(51)=1
15921
15922       ELSEIF(ILIM.EQ.3) THEN
15923 C...Calculate limits on cos(theta-hat)
15924         YST=VINT(22)
15925 C...0) due to definition
15926         CTNMN0=-1.
15927         CTNMX0=0.
15928         CTPMN0=0.
15929         CTPMX0=1.
15930 C...1) due to explicit limits
15931         CTNMN1=MIN(0.,CKIN(27))
15932         CTNMX1=MIN(0.,CKIN(28))
15933         CTPMN1=MAX(0.,CKIN(27))
15934         CTPMX1=MAX(0.,CKIN(28))
15935 C...2) due to limits on pT-hat
15936         CTNMN2=-SQRT(1.-4.*PTHMIN**2/(BE34**2*TAU*VINT(2)))
15937         CTPMX2=-CTNMN2
15938         CTNMX2=0.
15939         CTPMN2=0.
15940         IF(CKIN(4).GE.0.) THEN
15941           CTNMX2=-SQRT(MAX(0.,1.-4.*CKIN(4)**2/(BE34**2*TAU*VINT(2))))
15942           CTPMN2=-CTNMX2
15943         ENDIF
15944 C...3) due to limits on y-large and y-small
15945         CTNMN3=MIN(0.,MAX((1.+RM3-RM4)/BE34*TANH(CKIN(11)-YST),
15946      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(10)-YST)))
15947         CTNMX3=MIN(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(12)-YST),
15948      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(9)-YST))
15949         CTPMN3=MAX(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(9)-YST),
15950      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(12)-YST))
15951         CTPMX3=MAX(0.,MIN((1.+RM3-RM4)/BE34*TANH(CKIN(10)-YST),
15952      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(11)-YST)))
15953         VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3)
15954         VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3)
15955         VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3)
15956         VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3)
15957         IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
15958
15959       ELSEIF(ILIM.EQ.4) THEN
15960 C...Calculate limits on tau'
15961 C...0) due to kinematics
15962         TAPMN0=TAU
15963         TAPMX0=1.
15964 C...1) due to explicit limits
15965         TAPMN1=CKIN(31)**2/VINT(2)
15966         TAPMX1=1.
15967         IF(CKIN(32).GE.0.) TAPMX1=CKIN(32)**2/VINT(2)
15968         VINT(16)=MAX(TAPMN0,TAPMN1)
15969         VINT(36)=MIN(TAPMX0,TAPMX1)
15970         IF(MINT(43).EQ.1) THEN
15971           VINT(16)=0.99999
15972           VINT(36)=1.00001
15973         ENDIF
15974         IF(VINT(36).LE.VINT(16)) MINT(51)=1
15975
15976       ENDIF
15977       RETURN
15978
15979 C...Special case for low-pT and multiple interactions:
15980 C...effective kinematical limits for tau, y*, cos(theta-hat).
15981   110 IF(ILIM.EQ.0) THEN
15982       ELSEIF(ILIM.EQ.1) THEN
15983         IF(MSTP(82).LE.1) VINT(11)=4.*PARP(81)**2/VINT(2)
15984         IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
15985         VINT(31)=1.
15986       ELSEIF(ILIM.EQ.2) THEN
15987         VINT(12)=0.5*LOG(VINT(21))
15988         VINT(32)=-VINT(12)
15989       ELSEIF(ILIM.EQ.3) THEN
15990         IF(MSTP(82).LE.1) ST2EFF=4.*PARP(81)**2/(VINT(21)*VINT(2))
15991         IF(MSTP(82).GE.2) ST2EFF=0.01*PARP(82)**2/(VINT(21)*VINT(2))
15992         VINT(13)=-SQRT(MAX(0.,1.-ST2EFF))
15993         VINT(33)=0.
15994         VINT(14)=0.
15995         VINT(34)=-VINT(13)
15996       ENDIF
15997
15998       RETURN
15999       END
16000
16001 C*********************************************************************
16002
16003       SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
16004
16005 C...Maps a uniform distribution into a distribution of a kinematical
16006 C...variable according to one of the possibilities allowed. It is
16007 C...assumed that kinematical limits have been set by a PYKLIM call.
16008       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
16009       SAVE /LUDAT2/
16010       COMMON/PYINT1/MINT(400),VINT(400)
16011       SAVE /PYINT1/
16012       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
16013       SAVE /PYINT2/
16014
16015 C...Convert VVAR to tau variable.
16016       ISUB=MINT(1)
16017       IF(IVAR.EQ.1) THEN
16018         TAUMIN=VINT(11)
16019         TAUMAX=VINT(31)
16020         IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
16021           TAURE=VINT(73)
16022           GAMRE=VINT(74)
16023         ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
16024           TAURE=VINT(75)
16025           GAMRE=VINT(76)
16026         ENDIF
16027         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
16028           TAU=1.
16029         ELSEIF(MVAR.EQ.1) THEN
16030           TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
16031         ELSEIF(MVAR.EQ.2) THEN
16032           TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
16033         ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
16034           RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
16035           TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
16036         ELSE
16037           AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
16038           ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
16039           TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
16040         ENDIF
16041         VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
16042
16043 C...Convert VVAR to y* variable.
16044       ELSEIF(IVAR.EQ.2) THEN
16045         YSTMIN=VINT(12)
16046         YSTMAX=VINT(32)
16047         IF(MINT(43).EQ.1) THEN
16048           YST=0.
16049         ELSEIF(MINT(43).EQ.2) THEN
16050           IF(ISET(ISUB).LE.2) YST=-0.5*LOG(VINT(21))
16051           IF(ISET(ISUB).GE.3) YST=-0.5*LOG(VINT(26))
16052         ELSEIF(MINT(43).EQ.3) THEN
16053           IF(ISET(ISUB).LE.2) YST=0.5*LOG(VINT(21))
16054           IF(ISET(ISUB).GE.3) YST=0.5*LOG(VINT(26))
16055         ELSEIF(MVAR.EQ.1) THEN
16056           YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
16057         ELSEIF(MVAR.EQ.2) THEN
16058           YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1.-VVAR)
16059         ELSE
16060           AUPP=ATAN(EXP(YSTMAX))
16061           ALOW=ATAN(EXP(YSTMIN))
16062           YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
16063         ENDIF
16064         VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
16065
16066 C...Convert VVAR to cos(theta-hat) variable.
16067       ELSEIF(IVAR.EQ.3) THEN
16068         RM34=2.*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2
16069         RSQM=1.+RM34
16070         IF(2.*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001) RM34=MAX(RM34,
16071      &  2.*VINT(71)**2/(VINT(21)*VINT(2)))
16072         CTNMIN=VINT(13)
16073         CTNMAX=VINT(33)
16074         CTPMIN=VINT(14)
16075         CTPMAX=VINT(34)
16076         IF(MVAR.EQ.1) THEN
16077           ANEG=CTNMAX-CTNMIN
16078           APOS=CTPMAX-CTPMIN
16079           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
16080             VCTN=VVAR*(ANEG+APOS)/ANEG
16081             CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
16082           ELSE
16083             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
16084             CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
16085           ENDIF
16086         ELSEIF(MVAR.EQ.2) THEN
16087           RMNMIN=MAX(RM34,RSQM-CTNMIN)
16088           RMNMAX=MAX(RM34,RSQM-CTNMAX)
16089           RMPMIN=MAX(RM34,RSQM-CTPMIN)
16090           RMPMAX=MAX(RM34,RSQM-CTPMAX)
16091           ANEG=LOG(RMNMIN/RMNMAX)
16092           APOS=LOG(RMPMIN/RMPMAX)
16093           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
16094             VCTN=VVAR*(ANEG+APOS)/ANEG
16095             CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
16096           ELSE
16097             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
16098             CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
16099           ENDIF
16100         ELSEIF(MVAR.EQ.3) THEN
16101           RMNMIN=MAX(RM34,RSQM+CTNMIN)
16102           RMNMAX=MAX(RM34,RSQM+CTNMAX)
16103           RMPMIN=MAX(RM34,RSQM+CTPMIN)
16104           RMPMAX=MAX(RM34,RSQM+CTPMAX)
16105           ANEG=LOG(RMNMAX/RMNMIN)
16106           APOS=LOG(RMPMAX/RMPMIN)
16107           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
16108             VCTN=VVAR*(ANEG+APOS)/ANEG
16109             CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
16110           ELSE
16111             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
16112             CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
16113           ENDIF
16114         ELSEIF(MVAR.EQ.4) THEN
16115           RMNMIN=MAX(RM34,RSQM-CTNMIN)
16116           RMNMAX=MAX(RM34,RSQM-CTNMAX)
16117           RMPMIN=MAX(RM34,RSQM-CTPMIN)
16118           RMPMAX=MAX(RM34,RSQM-CTPMAX)
16119           ANEG=1./RMNMAX-1./RMNMIN
16120           APOS=1./RMPMAX-1./RMPMIN
16121           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
16122             VCTN=VVAR*(ANEG+APOS)/ANEG
16123             CTH=RSQM-1./(1./RMNMIN+ANEG*VCTN)
16124           ELSE
16125             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
16126             CTH=RSQM-1./(1./RMPMIN+APOS*VCTP)
16127           ENDIF
16128         ELSEIF(MVAR.EQ.5) THEN
16129           RMNMIN=MAX(RM34,RSQM+CTNMIN)
16130           RMNMAX=MAX(RM34,RSQM+CTNMAX)
16131           RMPMIN=MAX(RM34,RSQM+CTPMIN)
16132           RMPMAX=MAX(RM34,RSQM+CTPMAX)
16133           ANEG=1./RMNMIN-1./RMNMAX
16134           APOS=1./RMPMIN-1./RMPMAX
16135           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
16136             VCTN=VVAR*(ANEG+APOS)/ANEG
16137             CTH=1./(1./RMNMIN-ANEG*VCTN)-RSQM
16138           ELSE
16139             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
16140             CTH=1./(1./RMPMIN-APOS*VCTP)-RSQM
16141           ENDIF
16142         ENDIF
16143         IF(CTH.LT.0.) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
16144         IF(CTH.GT.0.) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
16145         VINT(23)=CTH
16146
16147 C...Convert VVAR to tau' variable.
16148       ELSEIF(IVAR.EQ.4) THEN
16149         TAU=VINT(11)
16150         TAUPMN=VINT(16)
16151         TAUPMX=VINT(36)
16152         IF(MINT(43).EQ.1) THEN
16153           TAUP=1.
16154         ELSEIF(MVAR.EQ.1) THEN
16155           TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
16156         ELSE
16157           AUPP=(1.-TAU/TAUPMX)**4
16158           ALOW=(1.-TAU/TAUPMN)**4
16159           TAUP=TAU/(1.-(ALOW+(AUPP-ALOW)*VVAR)**0.25)
16160         ENDIF
16161         VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
16162       ENDIF
16163
16164       RETURN
16165       END
16166
16167 C***********************************************************************
16168
16169       SUBROUTINE PYSIGH(NCHN,SIGS)
16170
16171 C...Differential matrix elements for all included subprocesses.
16172 C...Note that what is coded is (disregarding the COMFAC factor)
16173 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
16174 C...when d(sigma-hat) is given in the zero-width limit, the delta
16175 C...function in tau is replaced by a Breit-Wigner:
16176 C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);
16177 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
16178 C...i.e., dimensionless quantities. COMFAC contains the factor
16179 C...pi/s and the conversion factor from GeV^-2 to mb.
16180       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16181       SAVE /LUDAT1/
16182       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
16183       SAVE /LUDAT2/
16184       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
16185       SAVE /LUDAT3/
16186       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
16187       SAVE /PYSUBS/
16188       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16189       SAVE /PYPARS/
16190       COMMON/PYINT1/MINT(400),VINT(400)
16191       SAVE /PYINT1/
16192       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
16193       SAVE /PYINT2/
16194       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
16195       SAVE /PYINT3/
16196       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
16197       SAVE /PYINT4/
16198       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
16199       SAVE /PYINT5/
16200       DIMENSION X(2),XPQ(-6:6),KFAC(2,-40:40),WDTP(0:40),WDTE(0:40,0:5)
16201
16202 C...Reset number of channels and cross-section.
16203       NCHN=0
16204       SIGS=0.
16205
16206 C...Read kinematical variables and limits.
16207       ISUB=MINT(1)
16208       TAUMIN=VINT(11)
16209       YSTMIN=VINT(12)
16210       CTNMIN=VINT(13)
16211       CTPMIN=VINT(14)
16212       XT2MIN=VINT(15)
16213       TAUPMN=VINT(16)
16214       TAU=VINT(21)
16215       YST=VINT(22)
16216       CTH=VINT(23)
16217       XT2=VINT(25)
16218       TAUP=VINT(26)
16219       TAUMAX=VINT(31)
16220       YSTMAX=VINT(32)
16221       CTNMAX=VINT(33)
16222       CTPMAX=VINT(34)
16223       XT2MAX=VINT(35)
16224       TAUPMX=VINT(36)
16225
16226 C...Derive kinematical quantities.
16227       IF(ISET(ISUB).LE.2.OR.ISET(ISUB).EQ.5) THEN
16228         X(1)=SQRT(TAU)*EXP(YST)
16229         X(2)=SQRT(TAU)*EXP(-YST)
16230       ELSE
16231         X(1)=SQRT(TAUP)*EXP(YST)
16232         X(2)=SQRT(TAUP)*EXP(-YST)
16233       ENDIF
16234       IF(MINT(43).EQ.4.AND.ISET(ISUB).GE.1.AND.
16235      &(X(1).GT.0.999.OR.X(2).GT.0.999)) RETURN
16236       SH=TAU*VINT(2)
16237       SQM3=VINT(63)
16238       SQM4=VINT(64)
16239       RM3=SQM3/SH
16240       RM4=SQM4/SH
16241       BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
16242       RPTS=4.*VINT(71)**2/SH
16243       BE34L=SQRT(MAX(0.,(1.-RM3-RM4)**2-4.*RM3*RM4-RPTS))
16244       RM34=2.*RM3*RM4
16245       RSQM=1.+RM34
16246       RTHM=(4.*RM3*RM4+RPTS)/(1.-RM3-RM4+BE34L)
16247       TH=-0.5*SH*MAX(RTHM,1.-RM3-RM4-BE34*CTH)
16248       UH=-0.5*SH*MAX(RTHM,1.-RM3-RM4+BE34*CTH)
16249       SQPTH=0.25*SH*BE34**2*(1.-CTH**2)
16250       SH2=SH**2
16251       TH2=TH**2
16252       UH2=UH**2
16253
16254 C...Choice of Q2 scale.
16255       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
16256         Q2=SH
16257       ELSEIF(MOD(ISET(ISUB),2).EQ.0.OR.ISET(ISUB).EQ.5) THEN
16258         IF(MSTP(32).EQ.1) THEN
16259           Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
16260         ELSEIF(MSTP(32).EQ.2) THEN
16261           Q2=SQPTH+0.5*(SQM3+SQM4)
16262         ELSEIF(MSTP(32).EQ.3) THEN
16263           Q2=MIN(-TH,-UH)
16264         ELSEIF(MSTP(32).EQ.4) THEN
16265           Q2=SH
16266         ENDIF
16267         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2=Q2+PARP(82)**2
16268       ENDIF
16269
16270 C...Store derived kinematical quantities.
16271       VINT(41)=X(1)
16272       VINT(42)=X(2)
16273       VINT(44)=SH
16274       VINT(43)=SQRT(SH)
16275       VINT(45)=TH
16276       VINT(46)=UH
16277       VINT(48)=SQPTH
16278       VINT(47)=SQRT(SQPTH)
16279       VINT(50)=TAUP*VINT(2)
16280       VINT(49)=SQRT(MAX(0.,VINT(50)))
16281       VINT(52)=Q2
16282       VINT(51)=SQRT(Q2)
16283
16284 C...Calculate parton structure functions.
16285       IF(ISET(ISUB).LE.0) GOTO 145
16286       IF(MINT(43).GE.2) THEN
16287         Q2SF=Q2
16288         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
16289           Q2SF=PMAS(23,1)**2
16290           IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2SF=PMAS(24,1)**2
16291         ENDIF
16292         DO 100 I=3-MINT(41),MINT(42)
16293         XSF=X(I)
16294         IF(ISET(ISUB).EQ.5) XSF=X(I)/VINT(142+I)
16295         CALL PYSTFU(MINT(10+I),XSF,Q2SF,XPQ,I)
16296         DO 100 KFL=-6,6
16297   100   XSFX(I,KFL)=XPQ(KFL)
16298       ENDIF
16299
16300 C...Calculate alpha_strong and K-factor.
16301       IF(MSTP(33).NE.3) AS=ULALPS(Q2)
16302       FACK=1.
16303       FACA=1.
16304       IF(MSTP(33).EQ.1) THEN
16305         FACK=PARP(31)
16306       ELSEIF(MSTP(33).EQ.2) THEN
16307         FACK=PARP(31)
16308         FACA=PARP(32)/PARP(31)
16309       ELSEIF(MSTP(33).EQ.3) THEN
16310         Q2AS=PARP(33)*Q2
16311         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2AS=Q2AS+
16312      &  PARU(112)*PARP(82)
16313         AS=ULALPS(Q2AS)
16314       ENDIF
16315       RADC=1.+AS/PARU(1)
16316
16317 C...Set flags for allowed reacting partons/leptons.
16318       DO 130 I=1,2
16319       DO 110 J=-40,40
16320   110 KFAC(I,J)=0
16321       IF(MINT(40+I).EQ.1) THEN
16322         KFAC(I,MINT(10+I))=1
16323       ELSE
16324         DO 120 J=-40,40
16325         KFAC(I,J)=KFIN(I,J)
16326         IF(ABS(J).GT.MSTP(54).AND.J.NE.21) KFAC(I,J)=0
16327         IF(ABS(J).LE.6) THEN
16328           IF(XSFX(I,J).LT.1.E-10) KFAC(I,J)=0
16329         ELSEIF(J.EQ.21) THEN
16330           IF(XSFX(I,0).LT.1.E-10) KFAC(I,21)=0
16331         ENDIF
16332   120   CONTINUE
16333       ENDIF
16334   130 CONTINUE
16335
16336 C...Lower and upper limit for flavour loops.
16337       MIN1=0
16338       MAX1=0
16339       MIN2=0
16340       MAX2=0
16341       DO 140 J=-20,20
16342       IF(KFAC(1,-J).EQ.1) MIN1=-J
16343       IF(KFAC(1,J).EQ.1) MAX1=J
16344       IF(KFAC(2,-J).EQ.1) MIN2=-J
16345       IF(KFAC(2,J).EQ.1) MAX2=J
16346   140 CONTINUE
16347       MINA=MIN(MIN1,MIN2)
16348       MAXA=MAX(MAX1,MAX2)
16349
16350 C...Common conversion factors (including Jacobian) for subprocesses.
16351       SQMZ=PMAS(23,1)**2
16352       GMMZ=PMAS(23,1)*PMAS(23,2)
16353       SQMW=PMAS(24,1)**2
16354       GMMW=PMAS(24,1)*PMAS(24,2)
16355       SQMH=PMAS(25,1)**2
16356       GMMH=PMAS(25,1)*PMAS(25,2)
16357       SQMZP=PMAS(32,1)**2
16358       GMMZP=PMAS(32,1)*PMAS(32,2)
16359       SQMHC=PMAS(37,1)**2
16360       GMMHC=PMAS(37,1)*PMAS(37,2)
16361       SQMR=PMAS(40,1)**2
16362       GMMR=PMAS(40,1)*PMAS(40,2)
16363       AEM=PARU(101)
16364       XW=PARU(102)
16365
16366 C...Phase space integral in tau and y*.
16367       COMFAC=PARU(1)*PARU(5)/VINT(2)
16368       IF(MINT(43).EQ.4) COMFAC=COMFAC*FACK
16369       IF((MINT(43).GE.2.OR.ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4).AND.
16370      &ISET(ISUB).NE.5) THEN
16371         ATAU0=LOG(TAUMAX/TAUMIN)
16372         ATAU1=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
16373         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/TAU
16374         IF(MINT(72).GE.1) THEN
16375           TAUR1=VINT(73)
16376           GAMR1=VINT(74)
16377           ATAU2=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
16378           ATAU3=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
16379      &    GAMR1
16380           H1=H1+(ATAU0/ATAU2)*COEF(ISUB,3)/(TAU+TAUR1)+
16381      &    (ATAU0/ATAU3)*COEF(ISUB,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
16382         ENDIF
16383         IF(MINT(72).EQ.2) THEN
16384           TAUR2=VINT(75)
16385           GAMR2=VINT(76)
16386           ATAU4=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
16387           ATAU5=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
16388      &    GAMR2
16389           H1=H1+(ATAU0/ATAU4)*COEF(ISUB,5)/(TAU+TAUR2)+
16390      &    (ATAU0/ATAU5)*COEF(ISUB,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
16391         ENDIF
16392         COMFAC=COMFAC*ATAU0/(TAU*H1)
16393       ENDIF
16394       IF(MINT(43).EQ.4.AND.ISET(ISUB).NE.5) THEN
16395         AYST0=YSTMAX-YSTMIN
16396         AYST1=0.5*(YSTMAX-YSTMIN)**2
16397         AYST2=AYST1
16398         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16399         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST2)*
16400      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
16401         COMFAC=COMFAC*AYST0/H2
16402       ENDIF
16403
16404 C...2 -> 1 processes: reduction in angular part of phase space integral
16405 C...for case of decaying resonance.
16406       ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
16407       IF((ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3).AND.
16408      &MDCY(KFPR(ISUB,1),1).EQ.1) THEN
16409         IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN
16410           COMFAC=COMFAC*0.5*ACTH0
16411         ELSE
16412           COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+
16413      &    CTPMAX**3-CTPMIN**3)
16414         ENDIF
16415
16416 C...2 -> 2 processes: angular part of phase space integral.
16417       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
16418         ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
16419      &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
16420         ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
16421      &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
16422         ACTH3=1./MAX(RM34,RSQM-CTNMAX)-1./MAX(RM34,RSQM-CTNMIN)+
16423      &  1./MAX(RM34,RSQM-CTPMAX)-1./MAX(RM34,RSQM-CTPMIN)
16424         ACTH4=1./MAX(RM34,RSQM+CTNMIN)-1./MAX(RM34,RSQM+CTNMAX)+
16425      &  1./MAX(RM34,RSQM+CTPMIN)-1./MAX(RM34,RSQM+CTPMAX)
16426         H3=COEF(ISUB,10)+
16427      &  (ACTH0/ACTH1)*COEF(ISUB,11)/MAX(RM34,RSQM-CTH)+
16428      &  (ACTH0/ACTH2)*COEF(ISUB,12)/MAX(RM34,RSQM+CTH)+
16429      &  (ACTH0/ACTH3)*COEF(ISUB,13)/MAX(RM34,RSQM-CTH)**2+
16430      &  (ACTH0/ACTH4)*COEF(ISUB,14)/MAX(RM34,RSQM+CTH)**2
16431         COMFAC=COMFAC*ACTH0*0.5*BE34/H3
16432       ENDIF
16433
16434 C...2 -> 3, 4 processes: phace space integral in tau'.
16435       IF(MINT(43).GE.2.AND.(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4)) THEN
16436         ATAUP0=LOG(TAUPMX/TAUPMN)
16437         ATAUP1=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
16438         H4=COEF(ISUB,15)+
16439      &  ATAUP0/ATAUP1*COEF(ISUB,16)/TAUP*(1.-TAU/TAUP)**3
16440         IF(1.-TAU/TAUP.GT.1.E-4) THEN
16441           FZW=(1.+TAU/TAUP)*LOG(TAUP/TAU)-2.*(1.-TAU/TAUP)
16442         ELSE
16443           FZW=1./6.*(1.-TAU/TAUP)**3*TAU/TAUP
16444         ENDIF
16445         COMFAC=COMFAC*ATAUP0*FZW/H4
16446       ENDIF
16447
16448 C...Phase space integral for low-pT and multiple interactions.
16449       IF(ISET(ISUB).EQ.5) THEN
16450         COMFAC=PARU(1)*PARU(5)*FACK*0.5*VINT(2)/SH2
16451         ATAU0=LOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)
16452         ATAU1=2.*ATAN(1./XT2-1.)/SQRT(XT2)
16453         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/SQRT(TAU)
16454         COMFAC=COMFAC*ATAU0/H1
16455         AYST0=YSTMAX-YSTMIN
16456         AYST1=0.5*(YSTMAX-YSTMIN)**2
16457         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16458         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST1)*
16459      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
16460         COMFAC=COMFAC*AYST0/H2
16461         IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1./VINT(149)-1.)
16462 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16463 C...introduced to make cross-section finite for xT2 -> 0.
16464         IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
16465      &  (1.+VINT(149)))
16466       ENDIF
16467
16468 C...A: 2 -> 1, tree diagrams.
16469
16470   145 IF(ISUB.LE.10) THEN
16471       IF(ISUB.EQ.1) THEN
16472 C...f + fb -> gamma*/Z0.
16473         MINT(61)=2
16474         CALL PYWIDT(23,SQRT(SH),WDTP,WDTE)
16475         FACZ=COMFAC*AEM**2*4./3.
16476         DO 150 I=MINA,MAXA
16477         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
16478         EI=KCHG(IABS(I),1)/3.
16479         AI=SIGN(1.,EI)
16480         VI=AI-4.*EI*XW
16481         FACF=1.
16482         IF(IABS(I).LE.10) FACF=FACA/3.
16483         NCHN=NCHN+1
16484         ISIG(NCHN,1)=I
16485         ISIG(NCHN,2)=-I
16486         ISIG(NCHN,3)=1
16487         SIGH(NCHN)=FACF*FACZ*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
16488      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+(VI**2+AI**2)/
16489      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*VINT(114))
16490   150   CONTINUE
16491
16492       ELSEIF(ISUB.EQ.2) THEN
16493 C...f + fb' -> W+/-.
16494         CALL PYWIDT(24,SQRT(SH),WDTP,WDTE)
16495         FACW=COMFAC*(AEM/XW)**2*1./24*SH2/((SH-SQMW)**2+GMMW**2)
16496         DO 170 I=MIN1,MAX1
16497         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 170
16498         IA=IABS(I)
16499         DO 160 J=MIN2,MAX2
16500         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 160
16501         JA=IABS(J)
16502         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
16503         IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) GOTO 160
16504         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16505         FACF=1.
16506         IF(IA.LE.10) FACF=VCKM((IA+1)/2,(JA+1)/2)*FACA/3.
16507         NCHN=NCHN+1
16508         ISIG(NCHN,1)=I
16509         ISIG(NCHN,2)=J
16510         ISIG(NCHN,3)=1
16511         SIGH(NCHN)=FACF*FACW*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
16512   160   CONTINUE
16513   170   CONTINUE
16514
16515       ELSEIF(ISUB.EQ.3) THEN
16516 C...f + fb -> H0.
16517         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
16518         FACH=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*
16519      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16520         DO 180 I=MINA,MAXA
16521         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
16522         RMQ=PMAS(IABS(I),1)**2/SH
16523         NCHN=NCHN+1
16524         ISIG(NCHN,1)=I
16525         ISIG(NCHN,2)=-I
16526         ISIG(NCHN,3)=1
16527         SIGH(NCHN)=FACH*RMQ*SQRT(MAX(0.,1.-4.*RMQ))
16528   180   CONTINUE
16529
16530       ELSEIF(ISUB.EQ.4) THEN
16531 C...gamma + W+/- -> W+/-.
16532
16533       ELSEIF(ISUB.EQ.5) THEN
16534 C...Z0 + Z0 -> H0.
16535         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
16536         FACH=COMFAC*1./(128.*PARU(1)**2*16.*(1.-XW)**3)*(AEM/XW)**4*
16537      &  (SH/SQMW)**2*SH2/((SH-SQMH)**2+GMMH**2)*
16538      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16539         DO 200 I=MIN1,MAX1
16540         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
16541         DO 190 J=MIN2,MAX2
16542         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
16543         EI=KCHG(IABS(I),1)/3.
16544         AI=SIGN(1.,EI)
16545         VI=AI-4.*EI*XW
16546         EJ=KCHG(IABS(J),1)/3.
16547         AJ=SIGN(1.,EJ)
16548         VJ=AJ-4.*EJ*XW
16549         NCHN=NCHN+1
16550         ISIG(NCHN,1)=I
16551         ISIG(NCHN,2)=J
16552         ISIG(NCHN,3)=1
16553         SIGH(NCHN)=FACH*(VI**2+AI**2)*(VJ**2+AJ**2)
16554   190   CONTINUE
16555   200   CONTINUE
16556
16557       ELSEIF(ISUB.EQ.6) THEN
16558 C...Z0 + W+/- -> W+/-.
16559
16560       ELSEIF(ISUB.EQ.7) THEN
16561 C...W+ + W- -> Z0.
16562
16563       ELSEIF(ISUB.EQ.8) THEN
16564 C...W+ + W- -> H0.
16565         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
16566         FACH=COMFAC*1./(128*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
16567      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16568         DO 220 I=MIN1,MAX1
16569         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 220
16570         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
16571         DO 210 J=MIN2,MAX2
16572         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 210
16573         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
16574         IF(EI*EJ.GT.0.) GOTO 210
16575         NCHN=NCHN+1
16576         ISIG(NCHN,1)=I
16577         ISIG(NCHN,2)=J
16578         ISIG(NCHN,3)=1
16579         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
16580   210   CONTINUE
16581   220   CONTINUE
16582       ENDIF
16583
16584 C...B: 2 -> 2, tree diagrams.
16585
16586       ELSEIF(ISUB.LE.20) THEN
16587       IF(ISUB.EQ.11) THEN
16588 C...f + f' -> f + f'.
16589         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
16590         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
16591      &  MSTP(34)*2./3.*UH2/(SH*TH))
16592         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
16593      &  MSTP(34)*2./3.*SH2/(TH*UH))
16594         DO 240 I=MIN1,MAX1
16595         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
16596         DO 230 J=MIN2,MAX2
16597         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
16598         NCHN=NCHN+1
16599         ISIG(NCHN,1)=I
16600         ISIG(NCHN,2)=J
16601         ISIG(NCHN,3)=1
16602         SIGH(NCHN)=FACQQ1
16603         IF(I.EQ.-J) SIGH(NCHN)=FACQQB
16604         IF(I.EQ.J) THEN
16605           SIGH(NCHN)=0.5*SIGH(NCHN)
16606           NCHN=NCHN+1
16607           ISIG(NCHN,1)=I
16608           ISIG(NCHN,2)=J
16609           ISIG(NCHN,3)=2
16610           SIGH(NCHN)=0.5*FACQQ2
16611         ENDIF
16612   230   CONTINUE
16613   240   CONTINUE
16614
16615       ELSEIF(ISUB.EQ.12) THEN
16616 C...f + fb -> f' + fb' (q + qb -> q' + qb' only).
16617         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)
16618         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
16619      &  WDTE(0,3)+WDTE(0,4))
16620         DO 250 I=MINA,MAXA
16621         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 250
16622         NCHN=NCHN+1
16623         ISIG(NCHN,1)=I
16624         ISIG(NCHN,2)=-I
16625         ISIG(NCHN,3)=1
16626         SIGH(NCHN)=FACQQB
16627   250   CONTINUE
16628
16629       ELSEIF(ISUB.EQ.13) THEN
16630 C...f + fb -> g + g (q + qb -> g + g only).
16631         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
16632         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
16633         DO 260 I=MINA,MAXA
16634         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
16635         NCHN=NCHN+1
16636         ISIG(NCHN,1)=I
16637         ISIG(NCHN,2)=-I
16638         ISIG(NCHN,3)=1
16639         SIGH(NCHN)=0.5*FACGG1
16640         NCHN=NCHN+1
16641         ISIG(NCHN,1)=I
16642         ISIG(NCHN,2)=-I
16643         ISIG(NCHN,3)=2
16644         SIGH(NCHN)=0.5*FACGG2
16645   260   CONTINUE
16646
16647       ELSEIF(ISUB.EQ.14) THEN
16648 C...f + fb -> g + gamma (q + qb -> g + gamma only).
16649         FACGG=COMFAC*AS*AEM*8./9.*(TH2+UH2)/(TH*UH)
16650         DO 270 I=MINA,MAXA
16651         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
16652         EI=KCHG(IABS(I),1)/3.
16653         NCHN=NCHN+1
16654         ISIG(NCHN,1)=I
16655         ISIG(NCHN,2)=-I
16656         ISIG(NCHN,3)=1
16657         SIGH(NCHN)=FACGG*EI**2
16658   270   CONTINUE
16659
16660       ELSEIF(ISUB.EQ.15) THEN
16661 C...f + fb -> g + Z0 (q + qb -> g + Z0 only).
16662         FACZG=COMFAC*AS*AEM/(XW*(1.-XW))*1./18.*
16663      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)
16664         FACZG=FACZG*WIDS(23,2)
16665         DO 280 I=MINA,MAXA
16666         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
16667         EI=KCHG(IABS(I),1)/3.
16668         AI=SIGN(1.,EI)
16669         VI=AI-4.*EI*XW
16670         NCHN=NCHN+1
16671         ISIG(NCHN,1)=I
16672         ISIG(NCHN,2)=-I
16673         ISIG(NCHN,3)=1
16674         SIGH(NCHN)=FACZG*(VI**2+AI**2)
16675   280   CONTINUE
16676
16677       ELSEIF(ISUB.EQ.16) THEN
16678 C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only).
16679         FACWG=COMFAC*AS*AEM/XW*2./9.*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
16680         DO 300 I=MIN1,MAX1
16681         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
16682         IA=IABS(I)
16683         DO 290 J=MIN2,MAX2
16684         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
16685         JA=IABS(J)
16686         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
16687         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16688         FCKM=1.
16689         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16690         NCHN=NCHN+1
16691         ISIG(NCHN,1)=I
16692         ISIG(NCHN,2)=J
16693         ISIG(NCHN,3)=1
16694         SIGH(NCHN)=FACWG*FCKM*WIDS(24,(5-KCHW)/2)
16695   290   CONTINUE
16696   300   CONTINUE
16697
16698       ELSEIF(ISUB.EQ.17) THEN
16699 C...f + fb -> g + H0 (q + qb -> g + H0 only).
16700
16701       ELSEIF(ISUB.EQ.18) THEN
16702 C...f + fb -> gamma + gamma.
16703         FACGG=COMFAC*FACA*AEM**2*1./3.*(TH2+UH2)/(TH*UH)
16704         DO 310 I=MINA,MAXA
16705         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
16706         EI=KCHG(IABS(I),1)/3.
16707         NCHN=NCHN+1
16708         ISIG(NCHN,1)=I
16709         ISIG(NCHN,2)=-I
16710         ISIG(NCHN,3)=1
16711         SIGH(NCHN)=FACGG*EI**4
16712   310   CONTINUE
16713
16714       ELSEIF(ISUB.EQ.19) THEN
16715 C...f + fb -> gamma + Z0.
16716         FACGZ=COMFAC*FACA*AEM**2/(XW*(1.-XW))*1./24.*
16717      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)
16718         FACGZ=FACGZ*WIDS(23,2)
16719         DO 320 I=MINA,MAXA
16720         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
16721         EI=KCHG(IABS(I),1)/3.
16722         AI=SIGN(1.,EI)
16723         VI=AI-4.*EI*XW
16724         NCHN=NCHN+1
16725         ISIG(NCHN,1)=I
16726         ISIG(NCHN,2)=-I
16727         ISIG(NCHN,3)=1
16728         SIGH(NCHN)=FACGZ*EI**2*(VI**2+AI**2)
16729   320   CONTINUE
16730
16731       ELSEIF(ISUB.EQ.20) THEN
16732 C...f + fb' -> gamma + W+/-.
16733         FACGW=COMFAC*FACA*AEM**2/XW*1./6.*
16734      &  ((2.*UH-TH)/(3.*(SH-SQM4)))**2*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
16735         DO 340 I=MIN1,MAX1
16736         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
16737         IA=IABS(I)
16738         DO 330 J=MIN2,MAX2
16739         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
16740         JA=IABS(J)
16741         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 330
16742         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16743         FCKM=1.
16744         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16745         NCHN=NCHN+1
16746         ISIG(NCHN,1)=I
16747         ISIG(NCHN,2)=J
16748         ISIG(NCHN,3)=1
16749         SIGH(NCHN)=FACGW*FCKM*WIDS(24,(5-KCHW)/2)
16750   330   CONTINUE
16751   340   CONTINUE
16752       ENDIF
16753
16754       ELSEIF(ISUB.LE.30) THEN
16755       IF(ISUB.EQ.21) THEN
16756 C...f + fb -> gamma + H0.
16757
16758       ELSEIF(ISUB.EQ.22) THEN
16759 C...f + fb -> Z0 + Z0.
16760         FACZZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./768.*
16761      &  (UH/TH+TH/UH+2.*(SQM3+SQM4)*SH/(TH*UH)-
16762      &  SQM3*SQM4*(1./TH2+1./UH2))
16763         FACZZ=FACZZ*WIDS(23,1)
16764         DO 350 I=MINA,MAXA
16765         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
16766         EI=KCHG(IABS(I),1)/3.
16767         AI=SIGN(1.,EI)
16768         VI=AI-4.*EI*XW
16769         NCHN=NCHN+1
16770         ISIG(NCHN,1)=I
16771         ISIG(NCHN,2)=-I
16772         ISIG(NCHN,3)=1
16773         SIGH(NCHN)=FACZZ*(VI**4+6.*VI**2*AI**2+AI**4)
16774   350   CONTINUE
16775
16776       ELSEIF(ISUB.EQ.23) THEN
16777 C...f + fb' -> Z0 + W+/-.
16778         FACZW=COMFAC*FACA*(AEM/XW)**2*1./6.
16779         FACZW=FACZW*WIDS(23,2)
16780         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16781         DO 370 I=MIN1,MAX1
16782         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
16783         IA=IABS(I)
16784         DO 360 J=MIN2,MAX2
16785         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
16786         JA=IABS(J)
16787         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
16788         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16789         EI=KCHG(IA,1)/3.
16790         AI=SIGN(1.,EI)
16791         VI=AI-4.*EI*XW
16792         EJ=KCHG(JA,1)/3.
16793         AJ=SIGN(1.,EJ)
16794         VJ=AJ-4.*EJ*XW
16795         IF(VI+AI.GT.0) THEN
16796           VISAV=VI
16797           AISAV=AI
16798           VI=VJ
16799           AI=AJ
16800           VJ=VISAV
16801           AJ=AISAV
16802         ENDIF
16803         FCKM=1.
16804         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16805         NCHN=NCHN+1
16806         ISIG(NCHN,1)=I
16807         ISIG(NCHN,2)=J
16808         ISIG(NCHN,3)=1
16809         SIGH(NCHN)=FACZW*FCKM*(1./(SH-SQMW)**2*
16810      &  ((9.-8.*XW)/4.*THUH+(8.*XW-6.)/4.*SH*(SQM3+SQM4))+
16811      &  (THUH-SH*(SQM3+SQM4))/(2.*(SH-SQMW))*((VJ+AJ)/TH-(VI+AI)/UH)+
16812      &  THUH/(16.*(1.-XW))*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
16813      &  SH*(SQM3+SQM4)/(8.*(1.-XW))*(VI+AI)*(VJ+AJ)/(TH*UH))*
16814      &  WIDS(24,(5-KCHW)/2)
16815   360   CONTINUE
16816   370   CONTINUE
16817
16818       ELSEIF(ISUB.EQ.24) THEN
16819 C...f + fb -> Z0 + H0.
16820         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16821         FACHZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./96.*
16822      &  (THUH+2.*SH*SQMZ)/(SH-SQMZ)**2
16823         FACHZ=FACHZ*WIDS(23,2)*WIDS(25,2)
16824         DO 380 I=MINA,MAXA
16825         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
16826         EI=KCHG(IABS(I),1)/3.
16827         AI=SIGN(1.,EI)
16828         VI=AI-4.*EI*XW
16829         NCHN=NCHN+1
16830         ISIG(NCHN,1)=I
16831         ISIG(NCHN,2)=-I
16832         ISIG(NCHN,3)=1
16833         SIGH(NCHN)=FACHZ*(VI**2+AI**2)
16834   380   CONTINUE
16835
16836       ELSEIF(ISUB.EQ.25) THEN
16837 C...f + fb -> W+ + W-.
16838         FACWW=COMFAC*FACA*(AEM/XW)**2*1./12.
16839         FACWW=FACWW*WIDS(24,1)
16840         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16841         DO 390 I=MINA,MAXA
16842         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
16843         EI=KCHG(IABS(I),1)/3.
16844         AI=SIGN(1.,EI)
16845         VI=AI-4.*EI*XW
16846         DSIGWW=THUH/SH2*(3.-(SH-3.*(SQM3+SQM4))/(SH-SQMZ)*
16847      &  (VI+AI)/(2.*AI*(1.-XW))+(SH/(SH-SQMZ))**2*
16848      &  (1.-2.*(SQM3+SQM4)/SH+12.*SQM3*SQM4/SH2)*(VI**2+AI**2)/
16849      &  (8.*(1.-XW)**2))-2.*SQMZ/(SH-SQMZ)*(VI+AI)/AI+
16850      &  SQMZ*SH/(SH-SQMZ)**2*(1.-2.*(SQM3+SQM4)/SH)*(VI**2+AI**2)/
16851      &  (2.*(1.-XW))
16852         IF(KCHG(IABS(I),1).LT.0) THEN
16853           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
16854      &    (THUH/(SH*TH)-(SQM3+SQM4)/TH)+THUH/TH2
16855         ELSE
16856           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
16857      &    (THUH/(SH*UH)-(SQM3+SQM4)/UH)+THUH/UH2
16858         ENDIF
16859         NCHN=NCHN+1
16860         ISIG(NCHN,1)=I
16861         ISIG(NCHN,2)=-I
16862         ISIG(NCHN,3)=1
16863         SIGH(NCHN)=FACWW*DSIGWW
16864   390   CONTINUE
16865
16866       ELSEIF(ISUB.EQ.26) THEN
16867 C...f + fb' -> W+/- + H0.
16868         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16869         FACHW=COMFAC*FACA*(AEM/XW)**2*1./24.*(THUH+2.*SH*SQMW)/
16870      &  (SH-SQMW)**2
16871         FACHW=FACHW*WIDS(25,2)
16872         DO 410 I=MIN1,MAX1
16873         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
16874         IA=IABS(I)
16875         DO 400 J=MIN2,MAX2
16876         IF(J.EQ.0.OR.KFAC(1,J).EQ.0) GOTO 400
16877         JA=IABS(J)
16878         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
16879         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16880         FCKM=1.
16881         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16882         NCHN=NCHN+1
16883         ISIG(NCHN,1)=I
16884         ISIG(NCHN,2)=J
16885         ISIG(NCHN,3)=1
16886         SIGH(NCHN)=FACHW*FCKM*WIDS(24,(5-KCHW)/2)
16887   400   CONTINUE
16888   410   CONTINUE
16889
16890       ELSEIF(ISUB.EQ.27) THEN
16891 C...f + fb -> H0 + H0.
16892
16893       ELSEIF(ISUB.EQ.28) THEN
16894 C...f + g -> f + g (q + g -> q + g only).
16895         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
16896      &  FACA
16897         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
16898         DO 430 I=MINA,MAXA
16899         IF(I.EQ.0) GOTO 430
16900         DO 420 ISDE=1,2
16901         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
16902         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
16903         NCHN=NCHN+1
16904         ISIG(NCHN,ISDE)=I
16905         ISIG(NCHN,3-ISDE)=21
16906         ISIG(NCHN,3)=1
16907         SIGH(NCHN)=FACQG1
16908         NCHN=NCHN+1
16909         ISIG(NCHN,ISDE)=I
16910         ISIG(NCHN,3-ISDE)=21
16911         ISIG(NCHN,3)=2
16912         SIGH(NCHN)=FACQG2
16913   420   CONTINUE
16914   430   CONTINUE
16915
16916       ELSEIF(ISUB.EQ.29) THEN
16917 C...f + g -> f + gamma (q + g -> q + gamma only).
16918         FGQ=COMFAC*FACA*AS*AEM*1./3.*(SH2+UH2)/(-SH*UH)
16919         DO 450 I=MINA,MAXA
16920         IF(I.EQ.0) GOTO 450
16921         EI=KCHG(IABS(I),1)/3.
16922         FACGQ=FGQ*EI**2
16923         DO 440 ISDE=1,2
16924         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 440
16925         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 440
16926         NCHN=NCHN+1
16927         ISIG(NCHN,ISDE)=I
16928         ISIG(NCHN,3-ISDE)=21
16929         ISIG(NCHN,3)=1
16930         SIGH(NCHN)=FACGQ
16931   440   CONTINUE
16932   450   CONTINUE
16933
16934       ELSEIF(ISUB.EQ.30) THEN
16935 C...f + g -> f + Z0 (q + g -> q + Z0 only).
16936         FZQ=COMFAC*FACA*AS*AEM/(XW*(1.-XW))*1./48.*
16937      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
16938         FZQ=FZQ*WIDS(23,2)
16939         DO 470 I=MINA,MAXA
16940         IF(I.EQ.0) GOTO 470
16941         EI=KCHG(IABS(I),1)/3.
16942         AI=SIGN(1.,EI)
16943         VI=AI-4.*EI*XW
16944         FACZQ=FZQ*(VI**2+AI**2)
16945         DO 460 ISDE=1,2
16946         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 460
16947         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 460
16948         NCHN=NCHN+1
16949         ISIG(NCHN,ISDE)=I
16950         ISIG(NCHN,3-ISDE)=21
16951         ISIG(NCHN,3)=1
16952         SIGH(NCHN)=FACZQ
16953   460   CONTINUE
16954   470   CONTINUE
16955       ENDIF
16956
16957       ELSEIF(ISUB.LE.40) THEN
16958       IF(ISUB.EQ.31) THEN
16959 C...f + g -> f' + W+/- (q + g -> q' + W+/- only).
16960         FACWQ=COMFAC*FACA*AS*AEM/XW*1./12.*
16961      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
16962         DO 490 I=MINA,MAXA
16963         IF(I.EQ.0) GOTO 490
16964         IA=IABS(I)
16965         KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
16966         DO 480 ISDE=1,2
16967         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 480
16968         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 480
16969         NCHN=NCHN+1
16970         ISIG(NCHN,ISDE)=I
16971         ISIG(NCHN,3-ISDE)=21
16972         ISIG(NCHN,3)=1
16973         SIGH(NCHN)=FACWQ*VINT(180+I)*WIDS(24,(5-KCHW)/2)
16974   480   CONTINUE
16975   490   CONTINUE
16976
16977       ELSEIF(ISUB.EQ.32) THEN
16978 C...f + g -> f + H0 (q + g -> q + H0 only).
16979
16980       ELSEIF(ISUB.EQ.33) THEN
16981 C...f + gamma -> f + g (q + gamma -> q + g only).
16982
16983       ELSEIF(ISUB.EQ.34) THEN
16984 C...f + gamma -> f + gamma.
16985
16986       ELSEIF(ISUB.EQ.35) THEN
16987 C...f + gamma -> f + Z0.
16988
16989       ELSEIF(ISUB.EQ.36) THEN
16990 C...f + gamma -> f' + W+/-.
16991
16992       ELSEIF(ISUB.EQ.37) THEN
16993 C...f + gamma -> f + H0.
16994
16995       ELSEIF(ISUB.EQ.38) THEN
16996 C...f + Z0 -> f + g (q + Z0 -> q + g only).
16997
16998       ELSEIF(ISUB.EQ.39) THEN
16999 C...f + Z0 -> f + gamma.
17000
17001       ELSEIF(ISUB.EQ.40) THEN
17002 C...f + Z0 -> f + Z0.
17003       ENDIF
17004
17005       ELSEIF(ISUB.LE.50) THEN
17006       IF(ISUB.EQ.41) THEN
17007 C...f + Z0 -> f' + W+/-.
17008
17009       ELSEIF(ISUB.EQ.42) THEN
17010 C...f + Z0 -> f + H0.
17011
17012       ELSEIF(ISUB.EQ.43) THEN
17013 C...f + W+/- -> f' + g (q + W+/- -> q' + g only).
17014
17015       ELSEIF(ISUB.EQ.44) THEN
17016 C...f + W+/- -> f' + gamma.
17017
17018       ELSEIF(ISUB.EQ.45) THEN
17019 C...f + W+/- -> f' + Z0.
17020
17021       ELSEIF(ISUB.EQ.46) THEN
17022 C...f + W+/- -> f' + W+/-.
17023
17024       ELSEIF(ISUB.EQ.47) THEN
17025 C...f + W+/- -> f' + H0.
17026
17027       ELSEIF(ISUB.EQ.48) THEN
17028 C...f + H0 -> f + g (q + H0 -> q + g only).
17029
17030       ELSEIF(ISUB.EQ.49) THEN
17031 C...f + H0 -> f + gamma.
17032
17033       ELSEIF(ISUB.EQ.50) THEN
17034 C...f + H0 -> f + Z0.
17035       ENDIF
17036
17037       ELSEIF(ISUB.LE.60) THEN
17038       IF(ISUB.EQ.51) THEN
17039 C...f + H0 -> f' + W+/-.
17040
17041       ELSEIF(ISUB.EQ.52) THEN
17042 C...f + H0 -> f + H0.
17043
17044       ELSEIF(ISUB.EQ.53) THEN
17045 C...g + g -> f + fb (g + g -> q + qb only).
17046         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)
17047         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
17048      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17049         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
17050      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17051         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
17052         NCHN=NCHN+1
17053         ISIG(NCHN,1)=21
17054         ISIG(NCHN,2)=21
17055         ISIG(NCHN,3)=1
17056         SIGH(NCHN)=FACQQ1
17057         NCHN=NCHN+1
17058         ISIG(NCHN,1)=21
17059         ISIG(NCHN,2)=21
17060         ISIG(NCHN,3)=2
17061         SIGH(NCHN)=FACQQ2
17062   500   CONTINUE
17063
17064       ELSEIF(ISUB.EQ.54) THEN
17065 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17066
17067       ELSEIF(ISUB.EQ.55) THEN
17068 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17069
17070       ELSEIF(ISUB.EQ.56) THEN
17071 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17072
17073       ELSEIF(ISUB.EQ.57) THEN
17074 C...g + gamma -> f + fb (g + gamma -> q + qb only).
17075
17076       ELSEIF(ISUB.EQ.58) THEN
17077 C...gamma + gamma -> f + fb.
17078
17079       ELSEIF(ISUB.EQ.59) THEN
17080 C...gamma + Z0 -> f + fb.
17081
17082       ELSEIF(ISUB.EQ.60) THEN
17083 C...gamma + W+/- -> f + fb'.
17084       ENDIF
17085
17086       ELSEIF(ISUB.LE.70) THEN
17087       IF(ISUB.EQ.61) THEN
17088 C...gamma + H0 -> f + fb.
17089
17090       ELSEIF(ISUB.EQ.62) THEN
17091 C...Z0 + Z0 -> f + fb.
17092
17093       ELSEIF(ISUB.EQ.63) THEN
17094 C...Z0 + W+/- -> f + fb'.
17095
17096       ELSEIF(ISUB.EQ.64) THEN
17097 C...Z0 + H0 -> f + fb.
17098
17099       ELSEIF(ISUB.EQ.65) THEN
17100 C...W+ + W- -> f + fb.
17101
17102       ELSEIF(ISUB.EQ.66) THEN
17103 C...W+/- + H0 -> f + fb'.
17104
17105       ELSEIF(ISUB.EQ.67) THEN
17106 C...H0 + H0 -> f + fb.
17107
17108       ELSEIF(ISUB.EQ.68) THEN
17109 C...g + g -> g + g.
17110         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
17111      &  TH2/SH2)*FACA
17112         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
17113      &  SH2/UH2)*FACA
17114         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
17115         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
17116         NCHN=NCHN+1
17117         ISIG(NCHN,1)=21
17118         ISIG(NCHN,2)=21
17119         ISIG(NCHN,3)=1
17120         SIGH(NCHN)=0.5*FACGG1
17121         NCHN=NCHN+1
17122         ISIG(NCHN,1)=21
17123         ISIG(NCHN,2)=21
17124         ISIG(NCHN,3)=2
17125         SIGH(NCHN)=0.5*FACGG2
17126         NCHN=NCHN+1
17127         ISIG(NCHN,1)=21
17128         ISIG(NCHN,2)=21
17129         ISIG(NCHN,3)=3
17130         SIGH(NCHN)=0.5*FACGG3
17131   510   CONTINUE
17132
17133       ELSEIF(ISUB.EQ.69) THEN
17134 C...gamma + gamma -> W+ + W-.
17135
17136       ELSEIF(ISUB.EQ.70) THEN
17137 C...gamma + W+/- -> gamma + W+/-.
17138       ENDIF
17139
17140       ELSEIF(ISUB.LE.80) THEN
17141       IF(ISUB.EQ.71) THEN
17142 C...Z0 + Z0 -> Z0 + Z0.
17143         BE2=1.-4.*SQMZ/SH
17144         TH=-0.5*SH*BE2*(1.-CTH)
17145         UH=-0.5*SH*BE2*(1.+CTH)
17146         SHANG=1./(1.-XW)*SQMW/SQMZ*(1.+BE2)**2
17147         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17148         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17149         THANG=1./(1.-XW)*SQMW/SQMZ*(BE2-CTH)**2
17150         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17151         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17152         UHANG=1./(1.-XW)*SQMW/SQMZ*(BE2+CTH)**2
17153         AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
17154         AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
17155         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*
17156      &  (AEM/XW)**4*(SH/SQMW)**2*((ASHRE+ATHRE+AUHRE)**2+
17157      &  (ASHIM+ATHIM+AUHIM)**2)*SQMZ/SQMW
17158         DO 530 I=MIN1,MAX1
17159         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
17160         EI=KCHG(IABS(I),1)/3.
17161         AI=SIGN(1.,EI)
17162         VI=AI-4.*EI*XW
17163         AVI=AI**2+VI**2
17164         DO 520 J=MIN2,MAX2
17165         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
17166         EJ=KCHG(IABS(J),1)/3.
17167         AJ=SIGN(1.,EJ)
17168         VJ=AJ-4.*EJ*XW
17169         AVJ=AJ**2+VJ**2
17170         NCHN=NCHN+1
17171         ISIG(NCHN,1)=I
17172         ISIG(NCHN,2)=J
17173         ISIG(NCHN,3)=1
17174         SIGH(NCHN)=FACH*AVI*AVJ
17175   520   CONTINUE
17176   530   CONTINUE
17177
17178       ELSEIF(ISUB.EQ.72) THEN
17179 C...Z0 + Z0 -> W+ + W-.
17180         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
17181         CTH2=CTH**2
17182         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
17183         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
17184         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
17185      &  (1.-2.*SQMZ/SH)
17186         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17187         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17188         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
17189      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
17190      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
17191      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
17192         ATWIM=0.
17193         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
17194      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
17195      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
17196      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
17197         AUWIM=0.
17198         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
17199         A4IM=0.
17200         FACH=COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*(AEM/XW)**4*
17201      &  (SH/SQMW)**2*((ASHRE+ATWRE+AUWRE+A4RE)**2+
17202      &  (ASHIM+ATWIM+AUWIM+A4IM)**2)*SQMZ/SQMW
17203         DO 550 I=MIN1,MAX1
17204         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 550
17205         EI=KCHG(IABS(I),1)/3.
17206         AI=SIGN(1.,EI)
17207         VI=AI-4.*EI*XW
17208         AVI=AI**2+VI**2
17209         DO 540 J=MIN2,MAX2
17210         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 540
17211         EJ=KCHG(IABS(J),1)/3.
17212         AJ=SIGN(1.,EJ)
17213         VJ=AJ-4.*EJ*XW
17214         AVJ=AJ**2+VJ**2
17215         NCHN=NCHN+1
17216         ISIG(NCHN,1)=I
17217         ISIG(NCHN,2)=J
17218         ISIG(NCHN,3)=1
17219         SIGH(NCHN)=FACH*AVI*AVJ
17220   540   CONTINUE
17221   550   CONTINUE
17222
17223       ELSEIF(ISUB.EQ.73) THEN
17224 C...Z0 + W+/- -> Z0 + W+/-.
17225         BE2=1.-2.*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
17226         EP1=1.+(SQMZ-SQMW)/SH
17227         EP2=1.-(SQMZ-SQMW)/SH
17228         TH=-0.5*SH*BE2*(1.-CTH)
17229         UH=(SQMZ-SQMW)**2/SH-0.5*SH*BE2*(1.+CTH)
17230         THANG=SQRT(SQMW/(SQMZ*(1.-XW)))*(BE2-EP1*CTH)*(BE2-EP2*CTH)
17231         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17232         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17233         ASWRE=(1.-XW)/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
17234      &  1./4.*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4.*BE2*CTH)+
17235      &  2.*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
17236      &  1./16.*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
17237         ASWIM=0.
17238         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
17239      &  (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
17240      &  (BE2+EP1*EP2*CTH)*(2.*EP2-EP2*CTH+EP1)-BE2*(EP2+EP1*CTH)**2*
17241      &  (BE2-EP2**2*CTH)-1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+
17242      &  2.*BE2*(1.-CTH))+1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
17243      &  (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
17244      &  (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
17245      &  (2.*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*(BE2-EP1**2*CTH)-
17246      &  1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2.*BE2*(1.-CTH))+
17247      &  1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
17248         AUWIM=0.
17249         A4RE=(1.-XW)/SQMZ*(EP1**2*EP2**2*(CTH**2-1.)-
17250      &  2.*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2.*BE2*EP1*EP2)
17251         A4IM=0.
17252         FACH=COMFAC*1./(4096.*PARU(1)**2*4.*(1.-XW))*(AEM/XW)**4*
17253      &  (SH/SQMW)**2*((ATHRE+ASWRE+AUWRE+A4RE)**2+
17254      &  (ATHIM+ASWIM+AUWIM+A4IM)**2)*SQRT(SQMZ/SQMW)
17255         DO 570 I=MIN1,MAX1
17256         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 570
17257         EI=KCHG(IABS(I),1)/3.
17258         AI=SIGN(1.,EI)
17259         VI=AI-4.*EI*XW
17260         AVI=AI**2+VI**2
17261         DO 560 J=MIN2,MAX2
17262         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 560
17263         EJ=KCHG(IABS(J),1)/3.
17264         AJ=SIGN(1.,EJ)
17265         VJ=AI-4.*EJ*XW
17266         AVJ=AJ**2+VJ**2
17267         NCHN=NCHN+1
17268         ISIG(NCHN,1)=I
17269         ISIG(NCHN,2)=J
17270         ISIG(NCHN,3)=1
17271         SIGH(NCHN)=FACH*(AVI*VINT(180+J)+VINT(180+I)*AVJ)
17272   560   CONTINUE
17273   570   CONTINUE
17274
17275       ELSEIF(ISUB.EQ.75) THEN
17276 C...W+ + W- -> gamma + gamma.
17277
17278       ELSEIF(ISUB.EQ.76) THEN
17279 C...W+ + W- -> Z0 + Z0.
17280         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
17281         CTH2=CTH**2
17282         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
17283         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
17284         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
17285      &  (1.-2.*SQMZ/SH)
17286         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17287         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17288         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
17289      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
17290      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
17291      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
17292         ATWIM=0.
17293         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
17294      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
17295      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
17296      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
17297         AUWIM=0.
17298         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
17299         A4IM=0.
17300         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
17301      &  ((ASHRE+ATWRE+AUWRE+A4RE)**2+(ASHIM+ATWIM+AUWIM+A4IM)**2)
17302         DO 590 I=MIN1,MAX1
17303         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 590
17304         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
17305         DO 580 J=MIN2,MAX2
17306         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 580
17307         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
17308         IF(EI*EJ.GT.0.) GOTO 580
17309         NCHN=NCHN+1
17310         ISIG(NCHN,1)=I
17311         ISIG(NCHN,2)=J
17312         ISIG(NCHN,3)=1
17313         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
17314   580   CONTINUE
17315   590   CONTINUE
17316
17317       ELSEIF(ISUB.EQ.77) THEN
17318 C...W+/- + W+/- -> W+/- + W+/-.
17319         BE2=1.-4.*SQMW/SH
17320         BE4=BE2**2
17321         CTH2=CTH**2
17322         CTH3=CTH**3
17323         TH=-0.5*SH*BE2*(1.-CTH)
17324         UH=-0.5*SH*BE2*(1.+CTH)
17325         SHANG=(1.+BE2)**2
17326         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17327         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17328         THANG=(BE2-CTH)**2
17329         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17330         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17331         SGZANG=1./SQMW*BE2*(3.-BE2)**2*CTH
17332         ASGRE=XW*SGZANG
17333         ASGIM=0.
17334         ASZRE=(1.-XW)*SH/(SH-SQMZ)*SGZANG
17335         ASZIM=0.
17336         TGZANG=1./SQMW*(BE2*(4.-2.*BE2+BE4)+BE2*(4.-10.*BE2+BE4)*CTH+
17337      &  (2.-11.*BE2+10.*BE4)*CTH2+BE2*CTH3)
17338         ATGRE=0.5*XW*SH/TH*TGZANG
17339         ATGIM=0.
17340         ATZRE=0.5*(1.-XW)*SH/(TH-SQMZ)*TGZANG
17341         ATZIM=0.
17342         A4RE=1./SQMW*(1.+2.*BE2-6.*BE2*CTH-CTH2)
17343         A4IM=0.
17344         FACH=COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
17345      &  ((ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4RE)**2+
17346      &  (ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4IM)**2)
17347         DO 610 I=MIN1,MAX1
17348         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 610
17349         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
17350         DO 600 J=MIN2,MAX2
17351         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 600
17352         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
17353         IF(EI*EJ.GT.0.) GOTO 600
17354         NCHN=NCHN+1
17355         ISIG(NCHN,1)=I
17356         ISIG(NCHN,2)=J
17357         ISIG(NCHN,3)=1
17358         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
17359   600   CONTINUE
17360   610   CONTINUE
17361
17362       ELSEIF(ISUB.EQ.78) THEN
17363 C...W+/- + H0 -> W+/- + H0.
17364
17365       ELSEIF(ISUB.EQ.79) THEN
17366 C...H0 + H0 -> H0 + H0.
17367
17368       ENDIF
17369
17370 C...C: 2 -> 2, tree diagrams with masses.
17371
17372       ELSEIF(ISUB.LE.90) THEN
17373       IF(ISUB.EQ.81) THEN
17374 C...q + qb -> Q + QB.
17375         FACQQB=COMFAC*AS**2*4./9.*(((TH-SQM3)**2+
17376      &  (UH-SQM3)**2)/SH2+2.*SQM3/SH)
17377         IF(MSTP(35).GE.1) THEN
17378           IF(MSTP(35).EQ.1) THEN
17379             ALSSG=PARP(35)
17380           ELSE
17381             MST115=MSTU(115)
17382             MSTU(115)=MSTP(36)
17383             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
17384             ALSSG=ULALPS(Q2BN)
17385             MSTU(115)=MST115
17386           ENDIF
17387           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
17388           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
17389           PARI(81)=FREPU
17390           FACQQB=FACQQB*FREPU
17391         ENDIF
17392         DO 620 I=MINA,MAXA
17393         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 620
17394         NCHN=NCHN+1
17395         ISIG(NCHN,1)=I
17396         ISIG(NCHN,2)=-I
17397         ISIG(NCHN,3)=1
17398         SIGH(NCHN)=FACQQB
17399   620   CONTINUE
17400
17401       ELSEIF(ISUB.EQ.82) THEN
17402 C...g + g -> Q + QB.
17403         FACQQ1=COMFAC*FACA*AS**2*1./6.*((UH-SQM3)/(TH-SQM3)-
17404      &  2.*(UH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(TH-SQM3)**2)
17405         FACQQ2=COMFAC*FACA*AS**2*1./6.*((TH-SQM3)/(UH-SQM3)-
17406      &  2.*(TH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(UH-SQM3)**2)
17407         IF(MSTP(35).GE.1) THEN
17408           IF(MSTP(35).EQ.1) THEN
17409             ALSSG=PARP(35)
17410           ELSE
17411             MST115=MSTU(115)
17412             MSTU(115)=MSTP(36)
17413             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
17414             ALSSG=ULALPS(Q2BN)
17415             MSTU(115)=MST115
17416           ENDIF
17417           XATTR=4.*PARU(1)*ALSSG/(3.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
17418           FATTR=XATTR/(1.-EXP(-MIN(100.,XATTR)))
17419           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
17420           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
17421           FATRE=(2.*FATTR+5.*FREPU)/7.
17422           PARI(81)=FATRE
17423           FACQQ1=FACQQ1*FATRE
17424           FACQQ2=FACQQ2*FATRE
17425         ENDIF
17426         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 630
17427         NCHN=NCHN+1
17428         ISIG(NCHN,1)=21
17429         ISIG(NCHN,2)=21
17430         ISIG(NCHN,3)=1
17431         SIGH(NCHN)=FACQQ1
17432         NCHN=NCHN+1
17433         ISIG(NCHN,1)=21
17434         ISIG(NCHN,2)=21
17435         ISIG(NCHN,3)=2
17436         SIGH(NCHN)=FACQQ2
17437   630   CONTINUE
17438
17439       ENDIF
17440
17441 C...D: Mimimum bias processes.
17442
17443       ELSEIF(ISUB.LE.100) THEN
17444       IF(ISUB.EQ.91) THEN
17445 C...Elastic scattering.
17446         SIGS=XSEC(ISUB,1)
17447
17448       ELSEIF(ISUB.EQ.92) THEN
17449 C...Single diffractive scattering.
17450         SIGS=XSEC(ISUB,1)
17451
17452       ELSEIF(ISUB.EQ.93) THEN
17453 C...Double diffractive scattering.
17454         SIGS=XSEC(ISUB,1)
17455
17456       ELSEIF(ISUB.EQ.94) THEN
17457 C...Central diffractive scattering.
17458         SIGS=XSEC(ISUB,1)
17459
17460       ELSEIF(ISUB.EQ.95) THEN
17461 C...Low-pT scattering.
17462         SIGS=XSEC(ISUB,1)
17463
17464       ELSEIF(ISUB.EQ.96) THEN
17465 C...Multiple interactions: sum of QCD processes.
17466         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)
17467
17468 C...q + q' -> q + q'.
17469         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
17470         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
17471      &  MSTP(34)*2./3.*UH2/(SH*TH))
17472         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
17473      &  MSTP(34)*2./3.*SH2/(TH*UH))
17474         DO 650 I=-3,3
17475         IF(I.EQ.0) GOTO 650
17476         DO 640 J=-3,3
17477         IF(J.EQ.0) GOTO 640
17478         NCHN=NCHN+1
17479         ISIG(NCHN,1)=I
17480         ISIG(NCHN,2)=J
17481         ISIG(NCHN,3)=111
17482         SIGH(NCHN)=FACQQ1
17483         IF(I.EQ.-J) SIGH(NCHN)=FACQQB
17484         IF(I.EQ.J) THEN
17485           SIGH(NCHN)=0.5*SIGH(NCHN)
17486           NCHN=NCHN+1
17487           ISIG(NCHN,1)=I
17488           ISIG(NCHN,2)=J
17489           ISIG(NCHN,3)=112
17490           SIGH(NCHN)=0.5*FACQQ2
17491         ENDIF
17492   640   CONTINUE
17493   650   CONTINUE
17494
17495 C...q + qb -> q' + qb' or g + g.
17496         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
17497      &  WDTE(0,3)+WDTE(0,4))
17498         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
17499         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
17500         DO 660 I=-3,3
17501         IF(I.EQ.0) GOTO 660
17502         NCHN=NCHN+1
17503         ISIG(NCHN,1)=I
17504         ISIG(NCHN,2)=-I
17505         ISIG(NCHN,3)=121
17506         SIGH(NCHN)=FACQQB
17507         NCHN=NCHN+1
17508         ISIG(NCHN,1)=I
17509         ISIG(NCHN,2)=-I
17510         ISIG(NCHN,3)=131
17511         SIGH(NCHN)=0.5*FACGG1
17512         NCHN=NCHN+1
17513         ISIG(NCHN,1)=I
17514         ISIG(NCHN,2)=-I
17515         ISIG(NCHN,3)=132
17516         SIGH(NCHN)=0.5*FACGG2
17517   660   CONTINUE
17518
17519 C...q + g -> q + g.
17520         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
17521      &  FACA
17522         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
17523         DO 680 I=-3,3
17524         IF(I.EQ.0) GOTO 680
17525         DO 670 ISDE=1,2
17526         NCHN=NCHN+1
17527         ISIG(NCHN,ISDE)=I
17528         ISIG(NCHN,3-ISDE)=21
17529         ISIG(NCHN,3)=281
17530         SIGH(NCHN)=FACQG1
17531         NCHN=NCHN+1
17532         ISIG(NCHN,ISDE)=I
17533         ISIG(NCHN,3-ISDE)=21
17534         ISIG(NCHN,3)=282
17535         SIGH(NCHN)=FACQG2
17536   670   CONTINUE
17537   680   CONTINUE
17538
17539 C...g + g -> q + qb or g + g.
17540         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
17541      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17542         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
17543      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17544         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
17545      &  TH2/SH2)*FACA
17546         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
17547      &  SH2/UH2)*FACA
17548         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
17549         NCHN=NCHN+1
17550         ISIG(NCHN,1)=21
17551         ISIG(NCHN,2)=21
17552         ISIG(NCHN,3)=531
17553         SIGH(NCHN)=FACQQ1
17554         NCHN=NCHN+1
17555         ISIG(NCHN,1)=21
17556         ISIG(NCHN,2)=21
17557         ISIG(NCHN,3)=532
17558         SIGH(NCHN)=FACQQ2
17559         NCHN=NCHN+1
17560         ISIG(NCHN,1)=21
17561         ISIG(NCHN,2)=21
17562         ISIG(NCHN,3)=681
17563         SIGH(NCHN)=0.5*FACGG1
17564         NCHN=NCHN+1
17565         ISIG(NCHN,1)=21
17566         ISIG(NCHN,2)=21
17567         ISIG(NCHN,3)=682
17568         SIGH(NCHN)=0.5*FACGG2
17569         NCHN=NCHN+1
17570         ISIG(NCHN,1)=21
17571         ISIG(NCHN,2)=21
17572         ISIG(NCHN,3)=683
17573         SIGH(NCHN)=0.5*FACGG3
17574       ENDIF
17575
17576 C...E: 2 -> 1, loop diagrams.
17577
17578       ELSEIF(ISUB.LE.110) THEN
17579       IF(ISUB.EQ.101) THEN
17580 C...g + g -> gamma*/Z0.
17581
17582       ELSEIF(ISUB.EQ.102) THEN
17583 C...g + g -> H0.
17584         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
17585         ETARE=0.
17586         ETAIM=0.
17587         DO 690 I=1,2*MSTP(1)
17588         EPS=4.*PMAS(I,1)**2/SH
17589         IF(EPS.LE.1.) THEN
17590           IF(EPS.GT.1.E-4) THEN
17591             ROOT=SQRT(1.-EPS)
17592             RLN=LOG((1.+ROOT)/(1.-ROOT))
17593           ELSE
17594             RLN=LOG(4./EPS-2.)
17595           ENDIF
17596           PHIRE=0.25*(RLN**2-PARU(1)**2)
17597           PHIIM=0.5*PARU(1)*RLN
17598         ELSE
17599           PHIRE=-(ASIN(1./SQRT(EPS)))**2
17600           PHIIM=0.
17601         ENDIF
17602         ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
17603         ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
17604   690   CONTINUE
17605         ETA2=ETARE**2+ETAIM**2
17606         FACH=COMFAC*FACA*(AS/PARU(1)*AEM/XW)**2*1./512.*
17607      &  (SH/SQMW)**2*ETA2*SH2/((SH-SQMH)**2+GMMH**2)*
17608      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
17609         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 700
17610         NCHN=NCHN+1
17611         ISIG(NCHN,1)=21
17612         ISIG(NCHN,2)=21
17613         ISIG(NCHN,3)=1
17614         SIGH(NCHN)=FACH
17615   700   CONTINUE
17616
17617       ENDIF
17618
17619 C...F: 2 -> 2, box diagrams.
17620
17621       ELSEIF(ISUB.LE.120) THEN
17622       IF(ISUB.EQ.111) THEN
17623 C...f + fb -> g + H0 (q + qb -> g + H0 only).
17624         A5STUR=0.
17625         A5STUI=0.
17626         DO 710 I=1,2*MSTP(1)
17627         SQMQ=PMAS(I,1)**2
17628         EPSS=4.*SQMQ/SH
17629         EPSH=4.*SQMQ/SQMH
17630         A5STUR=A5STUR+SQMQ/SQMH*(4.+4.*SH/(TH+UH)*(PYW1AU(EPSS,1)-
17631      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,1)-
17632      &  PYW2AU(EPSH,1)))
17633         A5STUI=A5STUI+SQMQ/SQMH*(4.*SH/(TH+UH)*(PYW1AU(EPSS,2)-
17634      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,2)-
17635      &  PYW2AU(EPSH,2)))
17636   710   CONTINUE
17637         FACGH=COMFAC*FACA/(144.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
17638      &  SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
17639         FACGH=FACGH*WIDS(25,2)
17640         DO 720 I=MINA,MAXA
17641         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 720
17642         NCHN=NCHN+1
17643         ISIG(NCHN,1)=I
17644         ISIG(NCHN,2)=-I
17645         ISIG(NCHN,3)=1
17646         SIGH(NCHN)=FACGH
17647   720   CONTINUE
17648
17649       ELSEIF(ISUB.EQ.112) THEN
17650 C...f + g -> f + H0 (q + g -> q + H0 only).
17651         A5TSUR=0.
17652         A5TSUI=0.
17653         DO 730 I=1,2*MSTP(1)
17654         SQMQ=PMAS(I,1)**2
17655         EPST=4.*SQMQ/TH
17656         EPSH=4.*SQMQ/SQMH
17657         A5TSUR=A5TSUR+SQMQ/SQMH*(4.+4.*TH/(SH+UH)*(PYW1AU(EPST,1)-
17658      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,1)-
17659      &  PYW2AU(EPSH,1)))
17660         A5TSUI=A5TSUI+SQMQ/SQMH*(4.*TH/(SH+UH)*(PYW1AU(EPST,2)-
17661      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,2)-
17662      &  PYW2AU(EPSH,2)))
17663   730   CONTINUE
17664         FACQH=COMFAC*FACA/(384.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
17665      &  SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
17666         FACQH=FACQH*WIDS(25,2)
17667         DO 750 I=MINA,MAXA
17668         IF(I.EQ.0) GOTO 750
17669         DO 740 ISDE=1,2
17670         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 740
17671         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 740
17672         NCHN=NCHN+1
17673         ISIG(NCHN,ISDE)=I
17674         ISIG(NCHN,3-ISDE)=21
17675         ISIG(NCHN,3)=1
17676         SIGH(NCHN)=FACQH
17677   740   CONTINUE
17678   750   CONTINUE
17679
17680       ELSEIF(ISUB.EQ.113) THEN
17681 C...g + g -> g + H0.
17682         A2STUR=0.
17683         A2STUI=0.
17684         A2USTR=0.
17685         A2USTI=0.
17686         A2TUSR=0.
17687         A2TUSI=0.
17688         A4STUR=0.
17689         A4STUI=0.
17690         DO 760 I=6,2*MSTP(1)
17691 C'''Only t-quarks yet included
17692         SQMQ=PMAS(I,1)**2
17693         EPSS=4.*SQMQ/SH
17694         EPST=4.*SQMQ/TH
17695         EPSU=4.*SQMQ/UH
17696         EPSH=4.*SQMQ/SQMH
17697         IF(EPSH.LT.1.E-6) GOTO 760
17698         BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
17699         BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
17700         BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
17701         BEUTS=BESTU
17702         BETSU=BEUST
17703         BESUT=BETUS
17704         W3STUR=PYI3AU(BESTU,EPSH,1)-PYI3AU(BESTU,EPSS,1)-
17705      &  PYI3AU(BESTU,EPSU,1)
17706         W3STUI=PYI3AU(BESTU,EPSH,2)-PYI3AU(BESTU,EPSS,2)-
17707      &  PYI3AU(BESTU,EPSU,2)
17708         W3SUTR=PYI3AU(BESUT,EPSH,1)-PYI3AU(BESUT,EPSS,1)-
17709      &  PYI3AU(BESUT,EPST,1)
17710         W3SUTI=PYI3AU(BESUT,EPSH,2)-PYI3AU(BESUT,EPSS,2)-
17711      &  PYI3AU(BESUT,EPST,2)
17712         W3TSUR=PYI3AU(BETSU,EPSH,1)-PYI3AU(BETSU,EPST,1)-
17713      &  PYI3AU(BETSU,EPSU,1)
17714         W3TSUI=PYI3AU(BETSU,EPSH,2)-PYI3AU(BETSU,EPST,2)-
17715      &  PYI3AU(BETSU,EPSU,2)
17716         W3TUSR=PYI3AU(BETUS,EPSH,1)-PYI3AU(BETUS,EPST,1)-
17717      &  PYI3AU(BETUS,EPSS,1)
17718         W3TUSI=PYI3AU(BETUS,EPSH,2)-PYI3AU(BETUS,EPST,2)-
17719      &  PYI3AU(BETUS,EPSS,2)
17720         W3USTR=PYI3AU(BEUST,EPSH,1)-PYI3AU(BEUST,EPSU,1)-
17721      &  PYI3AU(BEUST,EPST,1)
17722         W3USTI=PYI3AU(BEUST,EPSH,2)-PYI3AU(BEUST,EPSU,2)-
17723      &  PYI3AU(BEUST,EPST,2)
17724         W3UTSR=PYI3AU(BEUTS,EPSH,1)-PYI3AU(BEUTS,EPSU,1)-
17725      &  PYI3AU(BEUTS,EPSS,1)
17726         W3UTSI=PYI3AU(BEUTS,EPSH,2)-PYI3AU(BEUTS,EPSU,2)-
17727      &  PYI3AU(BEUTS,EPSS,2)
17728         B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2.*TH*UH*(UH+2.*SH)/
17729      &  (SH+UH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
17730      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3STUR)+
17731      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,1)-
17732      &  PYW2AU(EPSH,1))+0.5*TH*UH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
17733      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUR)
17734         B2STUI=SQMQ/SQMH**2*(2.*TH*UH*(UH+2.*SH)/(SH+UH)**2*
17735      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
17736      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3STUI)+
17737      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,2)-
17738      &  PYW2AU(EPSH,2))+0.5*TH*UH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
17739      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUI)
17740         B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2.*UH*TH*(TH+2.*SH)/
17741      &  (SH+TH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
17742      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3SUTR)+
17743      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,1)-
17744      &  PYW2AU(EPSH,1))+0.5*UH*TH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
17745      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTR)
17746         B2SUTI=SQMQ/SQMH**2*(2.*UH*TH*(TH+2.*SH)/(SH+TH)**2*
17747      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
17748      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3SUTI)+
17749      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,2)-
17750      &  PYW2AU(EPSH,2))+0.5*UH*TH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
17751      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTI)
17752         B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2.*SH*UH*(UH+2.*TH)/
17753      &  (TH+UH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
17754      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3TSUR)+
17755      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,1)-
17756      &  PYW2AU(EPSH,1))+0.5*SH*UH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
17757      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUR)
17758         B2TSUI=SQMQ/SQMH**2*(2.*SH*UH*(UH+2.*TH)/(TH+UH)**2*
17759      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
17760      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3TSUI)+
17761      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,2)-
17762      &  PYW2AU(EPSH,2))+0.5*SH*UH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
17763      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUI)
17764         B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2.*UH*SH*(SH+2.*TH)/
17765      &  (TH+SH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
17766      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3TUSR)+
17767      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,1)-
17768      &  PYW2AU(EPSH,1))+0.5*UH*SH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
17769      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSR)
17770         B2TUSI=SQMQ/SQMH**2*(2.*UH*SH*(SH+2.*TH)/(TH+SH)**2*
17771      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
17772      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3TUSI)+
17773      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,2)-
17774      &  PYW2AU(EPSH,2))+0.5*UH*SH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
17775      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSI)
17776         B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2.*SH*TH*(TH+2.*UH)/
17777      &  (UH+TH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
17778      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3USTR)+
17779      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,1)-
17780      &  PYW2AU(EPSH,1))+0.5*SH*TH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
17781      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTR)
17782         B2USTI=SQMQ/SQMH**2*(2.*SH*TH*(TH+2.*UH)/(UH+TH)**2*
17783      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
17784      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3USTI)+
17785      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,2)-
17786      &  PYW2AU(EPSH,2))+0.5*SH*TH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
17787      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTI)
17788         B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2.*TH*SH*(SH+2.*UH)/
17789      &  (UH+SH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
17790      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3UTSR)+
17791      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,1)-
17792      &  PYW2AU(EPSH,1))+0.5*TH*SH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
17793      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSR)
17794         B2UTSI=SQMQ/SQMH**2*(2.*TH*SH*(SH+2.*UH)/(UH+SH)**2*
17795      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
17796      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3UTSI)+
17797      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,2)-
17798      &  PYW2AU(EPSH,2))+0.5*TH*SH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
17799      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSI)
17800         B4STUR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,1)-
17801      &  PYW2AU(EPSH,1)+W3STUR))
17802         B4STUI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,2)-
17803      &  PYW2AU(EPSH,2)+W3STUI)
17804         B4TUSR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,1)-
17805      &  PYW2AU(EPSH,1)+W3TUSR))
17806         B4TUSI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,2)-
17807      &  PYW2AU(EPSH,2)+W3TUSI)
17808         B4USTR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,1)-
17809      &  PYW2AU(EPSH,1)+W3USTR))
17810         B4USTI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,2)-
17811      &  PYW2AU(EPSH,2)+W3USTI)
17812         A2STUR=A2STUR+B2STUR+B2SUTR
17813         A2STUI=A2STUI+B2STUI+B2SUTI
17814         A2USTR=A2USTR+B2USTR+B2UTSR
17815         A2USTI=A2USTI+B2USTI+B2UTSI
17816         A2TUSR=A2TUSR+B2TUSR+B2TSUR
17817         A2TUSI=A2TUSI+B2TUSI+B2TSUI
17818         A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
17819         A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
17820   760   CONTINUE
17821         FACGH=COMFAC*FACA*3./(128.*PARU(1)**2)*AEM/XW*AS**3*
17822      &  SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
17823      &  A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
17824         FACGH=FACGH*WIDS(25,2)
17825         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 770
17826         NCHN=NCHN+1
17827         ISIG(NCHN,1)=21
17828         ISIG(NCHN,2)=21
17829         ISIG(NCHN,3)=1
17830         SIGH(NCHN)=FACGH
17831   770   CONTINUE
17832
17833       ELSEIF(ISUB.EQ.114) THEN
17834 C...g + g -> gamma + gamma.
17835         ASRE=0.
17836         ASIM=0.
17837         DO 780 I=1,2*MSTP(1)
17838         EI=KCHG(IABS(I),1)/3.
17839         SQMQ=PMAS(I,1)**2
17840         EPSS=4.*SQMQ/SH
17841         EPST=4.*SQMQ/TH
17842         EPSU=4.*SQMQ/UH
17843         IF(EPSS+ABS(EPST)+ABS(EPSU).LT.3.E-6) THEN
17844           A0STUR=1.+(TH-UH)/SH*LOG(TH/UH)+0.5*(TH2+UH2)/SH2*
17845      &    (LOG(TH/UH)**2+PARU(1)**2)
17846           A0STUI=0.
17847           A0TSUR=1.+(SH-UH)/TH*LOG(-SH/UH)+0.5*(SH2+UH2)/TH2*
17848      &    LOG(-SH/UH)**2
17849           A0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*LOG(-SH/UH))
17850           A0UTSR=1.+(TH-SH)/UH*LOG(-TH/SH)+0.5*(TH2+SH2)/UH2*
17851      &    LOG(-TH/SH)**2
17852           A0UTSI=PARU(1)*((TH-SH)/UH+(TH2+SH2)/UH2*LOG(-TH/SH))
17853           A1STUR=-1.
17854           A1STUI=0.
17855           A2STUR=-1.
17856           A2STUI=0.
17857         ELSE
17858           BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
17859           BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
17860           BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
17861           BEUTS=BESTU
17862           BETSU=BEUST
17863           BESUT=BETUS
17864           A0STUR=1.+(1.+2.*TH/SH)*PYW1AU(EPST,1)+(1.+2.*UH/SH)*
17865      &    PYW1AU(EPSU,1)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,1)+
17866      &    PYW2AU(EPSU,1))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,1)+
17867      &    PYI3AU(BESUT,EPST,1))-0.25*EPSU*(1.-0.5*EPSS)*
17868      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))+
17869      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
17870      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))
17871           A0STUI=(1.+2.*TH/SH)*PYW1AU(EPST,2)+(1.+2.*UH/SH)*
17872      &    PYW1AU(EPSU,2)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,2)+
17873      &    PYW2AU(EPSU,2))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,2)+
17874      &    PYI3AU(BESUT,EPST,2))-0.25*EPSU*(1.-0.5*EPSS)*
17875      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))+
17876      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
17877      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))
17878           A0TSUR=1.+(1.+2.*SH/TH)*PYW1AU(EPSS,1)+(1.+2.*UH/TH)*
17879      &    PYW1AU(EPSU,1)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,1)+
17880      &    PYW2AU(EPSU,1))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,1)+
17881      &    PYI3AU(BETUS,EPSS,1))-0.25*EPSU*(1.-0.5*EPST)*
17882      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))+
17883      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
17884      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))
17885           A0TSUI=(1.+2.*SH/TH)*PYW1AU(EPSS,2)+(1.+2.*UH/TH)*
17886      &    PYW1AU(EPSU,2)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,2)+
17887      &    PYW2AU(EPSU,2))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,2)+
17888      &    PYI3AU(BETUS,EPSS,2))-0.25*EPSU*(1.-0.5*EPST)*
17889      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))+
17890      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
17891      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))
17892           A0UTSR=1.+(1.+2.*TH/UH)*PYW1AU(EPST,1)+(1.+2.*SH/UH)*
17893      &    PYW1AU(EPSS,1)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,1)+
17894      &    PYW2AU(EPSS,1))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,1)+
17895      &    PYI3AU(BEUST,EPST,1))-0.25*EPSS*(1.-0.5*EPSU)*
17896      &    (PYI3AU(BEUTS,EPSU,1)+PYI3AU(BEUTS,EPSS,1))+
17897      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
17898      &    (PYI3AU(BETUS,EPST,1)+PYI3AU(BETUS,EPSS,1))
17899           A0UTSI=(1.+2.*TH/UH)*PYW1AU(EPST,2)+(1.+2.*SH/UH)*
17900      &    PYW1AU(EPSS,2)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,2)+
17901      &    PYW2AU(EPSS,2))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,2)+
17902      &    PYI3AU(BEUST,EPST,2))-0.25*EPSS*(1.-0.5*EPSU)*
17903      &    (PYI3AU(BEUTS,EPSU,2)+PYI3AU(BEUTS,EPSS,2))+
17904      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
17905      &    (PYI3AU(BETUS,EPST,2)+PYI3AU(BETUS,EPSS,2))
17906           A1STUR=-1.-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,1)+
17907      &    PYW2AU(EPST,1)+PYW2AU(EPSU,1))+0.25*(EPSU+0.5*EPSS*EPST)*
17908      &    (PYI3AU(BESUT,EPSS,1)+PYI3AU(BESUT,EPST,1))+
17909      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,1)+
17910      &    PYI3AU(BESTU,EPSU,1))+0.25*(EPSS+0.5*EPST*EPSU)*
17911      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))
17912           A1STUI=-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,2)+PYW2AU(EPST,2)+
17913      &    PYW2AU(EPSU,2))+0.25*(EPSU+0.5*EPSS*EPST)*
17914      &    (PYI3AU(BESUT,EPSS,2)+PYI3AU(BESUT,EPST,2))+
17915      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,2)+
17916      &    PYI3AU(BESTU,EPSU,2))+0.25*(EPSS+0.5*EPST*EPSU)*
17917      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))
17918           A2STUR=-1.+0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,1)+
17919      &    PYI3AU(BESUT,EPST,1))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,1)+
17920      &    PYI3AU(BESTU,EPSU,1))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,1)+
17921      &    PYI3AU(BETSU,EPSU,1))
17922           A2STUI=0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,2)+
17923      &    PYI3AU(BESUT,EPST,2))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,2)+
17924      &    PYI3AU(BESTU,EPSU,2))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,2)+
17925      &    PYI3AU(BETSU,EPSU,2))
17926         ENDIF
17927         ASRE=ASRE+EI**2*(A0STUR+A0TSUR+A0UTSR+4.*A1STUR+A2STUR)
17928         ASIM=ASIM+EI**2*(A0STUI+A0TSUI+A0UTSI+4.*A1STUI+A2STUI)
17929   780   CONTINUE
17930         FACGG=COMFAC*FACA/(8.*PARU(1)**2)*AS**2*AEM**2*(ASRE**2+ASIM**2)
17931         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 790
17932         NCHN=NCHN+1
17933         ISIG(NCHN,1)=21
17934         ISIG(NCHN,2)=21
17935         ISIG(NCHN,3)=1
17936         SIGH(NCHN)=FACGG
17937   790   CONTINUE
17938
17939       ELSEIF(ISUB.EQ.115) THEN
17940 C...g + g -> gamma + Z0.
17941
17942       ELSEIF(ISUB.EQ.116) THEN
17943 C...g + g -> Z0 + Z0.
17944
17945       ELSEIF(ISUB.EQ.117) THEN
17946 C...g + g -> W+ + W-.
17947
17948       ENDIF
17949
17950 C...G: 2 -> 3, tree diagrams.
17951
17952       ELSEIF(ISUB.LE.140) THEN
17953       IF(ISUB.EQ.121) THEN
17954 C...g + g -> f + fb + H0.
17955
17956       ENDIF
17957
17958 C...H: 2 -> 1, tree diagrams, non-standard model processes.
17959
17960       ELSEIF(ISUB.LE.160) THEN
17961       IF(ISUB.EQ.141) THEN
17962 C...f + fb -> gamma*/Z0/Z'0.
17963         MINT(61)=2
17964         CALL PYWIDT(32,SQRT(SH),WDTP,WDTE)
17965         FACZP=COMFAC*AEM**2*4./9.
17966         DO 800 I=MINA,MAXA
17967         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 800
17968         EI=KCHG(IABS(I),1)/3.
17969         AI=SIGN(1.,EI)
17970         VI=AI-4.*EI*XW
17971         API=SIGN(1.,EI)
17972         VPI=API-4.*EI*XW
17973         NCHN=NCHN+1
17974         ISIG(NCHN,1)=I
17975         ISIG(NCHN,2)=-I
17976         ISIG(NCHN,3)=1
17977         SIGH(NCHN)=FACZP*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
17978      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+EI*VPI/(8.*XW*
17979      &  (1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GMMZP**2)*VINT(113)+
17980      &  (VI**2+AI**2)/(16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*
17981      &  VINT(114)+2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*SH2*
17982      &  ((SH-SQMZ)*(SH-SQMZP)+GMMZ*GMMZP)/(((SH-SQMZ)**2+GMMZ**2)*
17983      &  ((SH-SQMZP)**2+GMMZP**2))*VINT(115)+(VPI**2+API**2)/
17984      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZP)**2+GMMZP**2)*VINT(116))
17985   800   CONTINUE
17986
17987       ELSEIF(ISUB.EQ.142) THEN
17988 C...f + fb' -> H+/-.
17989         CALL PYWIDT(37,SQRT(SH),WDTP,WDTE)
17990         FHC=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/
17991      &  ((SH-SQMHC)**2+GMMHC**2)
17992 C'''No construction yet for leptons
17993         DO 840 I=1,MSTP(54)/2
17994         IL=2*I-1
17995         IU=2*I
17996         RMQL=PMAS(IL,1)**2/SH
17997         RMQU=PMAS(IU,1)**2/SH
17998         FACHC=FHC*((RMQL*PARU(121)+RMQU/PARU(121))*(1.-RMQL-RMQU)-
17999      &  4.*RMQL*RMQU)/SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))
18000         IF(KFAC(1,IL)*KFAC(2,-IU).EQ.0) GOTO 810
18001         KCHHC=(KCHG(IL,1)-KCHG(IU,1))/3
18002         NCHN=NCHN+1
18003         ISIG(NCHN,1)=IL
18004         ISIG(NCHN,2)=-IU
18005         ISIG(NCHN,3)=1
18006         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18007   810   IF(KFAC(1,-IL)*KFAC(2,IU).EQ.0) GOTO 820
18008         KCHHC=(-KCHG(IL,1)+KCHG(IU,1))/3
18009         NCHN=NCHN+1
18010         ISIG(NCHN,1)=-IL
18011         ISIG(NCHN,2)=IU
18012         ISIG(NCHN,3)=1
18013         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18014   820   IF(KFAC(1,IU)*KFAC(2,-IL).EQ.0) GOTO 830
18015         KCHHC=(KCHG(IU,1)-KCHG(IL,1))/3
18016         NCHN=NCHN+1
18017         ISIG(NCHN,1)=IU
18018         ISIG(NCHN,2)=-IL
18019         ISIG(NCHN,3)=1
18020         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18021   830   IF(KFAC(1,-IU)*KFAC(2,IL).EQ.0) GOTO 840
18022         KCHHC=(-KCHG(IU,1)+KCHG(IL,1))/3
18023         NCHN=NCHN+1
18024         ISIG(NCHN,1)=-IU
18025         ISIG(NCHN,2)=IL
18026         ISIG(NCHN,3)=1
18027         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18028   840   CONTINUE
18029
18030       ELSEIF(ISUB.EQ.143) THEN
18031 C...f + fb -> R.
18032         CALL PYWIDT(40,SQRT(SH),WDTP,WDTE)
18033         FACR=COMFAC*(AEM/XW)**2*1./9.*SH2/((SH-SQMR)**2+GMMR**2)
18034         DO 860 I=MIN1,MAX1
18035         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
18036         IA=IABS(I)
18037         DO 850 J=MIN2,MAX2
18038         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
18039         JA=IABS(J)
18040         IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 850
18041         NCHN=NCHN+1
18042         ISIG(NCHN,1)=I
18043         ISIG(NCHN,2)=J
18044         ISIG(NCHN,3)=1
18045         SIGH(NCHN)=FACR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
18046   850   CONTINUE
18047   860   CONTINUE
18048
18049       ENDIF
18050
18051 C...I: 2 -> 2, tree diagrams, non-standard model processes.
18052
18053       ELSE
18054       IF(ISUB.EQ.161) THEN
18055 C...f + g -> f' + H+/- (q + g -> q' + H+/- only).
18056         FHCQ=COMFAC*FACA*AS*AEM/XW*1./24
18057         DO 900 I=1,MSTP(54)
18058         IU=I+MOD(I,2)
18059         SQMQ=PMAS(IU,1)**2
18060         FACHCQ=FHCQ/PARU(121)*SQMQ/SQMW*(SH/(SQMQ-UH)+
18061      &  2.*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
18062      &  2.*SQMQ/(SQMQ-UH)+2.*(SQMHC-UH)/(SQMQ-UH)*(SQMHC-SQMQ-SH)/SH)
18063         IF(KFAC(1,-I)*KFAC(2,21).EQ.0) GOTO 870
18064         KCHHC=ISIGN(1,-KCHG(I,1))
18065         NCHN=NCHN+1
18066         ISIG(NCHN,1)=-I
18067         ISIG(NCHN,2)=21
18068         ISIG(NCHN,3)=1
18069         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18070   870   IF(KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 880
18071         KCHHC=ISIGN(1,KCHG(I,1))
18072         NCHN=NCHN+1
18073         ISIG(NCHN,1)=I
18074         ISIG(NCHN,2)=21
18075         ISIG(NCHN,3)=1
18076         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18077   880   IF(KFAC(1,21)*KFAC(2,-I).EQ.0) GOTO 890
18078         KCHHC=ISIGN(1,-KCHG(I,1))
18079         NCHN=NCHN+1
18080         ISIG(NCHN,1)=21
18081         ISIG(NCHN,2)=-I
18082         ISIG(NCHN,3)=1
18083         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18084   890   IF(KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 900
18085         KCHHC=ISIGN(1,KCHG(I,1))
18086         NCHN=NCHN+1
18087         ISIG(NCHN,1)=21
18088         ISIG(NCHN,2)=I
18089         ISIG(NCHN,3)=1
18090         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
18091   900   CONTINUE
18092
18093       ENDIF
18094       ENDIF
18095
18096 C...Multiply with structure functions.
18097       IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
18098         DO 910 ICHN=1,NCHN
18099         IF(MINT(41).EQ.2) THEN
18100           KFL1=ISIG(ICHN,1)
18101           IF(KFL1.EQ.21) KFL1=0
18102           SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
18103         ENDIF
18104         IF(MINT(42).EQ.2) THEN
18105           KFL2=ISIG(ICHN,2)
18106           IF(KFL2.EQ.21) KFL2=0
18107           SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
18108         ENDIF
18109   910   SIGS=SIGS+SIGH(ICHN)
18110       ENDIF
18111
18112       RETURN
18113       END
18114
18115 C*********************************************************************
18116
18117       SUBROUTINE PYSTFU(KF,X,Q2,XPQ,JBT)
18118
18119 C                       *******JBT specifies beam or target of the particle
18120 C...Gives proton and pi+ parton structure functions according to a few
18121 C...different parametrizations. Note that what is coded is x times the
18122 C...probability distribution, i.e. xq(x,Q2) etc.
18123       COMMON/HIPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
18124       SAVE  /HIPARNT/
18125       COMMON/HIJCRDN/YP(3,300),YT(3,300)
18126       SAVE  /HIJCRDN/
18127 C                       ********COMMON BLOCK FROM HIJING
18128       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18129       SAVE /LUDAT1/
18130       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
18131       SAVE /LUDAT2/
18132       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18133       SAVE /PYPARS/
18134       COMMON/PYINT1/MINT(400),VINT(400)
18135       SAVE /PYINT1/
18136       DIMENSION XPQ(-6:6),XQ(6),TX(6),TT(6),TS(6),NEHLQ(8,2),
18137      &CEHLQ(6,6,2,8,2),CDO(3,6,5,2),COW(3,5,4,2)
18138
18139 C...The following data lines are coefficients needed in the
18140 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
18141 C...parametrizations, see below.
18142 C...Powers of 1-x in different cases.
18143       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
18144 C...Expansion coefficients for up valence quark distribution.
18145       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
18146      1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,
18147      2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,
18148      3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,
18149      4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,
18150      5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,
18151      6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,
18152      1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,
18153      2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,
18154      3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,
18155      4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,
18156      5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,
18157      6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/
18158       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
18159      1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,
18160      2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,
18161      3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,
18162      4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,
18163      5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,
18164      6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,
18165      1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,
18166      2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,
18167      3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,
18168      4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,
18169      5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,
18170      6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/
18171 C...Expansion coefficients for down valence quark distribution.
18172       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
18173      1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,
18174      2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,
18175      3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,
18176      4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,
18177      5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,
18178      6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,
18179      1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,
18180      2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,
18181      3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,
18182      4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,
18183      5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,
18184      6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/
18185       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
18186      1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,
18187      2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,
18188      3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,
18189      4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,
18190      5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,
18191      6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,
18192      1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,
18193      2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,
18194      3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,
18195      4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,
18196      5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,
18197      6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/
18198 C...Expansion coefficients for up and down sea quark distributions.
18199       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
18200      1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,
18201      2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,
18202      3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,
18203      4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,
18204      5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,
18205      6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,
18206      1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,
18207      2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,
18208      3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,
18209      4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,
18210      5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,
18211      6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/
18212       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
18213      1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,
18214      2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,
18215      3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,
18216      4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,
18217      5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,
18218      6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,
18219      1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,
18220      2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,
18221      3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,
18222      4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,
18223      5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,
18224      6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/
18225 C...Expansion coefficients for gluon distribution.
18226       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
18227      1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,
18228      2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,
18229      3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,
18230      4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,
18231      5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,
18232      6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,
18233      1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,
18234      2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,
18235      3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,
18236      4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,
18237      5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,
18238      6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/
18239       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
18240      1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,
18241      2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,
18242      3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,
18243      4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,
18244      5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,
18245      6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,
18246      1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,
18247      2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,
18248      3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,
18249      4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,
18250      5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,
18251      6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/
18252 C...Expansion coefficients for strange sea quark distribution.
18253       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
18254      1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,
18255      2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,
18256      3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,
18257      4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,
18258      5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,
18259      6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,
18260      1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,
18261      2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,
18262      3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,
18263      4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,
18264      5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,
18265      6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/
18266       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
18267      1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,
18268      2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,
18269      3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,
18270      4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,
18271      5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,
18272      6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,
18273      1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,
18274      2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,
18275      3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,
18276      4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,
18277      5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,
18278      6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/
18279 C...Expansion coefficients for charm sea quark distribution.
18280       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
18281      1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,
18282      2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,
18283      3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,
18284      4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,
18285      5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,
18286      6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,
18287      1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,
18288      2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,
18289      3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,
18290      4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,
18291      5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,
18292      6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/
18293       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
18294      1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,
18295      2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,
18296      3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,
18297      4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,
18298      5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,
18299      6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,
18300      1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,
18301      2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,
18302      3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,
18303      4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,
18304      5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,
18305      6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/
18306 C...Expansion coefficients for bottom sea quark distribution.
18307       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
18308      1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,
18309      2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,
18310      3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,
18311      4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,
18312      5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,
18313      6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,
18314      1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,
18315      2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,
18316      3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,
18317      4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,
18318      5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,
18319      6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/
18320       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
18321      1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,
18322      2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,
18323      3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,
18324      4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,
18325      5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,
18326      6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,
18327      1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,
18328      2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,
18329      3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,
18330      4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,
18331      5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,
18332      6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/
18333 C...Expansion coefficients for top sea quark distribution.
18334       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
18335      1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,
18336      2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,
18337      3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,
18338      4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,
18339      5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,
18340      6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
18341      1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,
18342      2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,
18343      3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,
18344      4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,
18345      5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,
18346      6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/
18347       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
18348      1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,
18349      2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,
18350      3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,
18351      4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,
18352      5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,
18353      6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
18354      1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,
18355      2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,
18356      3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,
18357      4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,
18358      5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,
18359      6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/
18360
18361 C...The following data lines are coefficients needed in the
18362 C...Duke, Owens proton structure function parametrizations, see below.
18363 C...Expansion coefficients for (up+down) valence quark distribution.
18364       DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
18365      1 4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18366      2 4.000E-03, 7.240E-01,-4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18367      3-7.000E-03,-6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/
18368       DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
18369      1 3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18370      2 1.400E-02, 7.530E-01,-6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18371      3 0.000E+00,-7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/
18372 C...Expansion coefficients for down valence quark distribution.
18373       DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
18374      1 7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18375      2-2.370E-01, 6.270E-01,-4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00,
18376      3 2.600E-02,-1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/
18377       DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
18378      1 7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18379      2-2.320E-01, 6.270E-01,-4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00,
18380      3 2.300E-02,-1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/
18381 C...Expansion coefficients for (up+down+strange) sea quark distribution.
18382       DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
18383      1 1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18384      2-1.132E+00,-3.720E-01, 1.590E+00, 6.310E+00,-1.050E+01, 1.470E+01,
18385      3 2.930E-01,-2.900E-02,-1.530E-01,-2.730E-01,-3.170E+00, 9.800E+00/
18386       DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
18387      1 1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18388      2-1.920E+00,-2.730E-01, 5.300E-01, 1.570E+01,-1.010E+02, 2.230E+02,
18389      3 5.820E-01,-1.640E-01,-7.630E-01,-2.830E+00, 4.470E+01,-1.170E+02/
18390 C...Expansion coefficients for charm sea quark distribution.
18391       DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
18392      1 0.000E+00,-3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18393      2 1.350E-01,-2.220E-01, 3.260E+00,-3.030E+00, 1.740E+01,-1.790E+01,
18394      3-7.500E-02,-5.800E-02,-9.090E-01, 1.500E+00,-1.130E+01, 1.560E+01/
18395        DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
18396      1 0.000E+00,-1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18397      2 6.700E-02,-2.330E-01, 3.660E+00,-4.740E-01, 9.500E+00,-1.660E+01,
18398      3-3.100E-02,-2.300E-02,-4.530E-01, 3.580E-01,-5.430E+00, 1.550E+01/
18399 C...Expansion coefficients for gluon distribution.
18400       DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
18401      1 1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
18402      2-1.710E+00,-9.490E-01, 1.440E+00,-7.190E+00,-1.650E+01, 1.530E+01,
18403      3 6.380E-01, 3.250E-01,-1.050E+00, 2.550E-01, 1.090E+01,-1.010E+01/
18404       DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
18405      1 8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
18406      2-9.710E-01,-1.160E+00, 1.230E+00,-5.640E+00,-7.540E+00,-5.960E-01,
18407      3 4.340E-01, 4.760E-01,-2.540E-01,-8.170E-01, 5.500E+00, 1.260E-01/
18408
18409 C...The following data lines are coefficients needed in the
18410 C...Owens pion structure function parametrizations, see below.
18411 C...Expansion coefficients for up and down valence quark distributions.
18412       DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
18413      1  4.0000E-01,  7.0000E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18414      2 -6.2120E-02,  6.4780E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18415      3 -7.1090E-03,  1.3350E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/
18416       DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
18417      1  4.0000E-01,  6.2800E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18418      2 -5.9090E-02,  6.4360E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18419      3 -6.5240E-03,  1.4510E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/
18420 C...Expansion coefficients for gluon distribution.
18421       DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
18422      1  8.8800E-01,  0.0000E+00,  3.1100E+00,  6.0000E+00,  0.0000E+00,
18423      2 -1.8020E+00, -1.5760E+00, -1.3170E-01,  2.8010E+00, -1.7280E+01,
18424      3  1.8120E+00,  1.2000E+00,  5.0680E-01, -1.2160E+01,  2.0490E+01/
18425       DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
18426      1  7.9400E-01,  0.0000E+00,  2.8900E+00,  6.0000E+00,  0.0000E+00,
18427      2 -9.1440E-01, -1.2370E+00,  5.9660E-01, -3.6710E+00, -8.1910E+00,
18428      3  5.9660E-01,  6.5820E-01, -2.5500E-01, -2.3040E+00,  7.7580E+00/
18429 C...Expansion coefficients for (up+down+strange) quark sea distribution.
18430       DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
18431      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00,
18432      2 -2.4280E-01, -2.1200E-01,  8.6730E-01,  1.2660E+00,  2.3820E+00,
18433      3  1.3860E-01,  3.6710E-03,  4.7470E-02, -2.2150E+00,  3.4820E-01/
18434       DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
18435      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00,
18436      2 -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00,  5.6210E-01,
18437      3 -1.7400E-01, -9.6230E-02,  1.5750E+00,  1.3780E+00, -2.7010E-01/
18438 C...Expansion coefficients for charm quark sea distribution.
18439       DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
18440      1  0.0000E+00, -2.2120E-02,  2.8940E+00,  0.0000E+00,  0.0000E+00,
18441      2  7.9280E-02, -3.7850E-01,  9.4330E+00,  5.2480E+00,  8.3880E+00,
18442      3 -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/
18443       DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
18444      1  0.0000E+00, -8.8200E-02,  1.9240E+00,  0.0000E+00,  0.0000E+00,
18445      2  6.2290E-02, -2.8920E-01,  2.4240E-01, -4.4630E+00, -8.3670E-01,
18446      3 -4.0990E-02, -1.0820E-01,  2.0360E+00,  5.2090E+00, -4.8400E-02/
18447
18448 C...Euler's beta function, requires ordinary Gamma function
18449       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
18450
18451 C...Reset structure functions, check x and hadron flavour.
18452       ALAM=0.
18453       DO 100 KFL=-6,6
18454   100 XPQ(KFL)=0.
18455       IF(X.LT.0..OR.X.GT.1.) THEN
18456         WRITE(MSTU(11),1000) X
18457         RETURN
18458       ENDIF
18459       KFA=IABS(KF)
18460       IF(KFA.NE.211.AND.KFA.NE.2212.AND.KFA.NE.2112) THEN
18461         WRITE(MSTU(11),1100) KF
18462         RETURN
18463       ENDIF
18464
18465 C...Call user-supplied structure function. Select proton/neutron/pion.
18466       IF(MSTP(51).EQ.0.OR.MSTP(52).GE.2) THEN
18467         KFE=KFA
18468         IF(KFA.EQ.2112) KFE=2212
18469         CALL PYSTFE(KFE,X,Q2,XPQ)
18470         GOTO 230
18471       ENDIF
18472       IF(KFA.EQ.211) GOTO 200
18473
18474       IF(MSTP(51).EQ.1.OR.MSTP(51).EQ.2) THEN
18475 C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.
18476 C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1
18477
18478 C...Determine set, Lamdba and x and t expansion variables.
18479         NSET=MSTP(51)
18480         IF(NSET.EQ.1) ALAM=0.2
18481         IF(NSET.EQ.2) ALAM=0.29
18482         TMIN=LOG(5./ALAM**2)
18483         TMAX=LOG(1E8/ALAM**2)
18484         IF(MSTP(52).EQ.0) THEN
18485           T=TMIN
18486         ELSE
18487           T=LOG(Q2/ALAM**2)
18488         ENDIF
18489         VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
18490         NX=1
18491         IF(X.LE.0.1) NX=2
18492         IF(NX.EQ.1) VX=(2.*X-1.1)/0.9
18493         IF(NX.EQ.2) VX=MAX(-1.,(2.*LOG(X)+11.51293)/6.90776)
18494         CXS=1.
18495         IF(X.LT.1E-4.AND.ABS(PARP(51)-1.).GT.0.01) CXS=
18496      &  (1E-4/X)**(PARP(51)-1.)
18497
18498 C...Chebyshev polynomials for x and t expansion.
18499         TX(1)=1.
18500         TX(2)=VX
18501         TX(3)=2.*VX**2-1.
18502         TX(4)=4.*VX**3-3.*VX
18503         TX(5)=8.*VX**4-8.*VX**2+1.
18504         TX(6)=16.*VX**5-20.*VX**3+5.*VX
18505         TT(1)=1.
18506         TT(2)=VT
18507         TT(3)=2.*VT**2-1.
18508         TT(4)=4.*VT**3-3.*VT
18509         TT(5)=8.*VT**4-8.*VT**2+1.
18510         TT(6)=16.*VT**5-20.*VT**3+5.*VT
18511
18512 C...Calculate structure functions.
18513         DO 120 KFL=1,6
18514         XQSUM=0.
18515         DO 110 IT=1,6
18516         DO 110 IX=1,6
18517   110   XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
18518   120   XQ(KFL)=XQSUM*(1.-X)**NEHLQ(KFL,NSET)*CXS
18519
18520 C...Put into output array.
18521         XPQ(0)=XQ(4)
18522         XPQ(1)=XQ(2)+XQ(3)
18523         XPQ(2)=XQ(1)+XQ(3)
18524         XPQ(3)=XQ(5)
18525         XPQ(4)=XQ(6)
18526         XPQ(-1)=XQ(3)
18527         XPQ(-2)=XQ(3)
18528         XPQ(-3)=XQ(5)
18529         XPQ(-4)=XQ(6)
18530
18531 C...Special expansion for bottom (threshold effects).
18532         IF(MSTP(54).GE.5) THEN
18533           IF(NSET.EQ.1) TMIN=8.1905
18534           IF(NSET.EQ.2) TMIN=7.4474
18535           IF(T.LE.TMIN) GOTO 140
18536           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
18537           TT(1)=1.
18538           TT(2)=VT
18539           TT(3)=2.*VT**2-1.
18540           TT(4)=4.*VT**3-3.*VT
18541           TT(5)=8.*VT**4-8.*VT**2+1.
18542           TT(6)=16.*VT**5-20.*VT**3+5.*VT
18543           XQSUM=0.
18544           DO 130 IT=1,6
18545           DO 130 IX=1,6
18546   130     XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
18547           XPQ(5)=XQSUM*(1.-X)**NEHLQ(7,NSET)
18548           XPQ(-5)=XPQ(5)
18549   140     CONTINUE
18550         ENDIF
18551
18552 C...Special expansion for top (threshold effects).
18553         IF(MSTP(54).GE.6) THEN
18554           IF(NSET.EQ.1) TMIN=11.5528
18555           IF(NSET.EQ.2) TMIN=10.8097
18556           TMIN=TMIN+2.*LOG(PMAS(6,1)/30.)
18557           TMAX=TMAX+2.*LOG(PMAS(6,1)/30.)
18558           IF(T.LE.TMIN) GOTO 160
18559           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
18560           TT(1)=1.
18561           TT(2)=VT
18562           TT(3)=2.*VT**2-1.
18563           TT(4)=4.*VT**3-3.*VT
18564           TT(5)=8.*VT**4-8.*VT**2+1.
18565           TT(6)=16.*VT**5-20.*VT**3+5.*VT
18566           XQSUM=0.
18567           DO 150 IT=1,6
18568           DO 150 IX=1,6
18569   150     XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
18570           XPQ(6)=XQSUM*(1.-X)**NEHLQ(8,NSET)
18571           XPQ(-6)=XPQ(6)
18572   160     CONTINUE
18573         ENDIF
18574
18575       ELSEIF(MSTP(51).EQ.3.OR.MSTP(51).EQ.4) THEN
18576 C...Proton structure functions from Duke, Owens.
18577 C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.
18578
18579 C...Determine set, Lambda and s expansion parameter.
18580         NSET=MSTP(51)-2
18581         IF(NSET.EQ.1) ALAM=0.2
18582         IF(NSET.EQ.2) ALAM=0.4
18583         IF(MSTP(52).LE.0) THEN
18584           SD=0.
18585         ELSE
18586           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
18587         ENDIF
18588
18589 C...Calculate structure functions.
18590         DO 180 KFL=1,5
18591         DO 170 IS=1,6
18592   170   TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
18593      &  CDO(3,IS,KFL,NSET)*SD**2
18594         IF(KFL.LE.2) THEN
18595           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBET(TS(1),
18596      &    TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))
18597         ELSE
18598           XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2+
18599      &    TS(6)*X**3)
18600         ENDIF
18601   180   CONTINUE
18602
18603 C...Put into output arrays.
18604         XPQ(0)=XQ(5)
18605         XPQ(1)=XQ(2)+XQ(3)/6.
18606         XPQ(2)=3.*XQ(1)-XQ(2)+XQ(3)/6.
18607         XPQ(3)=XQ(3)/6.
18608         XPQ(4)=XQ(4)
18609         XPQ(-1)=XQ(3)/6.
18610         XPQ(-2)=XQ(3)/6.
18611         XPQ(-3)=XQ(3)/6.
18612         XPQ(-4)=XQ(4)
18613
18614 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
18615 C...These are accessed via PYSTFE since the files needed may not always
18616 C...available.
18617       ELSEIF(MSTP(51).GE.11.AND.MSTP(51).LE.13) THEN
18618         CALL PYSTFE(2212,X,Q2,XPQ)
18619
18620 C...Unknown proton parametrization.
18621       ELSE
18622         WRITE(MSTU(11),1200) MSTP(51)
18623       ENDIF
18624       GOTO 230
18625
18626   200 IF((MSTP(51).GE.1.AND.MSTP(51).LE.4).OR.
18627      &(MSTP(51).GE.11.AND.MSTP(51).LE.13)) THEN
18628 C...Pion structure functions from Owens.
18629 C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2.
18630
18631 C...Determine set, Lambda and s expansion variable.
18632         NSET=1
18633         IF(MSTP(51).EQ.2.OR.MSTP(51).EQ.4.OR.MSTP(51).EQ.13) NSET=2
18634         IF(NSET.EQ.1) ALAM=0.2
18635         IF(NSET.EQ.2) ALAM=0.4
18636         IF(MSTP(52).LE.0) THEN
18637           SD=0.
18638         ELSE
18639           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
18640         ENDIF
18641
18642 C...Calculate structure functions.
18643         DO 220 KFL=1,4
18644         DO 210 IS=1,5
18645   210   TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
18646      &  COW(3,IS,KFL,NSET)*SD**2
18647         IF(KFL.EQ.1) THEN
18648           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBET(TS(1),TS(2)+1.)
18649         ELSE
18650           XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2)
18651         ENDIF
18652   220   CONTINUE
18653
18654 C...Put into output arrays.
18655         XPQ(0)=XQ(2)
18656         XPQ(1)=XQ(3)/6.
18657         XPQ(2)=XQ(1)+XQ(3)/6.
18658         XPQ(3)=XQ(3)/6.
18659         XPQ(4)=XQ(4)
18660         XPQ(-1)=XQ(1)+XQ(3)/6.
18661         XPQ(-2)=XQ(3)/6.
18662         XPQ(-3)=XQ(3)/6.
18663         XPQ(-4)=XQ(4)
18664
18665 C...Unknown pion parametrization.
18666       ELSE
18667         WRITE(MSTU(11),1200) MSTP(51)
18668       ENDIF
18669
18670 C...Isospin conjugation for neutron, charge conjugation for antipart.
18671   230 IF(KFA.EQ.2112) THEN
18672         XPS=XPQ(1)
18673         XPQ(1)=XPQ(2)
18674         XPQ(2)=XPS
18675         XPS=XPQ(-1)
18676         XPQ(-1)=XPQ(-2)
18677         XPQ(-2)=XPS
18678       ENDIF
18679       IF(KF.LT.0) THEN
18680         DO 240 KFL=1,4
18681         XPS=XPQ(KFL)
18682         XPQ(KFL)=XPQ(-KFL)
18683   240   XPQ(-KFL)=XPS
18684       ENDIF
18685
18686 C...Check positivity and reset above maximum allowed flavour.
18687       DO 250 KFL=-6,6
18688       XPQ(KFL)=MAX(0.,XPQ(KFL))
18689   250 IF(IABS(KFL).GT.MSTP(54)) XPQ(KFL)=0.
18690
18691 C...consider nuclear effect on the structure function
18692         IF((JBT.NE.1.AND.JBT.NE.2).OR.IHPR2(6).EQ.0
18693      &                  .OR.IHNT2(16).EQ.1) GO TO 400
18694         ATNM=IHNT2(2*JBT-1)
18695         IF(ATNM.LE.1.0) GO TO 400
18696         IF(JBT.EQ.1) THEN
18697           BBR2=(YP(1,IHNT2(11))**2+YP(2,IHNT2(11))**2)/1.44/ATNM**0.66666
18698         ELSEIF(JBT.EQ.2) THEN
18699           BBR2=(YT(1,IHNT2(12))**2+YT(2,IHNT2(12))**2)/1.44/ATNM**0.66666
18700         ENDIF
18701         BBR2=MIN(1.0,BBR2)
18702         ABX=(ATNM**0.33333333-1.0)
18703         APX=HIPR1(6)*4.0/3.0*ABX*SQRT(1.0-BBR2)
18704         AAX=1.192*ALOG(ATNM)**0.1666666
18705         RRX=AAX*(X**3-1.2*X**2+0.21*X)+1.0
18706      &          -(APX-1.079*ABX*SQRT(X)/ALOG(ATNM+1.0))*EXP(-X**2.0/0.01)
18707         DO 300 KFL=-6,6
18708                 XPQ(KFL)=XPQ(KFL)*RRX
18709 300     CONTINUE
18710 C                       ********consider the nuclear effect on the structure
18711 C                               fucntion which also depends on the impact
18712 C                               parameter of the nuclear reaction
18713
18714 400     CONTINUE
18715 C...Formats for error printouts.
18716  1000 FORMAT(' Error: x value outside physical range, x =',1P,E12.3)
18717  1100 FORMAT(' Error: illegal particle code for structure function,',
18718      &' KF =',I5)
18719  1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',
18720      &' MSTP(51) =',I5)
18721
18722       RETURN
18723       END
18724
18725 C*********************************************************************
18726
18727       SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
18728
18729 C...In case of a hadron remnant which is more complicated than just a
18730 C...quark or a diquark, split it into two (partons or hadron + parton).
18731       DIMENSION KFL(3)
18732
18733 C...Preliminaries. Parton composition.
18734       KFA=IABS(KF)
18735       KFS=ISIGN(1,KF)
18736       KFL(1)=MOD(KFA/1000,10)
18737       KFL(2)=MOD(KFA/100,10)
18738       KFL(3)=MOD(KFA/10,10)
18739       KFLR=KFLIN*KFS
18740       KFLCH=0
18741
18742 C...Subdivide meson.
18743       IF(KFL(1).EQ.0) THEN
18744         KFL(2)=KFL(2)*(-1)**KFL(2)
18745         KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
18746         IF(KFLR.EQ.KFL(2)) THEN
18747           KFLSP=KFL(3)
18748         ELSEIF(KFLR.EQ.KFL(3)) THEN
18749           KFLSP=KFL(2)
18750         ELSEIF(IABS(KFLR).EQ.21.AND.RLU(0).GT.0.5) THEN
18751           KFLSP=KFL(2)
18752           KFLCH=KFL(3)
18753         ELSEIF(IABS(KFLR).EQ.21) THEN
18754           KFLSP=KFL(3)
18755           KFLCH=KFL(2)
18756         ELSEIF(KFLR*KFL(2).GT.0) THEN
18757           CALL LUKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
18758           KFLSP=KFL(3)
18759         ELSE
18760           CALL LUKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
18761           KFLSP=KFL(2)
18762         ENDIF
18763
18764 C...Subdivide baryon.
18765       ELSE
18766         NAGR=0
18767         DO 100 J=1,3
18768   100   IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
18769         IF(NAGR.GE.1) THEN
18770           RAGR=0.00001+(NAGR-0.00002)*RLU(0)
18771           IAGR=0
18772           DO 110 J=1,3
18773           IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1.
18774   110     IF(IAGR.EQ.0.AND.RAGR.LE.0.) IAGR=J
18775         ELSE
18776           IAGR=1.00001+2.99998*RLU(0)
18777         ENDIF
18778         ID1=1
18779         IF(IAGR.EQ.1) ID1=2
18780         IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
18781         ID2=6-IAGR-ID1
18782         KSP=3
18783         IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
18784           IF(IAGR.NE.3.AND.RLU(0).GT.0.25) KSP=1
18785         ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
18786           IF(IAGR.NE.1.AND.RLU(0).GT.0.25) KSP=1
18787         ELSEIF(MOD(KFA,10).EQ.2) THEN
18788           IF(IAGR.EQ.1) KSP=1
18789           IF(IAGR.NE.1.AND.RLU(0).GT.0.75) KSP=1
18790         ENDIF
18791         KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
18792         IF(KFLIN.EQ.21) THEN
18793           KFLCH=KFL(IAGR)
18794         ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
18795           CALL LUKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
18796         ELSEIF(NAGR.EQ.0) THEN
18797           CALL LUKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
18798           KFLSP=KFL(IAGR)
18799         ENDIF
18800       ENDIF
18801
18802 C...Add on correct sign for result.
18803       KFLCH=KFLCH*KFS
18804       KFLSP=KFLSP*KFS
18805
18806       RETURN
18807       END
18808
18809 C*********************************************************************
18810
18811       FUNCTION PYGAMM(X)
18812
18813 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
18814 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
18815 C...(Dover, 1965) 6.1.36.
18816       DIMENSION B(8)
18817       DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857,
18818      &-0.756704078,0.482199394,-0.193527818,0.035868343/
18819
18820       NX=INT(X)
18821       DX=X-NX
18822
18823       PYGAMM=1.
18824       DO 100 I=1,8
18825   100 PYGAMM=PYGAMM+B(I)*DX**I
18826       IF(X.LT.1.) THEN
18827         PYGAMM=PYGAMM/X
18828       ELSE
18829         DO 110 IX=1,NX-1
18830   110   PYGAMM=(X-IX)*PYGAMM
18831       ENDIF
18832
18833       RETURN
18834       END
18835
18836 C***********************************************************************
18837
18838       FUNCTION PYW1AU(EPS,IREIM)
18839
18840 C...Calculates real and imaginary parts of the auxiliary function W1;
18841 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18842 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18843       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18844       SAVE /LUDAT1/
18845
18846       ASINH(X)=LOG(X+SQRT(X**2+1.))
18847       ACOSH(X)=LOG(X+SQRT(X**2-1.))
18848
18849       IF(EPS.LT.0.) THEN
18850         W1RE=2.*SQRT(1.-EPS)*ASINH(SQRT(-1./EPS))
18851         W1IM=0.
18852       ELSEIF(EPS.LT.1.) THEN
18853         W1RE=2.*SQRT(1.-EPS)*ACOSH(SQRT(1./EPS))
18854         W1IM=-PARU(1)*SQRT(1.-EPS)
18855       ELSE
18856         W1RE=2.*SQRT(EPS-1.)*ASIN(SQRT(1./EPS))
18857         W1IM=0.
18858       ENDIF
18859
18860       IF(IREIM.EQ.1) PYW1AU=W1RE
18861       IF(IREIM.EQ.2) PYW1AU=W1IM
18862
18863       RETURN
18864       END
18865
18866 C***********************************************************************
18867
18868       FUNCTION PYW2AU(EPS,IREIM)
18869
18870 C...Calculates real and imaginary parts of the auxiliary function W2;
18871 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18872 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18873       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18874       SAVE /LUDAT1/
18875
18876       ASINH(X)=LOG(X+SQRT(X**2+1.))
18877       ACOSH(X)=LOG(X+SQRT(X**2-1.))
18878
18879       IF(EPS.LT.0.) THEN
18880         W2RE=4.*(ASINH(SQRT(-1./EPS)))**2
18881         W2IM=0.
18882       ELSEIF(EPS.LT.1.) THEN
18883         W2RE=4.*(ACOSH(SQRT(1./EPS)))**2-PARU(1)**2
18884         W2IM=-4.*PARU(1)*ACOSH(SQRT(1./EPS))
18885       ELSE
18886         W2RE=-4.*(ASIN(SQRT(1./EPS)))**2
18887         W2IM=0.
18888       ENDIF
18889
18890       IF(IREIM.EQ.1) PYW2AU=W2RE
18891       IF(IREIM.EQ.2) PYW2AU=W2IM
18892
18893       RETURN
18894       END
18895
18896 C***********************************************************************
18897
18898       FUNCTION PYI3AU(BE,EPS,IREIM)
18899
18900 C...Calculates real and imaginary parts of the auxiliary function I3;
18901 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18902 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18903       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18904       SAVE /LUDAT1/
18905
18906       IF(EPS.LT.1.) GA=0.5*(1.+SQRT(1.-EPS))
18907
18908       IF(EPS.LT.0.) THEN
18909         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+
18910      &  PYSPEN((BE-GA)/BE,0.,1)-PYSPEN((BE-GA)/(BE-1.),0.,1)+
18911      &  (LOG(BE)**2-LOG(BE-1.)**2)/2.+LOG(GA)*LOG((GA+BE-1.)/BE)+
18912      &  LOG(GA-1.)*LOG((BE-1.)/(GA+BE-1.))
18913         F3IM=0.
18914       ELSEIF(EPS.LT.1.) THEN
18915         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+
18916      &  PYSPEN(GA/(GA-BE),0.,1)-PYSPEN((GA-1.)/(GA-BE),0.,1)+
18917      &  LOG(GA/(1.-GA))*LOG((GA+BE-1.)/(BE-GA))
18918         F3IM=-PARU(1)*LOG((GA+BE-1.)/(BE-GA))
18919       ELSE
18920         RSQ=EPS/(EPS-1.+(2.*BE-1.)**2)
18921         RCTHE=RSQ*(1.-2.*BE/EPS)
18922         RSTHE=SQRT(RSQ-RCTHE**2)
18923         RCPHI=RSQ*(1.+2.*(BE-1.)/EPS)
18924         RSPHI=SQRT(RSQ-RCPHI**2)
18925         R=SQRT(RSQ)
18926         THE=ACOS(RCTHE/R)
18927         PHI=ACOS(RCPHI/R)
18928         F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
18929      &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
18930      &  (PHI-THE)*(PHI+THE-PARU(1))
18931         F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
18932      &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
18933       ENDIF
18934
18935       IF(IREIM.EQ.1) PYI3AU=2./(2.*BE-1.)*F3RE
18936       IF(IREIM.EQ.2) PYI3AU=2./(2.*BE-1.)*F3IM
18937
18938       RETURN
18939       END
18940
18941 C***********************************************************************
18942
18943       FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
18944
18945 C...Calculates real and imaginary part of Spence function; see
18946 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
18947       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18948       SAVE /LUDAT1/
18949       DIMENSION B(0:14)
18950
18951       DATA B/
18952      & 1.000000E+00,        -5.000000E-01,         1.666667E-01,
18953      & 0.000000E+00,        -3.333333E-02,         0.000000E+00,
18954      & 2.380952E-02,         0.000000E+00,        -3.333333E-02,
18955      & 0.000000E+00,         7.575757E-02,         0.000000E+00,
18956      &-2.531135E-01,         0.000000E+00,         1.166667E+00/
18957
18958       XRE=XREIN
18959       XIM=XIMIN
18960       IF(ABS(1.-XRE).LT.1.E-6.AND.ABS(XIM).LT.1.E-6) THEN
18961         IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6.
18962         IF(IREIM.EQ.2) PYSPEN=0.
18963         RETURN
18964       ENDIF
18965
18966       XMOD=SQRT(XRE**2+XIM**2)
18967       IF(XMOD.LT.1.E-6) THEN
18968         IF(IREIM.EQ.1) PYSPEN=0.
18969         IF(IREIM.EQ.2) PYSPEN=0.
18970         RETURN
18971       ENDIF
18972
18973       XARG=SIGN(ACOS(XRE/XMOD),XIM)
18974       SP0RE=0.
18975       SP0IM=0.
18976       SGN=1.
18977       IF(XMOD.GT.1.) THEN
18978         ALGXRE=LOG(XMOD)
18979         ALGXIM=XARG-SIGN(PARU(1),XARG)
18980         SP0RE=-PARU(1)**2/6.-(ALGXRE**2-ALGXIM**2)/2.
18981         SP0IM=-ALGXRE*ALGXIM
18982         SGN=-1.
18983         XMOD=1./XMOD
18984         XARG=-XARG
18985         XRE=XMOD*COS(XARG)
18986         XIM=XMOD*SIN(XARG)
18987       ENDIF
18988       IF(XRE.GT.0.5) THEN
18989         ALGXRE=LOG(XMOD)
18990         ALGXIM=XARG
18991         XRE=1.-XRE
18992         XIM=-XIM
18993         XMOD=SQRT(XRE**2+XIM**2)
18994         XARG=SIGN(ACOS(XRE/XMOD),XIM)
18995         ALGYRE=LOG(XMOD)
18996         ALGYIM=XARG
18997         SP0RE=SP0RE+SGN*(PARU(1)**2/6.-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
18998         SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
18999         SGN=-SGN
19000       ENDIF
19001
19002       XRE=1.-XRE
19003       XIM=-XIM
19004       XMOD=SQRT(XRE**2+XIM**2)
19005       XARG=SIGN(ACOS(XRE/XMOD),XIM)
19006       ZRE=-LOG(XMOD)
19007       ZIM=-XARG
19008
19009       SPRE=0.
19010       SPIM=0.
19011       SAVERE=1.
19012       SAVEIM=0.
19013       DO 100 I=0,14
19014       TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/FLOAT(I+1)
19015       TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/FLOAT(I+1)
19016       SAVERE=TERMRE
19017       SAVEIM=TERMIM
19018       SPRE=SPRE+B(I)*TERMRE
19019   100 SPIM=SPIM+B(I)*TERMIM
19020
19021       IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
19022       IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
19023
19024       RETURN
19025       END
19026
19027 ***********************************************************************
19028
19029       SUBROUTINE PYTEST(MTEST)
19030
19031 C...Purpose: to provide a simple program (disguised as a subroutine) to
19032 C...run at installation as a check that the program works as intended.
19033       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
19034       SAVE /LUJETS/
19035       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19036       SAVE /LUDAT1/
19037       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
19038       SAVE /LUDAT2/
19039       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
19040       SAVE /LUDAT3/
19041       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
19042       SAVE /PYSUBS/
19043       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19044       SAVE /PYPARS/
19045
19046 C...Common initial values. Loop over initiating conditions.
19047       MSTP(122)=1
19048       IF(MTEST.LE.0) MSTP(122)=0
19049       MDCY(LUCOMP(111),1)=0
19050       NERR=0
19051       DO 130 IPROC=1,7
19052
19053 C...Reset process type, kinematics cuts, and the flags used.
19054       MSEL=0
19055       DO 100 ISUB=1,200
19056   100 MSUB(ISUB)=0
19057       CKIN(1)=2.
19058       CKIN(3)=0.
19059       MSTP(2)=1
19060       MSTP(33)=0
19061       MSTP(81)=1
19062       MSTP(82)=1
19063       MSTP(111)=1
19064       MSTP(131)=0
19065       MSTP(133)=0
19066       PARP(131)=0.01
19067
19068 C...Prompt photon production at fixed target.
19069       IF(IPROC.EQ.1) THEN
19070         PZSUM=300.
19071         PESUM=SQRT(PZSUM**2+ULMASS(211)**2)+ULMASS(2212)
19072         PQSUM=2.
19073         MSEL=10
19074         CKIN(3)=5.
19075         CALL PYINIT('FIXT','pi+','p',PZSUM)
19076
19077 C...QCD processes at ISR energies.
19078       ELSEIF(IPROC.EQ.2) THEN
19079         PESUM=63.
19080         PZSUM=0.
19081         PQSUM=2.
19082         MSEL=1
19083         CKIN(3)=5.
19084         CALL PYINIT('CMS','p','p',PESUM)
19085
19086 C...W production + multiple interactions at CERN Collider.
19087       ELSEIF(IPROC.EQ.3) THEN
19088         PESUM=630.
19089         PZSUM=0.
19090         PQSUM=0.
19091         MSEL=12
19092         CKIN(1)=20.
19093         MSTP(82)=4
19094         MSTP(2)=2
19095         MSTP(33)=3
19096         CALL PYINIT('CMS','p','pbar',PESUM)
19097
19098 C...W/Z gauge boson pairs + overlayed events at the Tevatron.
19099       ELSEIF(IPROC.EQ.4) THEN
19100         PESUM=1800.
19101         PZSUM=0.
19102         PQSUM=0.
19103         MSUB(22)=1
19104         MSUB(23)=1
19105         MSUB(25)=1
19106         CKIN(1)=200.
19107         MSTP(111)=0
19108         MSTP(131)=1
19109         MSTP(133)=2
19110         PARP(131)=0.04
19111         CALL PYINIT('CMS','p','pbar',PESUM)
19112
19113 C...Higgs production at LHC.
19114       ELSEIF(IPROC.EQ.5) THEN
19115         PESUM=17000.
19116         PZSUM=0.
19117         PQSUM=0.
19118         MSEL=16
19119         PMAS(25,1)=300.
19120         CKIN(1)=200.
19121         MSTP(81)=0
19122         MSTP(111)=0
19123         CALL PYINIT('CMS','p','pbar',PESUM)
19124
19125 C...Z' production at SSC.
19126       ELSEIF(IPROC.EQ.6) THEN
19127         PESUM=40000.
19128         PZSUM=0.
19129         PQSUM=0.
19130         MSEL=21
19131         PMAS(32,1)=600.
19132         CKIN(1)=400.
19133         MSTP(81)=0
19134         MSTP(111)=0
19135         CALL PYINIT('CMS','p','pbar',PESUM)
19136
19137 C...W pair production at 1 TeV e+e- collider.
19138       ELSEIF(IPROC.EQ.7) THEN
19139         PESUM=1000.
19140         PZSUM=0.
19141         PQSUM=0.
19142         MSUB(25)=1
19143         CALL PYINIT('CMS','e+','e-',PESUM)
19144       ENDIF
19145
19146 C...Generate 20 events of each required type.
19147       DO 120 IEV=1,20
19148       CALL PYTHIA
19149       PESUMM=PESUM
19150       IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
19151
19152 C...Check conservation of energy/momentum/flavour.
19153       MERR=0
19154       DEVE=ABS(PLU(0,4)-PESUMM)+ABS(PLU(0,3)-PZSUM)
19155       DEVT=ABS(PLU(0,1))+ABS(PLU(0,2))
19156       DEVQ=ABS(PLU(0,6)-PQSUM)
19157       IF(DEVE.GT.1E-3*PESUM.OR.DEVT.GT.MAX(0.01,1E-5*PESUM).OR.
19158      &DEVQ.GT.0.1) MERR=1
19159       IF(MERR.NE.0) WRITE(MSTU(11),1000) IPROC,IEV
19160
19161 C...Check that all KF codes are known ones, and that partons/particles
19162 C...satisfy energy-momentum-mass relation.
19163       DO 110 I=1,N
19164       IF(K(I,1).GT.20) GOTO 110
19165       IF(LUCOMP(K(I,2)).EQ.0) THEN
19166         WRITE(MSTU(11),1100) I
19167         MERR=MERR+1
19168       ENDIF
19169       PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
19170      &SIGN(1.,P(I,5))
19171       IF(ABS(PD).GT.MAX(0.1,0.002*P(I,4)**2,0.002*P(I,5)**2).OR.
19172      &(P(I,5).GE.0..AND.P(I,4).LT.0.)) THEN
19173         WRITE(MSTU(11),1200) I
19174         MERR=MERR+1
19175       ENDIF
19176   110 CONTINUE
19177
19178 C...Listing of erronoeus events, and first event of each type.
19179       IF(MERR.GE.1) NERR=NERR+1
19180       IF(NERR.GE.10) THEN
19181         WRITE(MSTU(11),1300)
19182         CALL LULIST(1)
19183         STOP
19184       ENDIF
19185       IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
19186         IF(MERR.GE.1) WRITE(MSTU(11),1400)
19187         CALL LULIST(1)
19188       ENDIF
19189   120 CONTINUE
19190
19191 C...List statistics for each process type.
19192       IF(MTEST.GE.1) CALL PYSTAT(1)
19193   130 CONTINUE
19194
19195 C...Summarize result of run.
19196       IF(NERR.EQ.0) WRITE(MSTU(11),1500)
19197       IF(NERR.GT.0) WRITE(MSTU(11),1600) NERR
19198       RETURN
19199
19200 C...Formats for information.
19201  1000 FORMAT(/5X,'Energy/momentum/flavour nonconservation for process',
19202      &I2,', event',I4)
19203  1100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
19204  1200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
19205      &'kinematics')
19206  1300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
19207      &'wrong.'/5X,'Execution will be stopped after listing of event.')
19208  1400 FORMAT(5X,'Faulty event follows:')
19209  1500 FORMAT(//5X,'End result of run: no errors detected.')
19210  1600 FORMAT(//5X,'End result of run:',I2,' errors detected.'/
19211      &5X,'This should not have happened!')
19212       END
19213
19214 C*********************************************************************
19215
19216       BLOCK DATA PYDATA
19217
19218 C...Give sensible default values to all status codes and parameters.
19219       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
19220       SAVE /PYSUBS/
19221       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19222       SAVE /PYPARS/
19223       COMMON/PYINT1/MINT(400),VINT(400)
19224       SAVE /PYINT1/
19225       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
19226       SAVE /PYINT2/
19227       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19228       SAVE /PYINT3/
19229       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
19230       SAVE /PYINT4/
19231       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
19232       SAVE /PYINT5/
19233       COMMON/PYINT6/PROC(0:200)
19234       CHARACTER PROC*28
19235       SAVE /PYINT6/
19236
19237 C...Default values for allowed processes and kinematics constraints.
19238       DATA MSEL/1/
19239       DATA MSUB/200*0/
19240       DATA ((KFIN(I,J),J=-40,40),I=1,2)/40*1,0,80*1,0,40*1/
19241       DATA CKIN/
19242      &   2.0, -1.0,  0.0, -1.0,  1.0,  1.0, -10.,  10., -10.,  10.,
19243      1  -10.,  10., -10.,  10., -10.,  10., -1.0,  1.0, -1.0,  1.0,
19244      2   0.0,  1.0,  0.0,  1.0, -1.0,  1.0, -1.0,  1.0,   0.,   0.,
19245      3   2.0, -1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19246      4   160*0./
19247
19248 C...Default values for main switches and parameters. Reset information.
19249       DATA (MSTP(I),I=1,100)/
19250      &     3,    1,    2,    0,    0,    0,    0,    0,    0,    0,
19251      1     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19252      2     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19253      3     1,    2,    0,    0,    0,    2,    0,    0,    0,    0,
19254      4     1,    0,    3,    7,    1,    0,    0,    0,    0,    0,
19255      5     1,    1,   20,    6,    0,    0,    0,    0,    0,    0,
19256      6     1,    2,    2,    2,    1,    0,    0,    0,    0,    0,
19257      7     1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19258      8     1,    1,  100,    0,    0,    0,    0,    0,    0,    0,
19259      9     1,    4,    0,    0,    0,    0,    0,    0,    0,    0/
19260       DATA (MSTP(I),I=101,200)/
19261      &     1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19262      1     1,    1,    1,    0,    0,    0,    0,    0,    0,    0,
19263      2     0,    1,    2,    1,    1,   20,    0,    0,    0,    0,
19264      3     0,    4,    0,    1,    0,    0,    0,    0,    0,    0,
19265      4     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19266      5     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19267      6     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19268      7     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19269      8     5,    3, 1989,   11,   24,    0,    0,    0,    0,    0,
19270      9     0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
19271       DATA (PARP(I),I=1,100)/
19272      &  0.25,  10.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19273      1    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19274      2    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19275      3   1.5,  2.0, 0.075,  0.,  0.2,   0.,   0.,   0.,   0.,   0.,
19276      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19277      5   1.0, 2.26, 1.E4, 1.E-4,  0.,   0.,   0.,   0.,   0.,   0.,
19278      6  0.25,  1.0, 0.25,  1.0,  2.0, 1.E-3, 4.0,   0.,   0.,   0.,
19279      7   4.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19280      8   1.6, 1.85,  0.5,  0.2, 0.33, 0.66,  0.7,  0.5,   0.,   0.,
19281      9  0.44, 0.44,  2.0,  1.0,   0.,  3.0,  1.0, 0.75,   0.,   0./
19282       DATA (PARP(I),I=101,200)/
19283      & -0.02,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19284      1   2.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19285      2   0.4,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19286      3  0.01,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19287      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19288      5    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19289      6    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19290      7    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19291      8    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
19292      9    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0./
19293       DATA MSTI/200*0/
19294       DATA PARI/200*0./
19295       DATA MINT/400*0/
19296       DATA VINT/400*0./
19297
19298 C...Constants for the generation of the various processes.
19299       DATA (ISET(I),I=1,100)/
19300      &    1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,   -2,
19301      1    2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
19302      2   -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
19303      3    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
19304      4   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
19305      5   -1,   -1,    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
19306      6   -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,   -1,   -1,
19307      7    4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,   -2,
19308      8    2,    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19309      9    0,    0,    0,   -1,    0,    5,   -2,   -2,   -2,   -2/
19310       DATA (ISET(I),I=101,200)/
19311      &   -1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19312      1    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,   -2,
19313      2   -1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19314      3   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19315      4    1,    1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19316      5   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19317      6    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19318      7   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19319      8   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
19320      9   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2/
19321       DATA ((KFPR(I,J),J=1,2),I=1,50)/
19322      &   23,    0,   24,    0,   25,    0,   24,    0,   25,    0,
19323      &   24,    0,   23,    0,   25,    0,    0,    0,    0,    0,
19324      1    0,    0,    0,    0,   21,   21,   21,   22,   21,   23,
19325      1   21,   24,   21,   25,   22,   22,   22,   23,   22,   24,
19326      2   22,   25,   23,   23,   23,   24,   23,   25,   24,   24,
19327      2   24,   25,   25,   25,    0,   21,    0,   22,    0,   23,
19328      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
19329      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
19330      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
19331      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23/
19332       DATA ((KFPR(I,J),J=1,2),I=51,100)/
19333      5    0,   24,    0,   25,    0,    0,    0,    0,    0,    0,
19334      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19335      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19336      6    0,    0,    0,    0,   21,   21,   24,   24,   22,   24,
19337      7   23,   23,   24,   24,   23,   24,   23,   25,   22,   22,
19338      7   23,   23,   24,   24,   24,   25,   25,   25,    0,    0,
19339      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19340      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19341      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19342      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
19343       DATA ((KFPR(I,J),J=1,2),I=101,150)/
19344      &   23,    0,   25,    0,    0,    0,    0,    0,    0,    0,
19345      &    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19346      1   21,   25,    0,   25,   21,   25,   22,   22,   22,   23,
19347      1   23,   23,   24,   24,    0,    0,    0,    0,    0,    0,
19348      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19349      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19350      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19351      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19352      4   32,    0,   37,    0,   40,    0,    0,    0,    0,    0,
19353      4    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
19354       DATA ((KFPR(I,J),J=1,2),I=151,200)/
19355      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19356      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19357      6    0,   37,    0,    0,    0,    0,    0,    0,    0,    0,
19358      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19359      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19360      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19361      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19362      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19363      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19364      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
19365       DATA COEF/4000*0./
19366       DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
19367      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,
19368      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,
19369      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,
19370      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,
19371      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,
19372      6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
19373      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,
19374      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,
19375      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,
19376      & 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/
19377
19378 C...Character constants: name of processes.
19379       DATA PROC(0)/                    'All included subprocesses   '/
19380       DATA (PROC(I),I=1,20)/
19381      1'f + fb -> gamma*/Z0         ',  'f + fb'' -> W+/-             ',
19382      2'f + fb -> H0                ',  'gamma + W+/- -> W+/-        ',
19383      3'Z0 + Z0 -> H0               ',  'Z0 + W+/- -> W+/-           ',
19384      4'                            ',  'W+ + W- -> H0               ',
19385      5'                            ',  '                            ',
19386      6'f + f'' -> f + f''            ','f + fb -> f'' + fb''          ',
19387      7'f + fb -> g + g             ',  'f + fb -> g + gamma         ',
19388      8'f + fb -> g + Z0            ',  'f + fb'' -> g + W+/-         ',
19389      9'f + fb -> g + H0            ',  'f + fb -> gamma + gamma     ',
19390      &'f + fb -> gamma + Z0        ',  'f + fb'' -> gamma + W+/-     '/
19391       DATA (PROC(I),I=21,40)/
19392      1'f + fb -> gamma + H0        ',  'f + fb -> Z0 + Z0           ',
19393      2'f + fb'' -> Z0 + W+/-        ', 'f + fb -> Z0 + H0           ',
19394      3'f + fb -> W+ + W-           ',  'f + fb'' -> W+/- + H0        ',
19395      4'f + fb -> H0 + H0           ',  'f + g -> f + g              ',
19396      5'f + g -> f + gamma          ',  'f + g -> f + Z0             ',
19397      6'f + g -> f'' + W+/-          ', 'f + g -> f + H0             ',
19398      7'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',
19399      8'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ',
19400      9'f + gamma -> f + H0         ',  'f + Z0 -> f + g             ',
19401      &'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/
19402       DATA (PROC(I),I=41,60)/
19403      1'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + H0            ',
19404      2'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ',
19405      3'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ',
19406      4'f + W+/- -> f'' + H0         ', 'f + H0 -> f + g             ',
19407      5'f + H0 -> f + gamma         ',  'f + H0 -> f + Z0            ',
19408      6'f + H0 -> f'' + W+/-         ', 'f + H0 -> f + H0            ',
19409      7'g + g -> f + fb             ',  'g + gamma -> f + fb         ',
19410      8'g + Z0 -> f + fb            ',  'g + W+/- -> f + fb''         ',
19411      9'g + H0 -> f + fb            ',  'gamma + gamma -> f + fb     ',
19412      &'gamma + Z0 -> f + fb        ',  'gamma + W+/- -> f + fb''     '/
19413       DATA (PROC(I),I=61,80)/
19414      1'gamma + H0 -> f + fb        ',  'Z0 + Z0 -> f + fb           ',
19415      2'Z0 + W+/- -> f + fb''        ', 'Z0 + H0 -> f + fb           ',
19416      3'W+ + W- -> f + fb           ',  'W+/- + H0 -> f + fb''        ',
19417      4'H0 + H0 -> f + fb           ',  'g + g -> g + g              ',
19418      5'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> gamma + W+/-',
19419      6'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',
19420      7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + H0          ',
19421      8'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',
19422      9'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + H0 -> W+/- + H0      ',
19423      &'H0 + H0 -> H0 + H0          ',  '                            '/
19424       DATA (PROC(I),I=81,100)/
19425      1'q + qb -> Q + QB, massive   ',  'g + g -> Q + QB, massive    ',
19426      2'                            ',  '                            ',
19427      3'                            ',  '                            ',
19428      4'                            ',  '                            ',
19429      5'                            ',  '                            ',
19430      6'Elastic scattering          ',  'Single diffractive          ',
19431      7'Double diffractive          ',  'Central diffractive         ',
19432      8'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',
19433      9'                            ',  '                            ',
19434      &'                            ',  '                            '/
19435       DATA (PROC(I),I=101,120)/
19436      1'g + g -> gamma*/Z0          ',  'g + g -> H0                 ',
19437      2'                            ',  '                            ',
19438      3'                            ',  '                            ',
19439      4'                            ',  '                            ',
19440      5'                            ',  '                            ',
19441      6'f + fb -> g + H0            ',  'q + g -> q + H0             ',
19442      7'g + g -> g + H0             ',  'g + g -> gamma + gamma      ',
19443      8'g + g -> gamma + Z0         ',  'g + g -> Z0 + Z0            ',
19444      9'g + g -> W+ + W-            ',  '                            ',
19445      &'                            ',  '                            '/
19446       DATA (PROC(I),I=121,140)/
19447      1'g + g -> f + fb + H0        ',  '                            ',
19448      2'                            ',  '                            ',
19449      3'                            ',  '                            ',
19450      4'                            ',  '                            ',
19451      5'                            ',  '                            ',
19452      6'                            ',  '                            ',
19453      7'                            ',  '                            ',
19454      8'                            ',  '                            ',
19455      9'                            ',  '                            ',
19456      &'                            ',  '                            '/
19457       DATA (PROC(I),I=141,160)/
19458      1'f + fb -> gamma*/Z0/Z''0     ', 'f + fb'' -> H+/-             ',
19459      2'f + fb -> R                 ',  '                            ',
19460      3'                            ',  '                            ',
19461      4'                            ',  '                            ',
19462      5'                            ',  '                            ',
19463      6'                            ',  '                            ',
19464      7'                            ',  '                            ',
19465      8'                            ',  '                            ',
19466      9'                            ',  '                            ',
19467      &'                            ',  '                            '/
19468       DATA (PROC(I),I=161,180)/
19469      1'f + g -> f'' + H+/-          ', '                            ',
19470      2'                            ',  '                            ',
19471      3'                            ',  '                            ',
19472      4'                            ',  '                            ',
19473      5'                            ',  '                            ',
19474      6'                            ',  '                            ',
19475      7'                            ',  '                            ',
19476      8'                            ',  '                            ',
19477      9'                            ',  '                            ',
19478      &'                            ',  '                            '/
19479       DATA (PROC(I),I=181,200)/     20*'                            '/
19480
19481       END
19482
19483 C*********************************************************************
19484
19485       SUBROUTINE PYKCUT(MCUT)
19486
19487 C...Dummy routine, which the user can replace in order to make cuts on
19488 C...the kinematics on the parton level before the matrix elements are
19489 C...evaluated and the event is generated. The cross-section estimates
19490 C...will automatically take these cuts into account, so the given
19491 C...values are for the allowed phase space region only. MCUT=0 means
19492 C...that the event has passed the cuts, MCUT=1 that it has failed.
19493       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19494       SAVE /PYPARS/
19495
19496       MCUT=0
19497
19498       RETURN
19499       END
19500
19501 C*********************************************************************
19502
19503       SUBROUTINE PYSTFE(KF,X,Q2,XPQ)
19504
19505 C...This is a dummy routine, where the user can introduce an interface
19506 C...to his own external structure function parametrization.
19507 C...Arguments in:
19508 C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge
19509 C...    conjugation for pbar, nbar or pi- is performed by PYSTFU.
19510 C...X : x value.
19511 C...Q2 : Q^2 value.
19512 C...Arguments out:
19513 C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,
19514 C...    except that gluon is placed in 0. Thus XPQ(0) = xg,
19515 C...    XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar,
19516 C...    XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar,
19517 C...    XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar.
19518 C...
19519 C...One such interface, to the Diemos, Ferroni, Longo, Martinelli
19520 C...proton structure functions, already comes with the package. What
19521 C...the user needs here is external files with the three routines
19522 C...FXG160, FXG260 and FXG360 of the authors above, plus the
19523 C...interpolation routine FINT, which is part of the CERN library
19524 C...KERNLIB package. To avoid problems with unresolved external
19525 C...references, the external calls are commented in the current
19526 C...version. To enable this option, remove the C* at the beginning
19527 C...of the relevant lines.
19528 C...
19529 C...Alternatively, the routine can be used as an interface to the
19530 C...structure function evolution program of Tung. This can be achieved
19531 C...by removing C* at the beginning of some of the lines below.
19532       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19533       SAVE /LUDAT1/
19534       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
19535       SAVE /LUDAT2/
19536       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19537       SAVE /PYPARS/
19538       DIMENSION XPQ(-6:6),XFDFLM(9)
19539       CHARACTER CHDFLM(9)*5,HEADER*40
19540       DATA CHDFLM/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',
19541      &'CBAR ','BBAR ','TBAR '/
19542       DATA HEADER/'Tung evolution package has been invoked'/
19543       DATA INIT/0/
19544
19545 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
19546 C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95.
19547       IF(MSTP(51).GE.11.AND.MSTP(51).LE.13.AND.MSTP(52).LE.1) THEN
19548         XDFLM=MAX(0.51E-4,X)
19549         Q2DFLM=MAX(10.,MIN(1E8,Q2))
19550         IF(MSTP(52).EQ.0) Q2DFLM=10.
19551         DO 100 J=1,9
19552         IF(MSTP(52).EQ.1.AND.J.EQ.9) THEN
19553           Q2DFLM=Q2DFLM*(40./PMAS(6,1))**2
19554           Q2DFLM=MAX(10.,MIN(1E8,Q2))
19555         ENDIF
19556         XFDFLM(J)=0.
19557 C...Remove C* on following three lines to enable the DFLM options.
19558 C*      IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19559 C*      IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19560 C*      IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19561   100   CONTINUE
19562         IF(X.LT.0.51E-4.AND.ABS(PARP(51)-1.).GT.0.01) THEN
19563           CXS=(0.51E-4/X)**(PARP(51)-1.)
19564           DO 110 J=1,7
19565   110     XFDFLM(J)=XFDFLM(J)*CXS
19566         ENDIF
19567         XPQ(0)=XFDFLM(3)
19568         XPQ(1)=XFDFLM(2)+XFDFLM(5)
19569         XPQ(2)=XFDFLM(1)+XFDFLM(5)
19570         XPQ(3)=XFDFLM(6)
19571         XPQ(4)=XFDFLM(7)
19572         XPQ(5)=XFDFLM(8)
19573         XPQ(6)=XFDFLM(9)
19574         XPQ(-1)=XFDFLM(5)
19575         XPQ(-2)=XFDFLM(5)
19576         XPQ(-3)=XFDFLM(6)
19577         XPQ(-4)=XFDFLM(7)
19578         XPQ(-5)=XFDFLM(8)
19579         XPQ(-6)=XFDFLM(9)
19580
19581 C...Proton structure function evolution from Wu-Ki Tung: parton
19582 C...distribution functions incorporating heavy quark mass effects.
19583 C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.
19584       ELSE
19585         IF(INIT.EQ.0) THEN
19586           I1=0
19587           IF(MSTP(52).EQ.4) I1=1
19588           IHDRN=1
19589           NU=MSTP(53)
19590           I2=MSTP(51)
19591           IF(MSTP(51).GE.11) I2=MSTP(51)-3
19592           I3=0
19593           IF(MSTP(52).EQ.3) I3=1
19594
19595 C...Convert to Lambda in CWZ scheme (approximately linear relation).
19596           ALAM=0.75*PARP(1)
19597           TPMS=PMAS(6,1)
19598           QINI=PARP(52)
19599           QMAX=PARP(53)
19600           XMIN=PARP(54)
19601
19602 C...Initialize evolution (perform calculation or read results from
19603 C...file).
19604 C...Remove C* on following two lines to enable Tung initialization.
19605 C*        CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,
19606 C*   &    I2,I3,IRET,IRR)
19607           INIT=1
19608         ENDIF
19609
19610 C...Put into output array.
19611         Q=SQRT(Q2)
19612         DO 200 I=-6,6
19613         FIXQ=0.
19614 C...Remove C* on following line to enable structure function call.
19615 C*      FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR))
19616   200   XPQ(I)=X*FIXQ
19617
19618 C...Change order of u and d quarks from Tung to PYTHIA convention.
19619         XPS=XPQ(1)
19620         XPQ(1)=XPQ(2)
19621         XPQ(2)=XPS
19622         XPS=XPQ(-1)
19623         XPQ(-1)=XPQ(-2)
19624         XPQ(-2)=XPS
19625       ENDIF
19626
19627       RETURN
19628       END