HijingInterface/src/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       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0021       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0022       SAVE
0023
0024 C...Standard checks.
0025       MSTU(28)=0
0026       IF(MSTU(12).GE.1) CALL LULIST(0)
0027       IPA=MAX(1,IABS(IP))
0028       IF(IPA.GT.MSTU(4)) CALL LUERRM(21,
0029      &'(LU1ENT:) writing outside LUJETS memory')
0030       KC=LUCOMP(KF)
0031       IF(KC.EQ.0) CALL LUERRM(12,'(LU1ENT:) unknown flavour code')
0032
0033 C...Find mass. Reset K, P and V vectors.
0034       PM=0.
0035       IF(MSTU(10).EQ.1) PM=P(IPA,5)
0036       IF(MSTU(10).GE.2) PM=ULMASS(KF)
0037       DO 100 J=1,5
0038       K(IPA,J)=0
0039       P(IPA,J)=0.
0040   100 V(IPA,J)=0.
0041
0042 C...Store parton/particle in K and P vectors.
0043       K(IPA,1)=1
0044       IF(IP.LT.0) K(IPA,1)=2
0045       K(IPA,2)=KF
0046       P(IPA,5)=PM
0047       P(IPA,4)=MAX(PE,PM)
0048       PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
0049       P(IPA,1)=PA*SIN(THE)*COS(PHI)
0050       P(IPA,2)=PA*SIN(THE)*SIN(PHI)
0051       P(IPA,3)=PA*COS(THE)
0052
0053 C...Set N. Optionally fragment/decay.
0054       N=IPA
0055       IF(IP.EQ.0) CALL LUEXEC
0056
0057       RETURN
0058       END
0059
0060 C*********************************************************************
0061
0062       SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
0063
0064 C...Purpose: to store two partons/particles in their CM frame,
0065 C...with the first along the +z axis.
0066       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0067       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0068       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0069       SAVE
0070
0071 C...Standard checks.
0072       MSTU(28)=0
0073       IF(MSTU(12).GE.1) CALL LULIST(0)
0074       IPA=MAX(1,IABS(IP))
0075       IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
0076      &'(LU2ENT:) writing outside LUJETS memory')
0077       KC1=LUCOMP(KF1)
0078       KC2=LUCOMP(KF2)
0079       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
0080      &'(LU2ENT:) unknown flavour code')
0081
0082 C...Find masses. Reset K, P and V vectors.
0083       PM1=0.
0084       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
0085       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
0086       PM2=0.
0087       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
0088       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
0089       DO 100 I=IPA,IPA+1
0090       DO 100 J=1,5
0091       K(I,J)=0
0092       P(I,J)=0.
0093   100 V(I,J)=0.
0094
0095 C...Check flavours.
0096       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
0097       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
0098       IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
0099      &'(LU2ENT:) unphysical flavour combination')
0100       K(IPA,2)=KF1
0101       K(IPA+1,2)=KF2
0102
0103 C...Store partons/particles in K vectors for normal case.
0104       IF(IP.GE.0) THEN
0105         K(IPA,1)=1
0106         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
0107         K(IPA+1,1)=1
0108
0109 C...Store partons in K vectors for parton shower evolution.
0110       ELSE
0111         IF(KQ1.EQ.0.OR.KQ2.EQ.0) CALL LUERRM(2,
0112      &  '(LU2ENT:) requested flavours can not develop parton shower')
0113         K(IPA,1)=3
0114         K(IPA+1,1)=3
0115         K(IPA,4)=MSTU(5)*(IPA+1)
0116         K(IPA,5)=K(IPA,4)
0117         K(IPA+1,4)=MSTU(5)*IPA
0118         K(IPA+1,5)=K(IPA+1,4)
0119       ENDIF
0120
0121 C...Check kinematics and store partons/particles in P vectors.
0122       IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
0123      &'(LU2ENT:) energy smaller than sum of masses')
0124       PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
0125      &(2.*PECM)
0126       P(IPA,3)=PA
0127       P(IPA,4)=SQRT(PM1**2+PA**2)
0128       P(IPA,5)=PM1
0129       P(IPA+1,3)=-PA
0130       P(IPA+1,4)=SQRT(PM2**2+PA**2)
0131       P(IPA+1,5)=PM2
0132
0133 C...Set N. Optionally fragment/decay.
0134       N=IPA+1
0135       IF(IP.EQ.0) CALL LUEXEC
0136
0137       RETURN
0138       END
0139
0140 C*********************************************************************
0141
0142       SUBROUTINE LU3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
0143
0144 C...Purpose: to store three partons or particles in their CM frame,
0145 C...with the first along the +z axis and the third in the (x,z)
0146 C...plane with x > 0.
0147       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0148       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0149       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0150       SAVE
0151
0152 C...Standard checks.
0153       MSTU(28)=0
0154       IF(MSTU(12).GE.1) CALL LULIST(0)
0155       IPA=MAX(1,IABS(IP))
0156       IF(IPA.GT.MSTU(4)-2) CALL LUERRM(21,
0157      &'(LU3ENT:) writing outside LUJETS memory')
0158       KC1=LUCOMP(KF1)
0159       KC2=LUCOMP(KF2)
0160       KC3=LUCOMP(KF3)
0161       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LUERRM(12,
0162      &'(LU3ENT:) unknown flavour code')
0163
0164 C...Find masses. Reset K, P and V vectors.
0165       PM1=0.
0166       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
0167       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
0168       PM2=0.
0169       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
0170       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
0171       PM3=0.
0172       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
0173       IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
0174       DO 100 I=IPA,IPA+2
0175       DO 100 J=1,5
0176       K(I,J)=0
0177       P(I,J)=0.
0178   100 V(I,J)=0.
0179
0180 C...Check flavours.
0181       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
0182       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
0183       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
0184       IF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
0185       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.KQ1+KQ3.EQ.4))
0186      &THEN
0187       ELSE
0188         CALL LUERRM(2,'(LU3ENT:) unphysical flavour combination')
0189       ENDIF
0190       K(IPA,2)=KF1
0191       K(IPA+1,2)=KF2
0192       K(IPA+2,2)=KF3
0193
0194 C...Store partons/particles in K vectors for normal case.
0195       IF(IP.GE.0) THEN
0196         K(IPA,1)=1
0197         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
0198         K(IPA+1,1)=1
0199         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
0200         K(IPA+2,1)=1
0201
0202 C...Store partons in K vectors for parton shower evolution.
0203       ELSE
0204         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0) CALL LUERRM(2,
0205      &  '(LU3ENT:) requested flavours can not develop parton shower')
0206         K(IPA,1)=3
0207         K(IPA+1,1)=3
0208         K(IPA+2,1)=3
0209         KCS=4
0210         IF(KQ1.EQ.-1) KCS=5
0211         K(IPA,KCS)=MSTU(5)*(IPA+1)
0212         K(IPA,9-KCS)=MSTU(5)*(IPA+2)
0213         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
0214         K(IPA+1,9-KCS)=MSTU(5)*IPA
0215         K(IPA+2,KCS)=MSTU(5)*IPA
0216         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
0217       ENDIF
0218
0219 C...Check kinematics.
0220       MKERR=0
0221       IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.
0222      &0.5*X3*PECM.LE.PM3) MKERR=1
0223       PA1=SQRT(MAX(0.,(0.5*X1*PECM)**2-PM1**2))
0224       PA2=SQRT(MAX(0.,(0.5*(2.-X1-X3)*PECM)**2-PM2**2))
0225       PA3=SQRT(MAX(0.,(0.5*X3*PECM)**2-PM3**2))
0226       CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2)
0227       CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3)
0228       IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1
0229       CTHE3=MAX(-1.,MIN(1.,CTHE3))
0230       IF(MKERR.NE.0) CALL LUERRM(13,
0231      &'(LU3ENT:) unphysical kinematical variable setup')
0232
0233 C...Store partons/particles in P vectors.
0234       P(IPA,3)=PA1
0235       P(IPA,4)=SQRT(PA1**2+PM1**2)
0236       P(IPA,5)=PM1
0237       P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
0238       P(IPA+2,3)=PA3*CTHE3
0239       P(IPA+2,4)=SQRT(PA3**2+PM3**2)
0240       P(IPA+2,5)=PM3
0241       P(IPA+1,1)=-P(IPA+2,1)
0242       P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
0243       P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
0244       P(IPA+1,5)=PM2
0245
0246 C...Set N. Optionally fragment/decay.
0247       N=IPA+2
0248       IF(IP.EQ.0) CALL LUEXEC
0249
0250       RETURN
0251       END
0252
0253 C*********************************************************************
0254
0255       SUBROUTINE LU4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
0256
0257 C...Purpose: to store four partons or particles in their CM frame, with
0258 C...the first along the +z axis, the last in the xz plane with x > 0
0259 C...and the second having y < 0 and y > 0 with equal probability.
0260       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0261       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0262       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0263       SAVE
0264
0265 C...Standard checks.
0266       MSTU(28)=0
0267       IF(MSTU(12).GE.1) CALL LULIST(0)
0268       IPA=MAX(1,IABS(IP))
0269       IF(IPA.GT.MSTU(4)-3) CALL LUERRM(21,
0270      &'(LU4ENT:) writing outside LUJETS momory')
0271       KC1=LUCOMP(KF1)
0272       KC2=LUCOMP(KF2)
0273       KC3=LUCOMP(KF3)
0274       KC4=LUCOMP(KF4)
0275       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LUERRM(12,
0276      &'(LU4ENT:) unknown flavour code')
0277
0278 C...Find masses. Reset K, P and V vectors.
0279       PM1=0.
0280       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
0281       IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
0282       PM2=0.
0283       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
0284       IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
0285       PM3=0.
0286       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
0287       IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
0288       PM4=0.
0289       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
0290       IF(MSTU(10).GE.2) PM4=ULMASS(KF4)
0291       DO 100 I=IPA,IPA+3
0292       DO 100 J=1,5
0293       K(I,J)=0
0294       P(I,J)=0.
0295   100 V(I,J)=0.
0296
0297 C...Check flavours.
0298       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
0299       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
0300       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
0301       KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
0302       IF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
0303       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
0304      &KQ1+KQ4.EQ.4)) THEN
0305       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
0306      &THEN
0307       ELSE
0308         CALL LUERRM(2,'(LU4ENT:) unphysical flavour combination')
0309       ENDIF
0310       K(IPA,2)=KF1
0311       K(IPA+1,2)=KF2
0312       K(IPA+2,2)=KF3
0313       K(IPA+3,2)=KF4
0314
0315 C...Store partons/particles in K vectors for normal case.
0316       IF(IP.GE.0) THEN
0317         K(IPA,1)=1
0318         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
0319         K(IPA+1,1)=1
0320         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
0321      &  K(IPA+1,1)=2
0322         K(IPA+2,1)=1
0323         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
0324         K(IPA+3,1)=1
0325
0326 C...Store partons for parton shower evolution from q-g-g-qbar or
0327 C...g-g-g-g event.
0328       ELSEIF(KQ1+KQ2.NE.0) THEN
0329         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0.OR.KQ4.EQ.0) CALL LUERRM(2,
0330      &  '(LU4ENT:) requested flavours can not develop parton shower')
0331         K(IPA,1)=3
0332         K(IPA+1,1)=3
0333         K(IPA+2,1)=3
0334         K(IPA+3,1)=3
0335         KCS=4
0336         IF(KQ1.EQ.-1) KCS=5
0337         K(IPA,KCS)=MSTU(5)*(IPA+1)
0338         K(IPA,9-KCS)=MSTU(5)*(IPA+3)
0339         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
0340         K(IPA+1,9-KCS)=MSTU(5)*IPA
0341         K(IPA+2,KCS)=MSTU(5)*(IPA+3)
0342         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
0343         K(IPA+3,KCS)=MSTU(5)*IPA
0344         K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
0345
0346 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
0347       ELSE
0348         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0.OR.KQ4.EQ.0) CALL LUERRM(2,
0349      &  '(LU4ENT:) requested flavours can not develop parton shower')
0350         K(IPA,1)=3
0351         K(IPA+1,1)=3
0352         K(IPA+2,1)=3
0353         K(IPA+3,1)=3
0354         K(IPA,4)=MSTU(5)*(IPA+1)
0355         K(IPA,5)=K(IPA,4)
0356         K(IPA+1,4)=MSTU(5)*IPA
0357         K(IPA+1,5)=K(IPA+1,4)
0358         K(IPA+2,4)=MSTU(5)*(IPA+3)
0359         K(IPA+2,5)=K(IPA+2,4)
0360         K(IPA+3,4)=MSTU(5)*(IPA+2)
0361         K(IPA+3,5)=K(IPA+3,4)
0362       ENDIF
0363
0364 C...Check kinematics.
0365       MKERR=0
0366       IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)*
0367      &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1
0368       PA1=SQRT(MAX(0.,(0.5*X1*PECM)**2-PM1**2))
0369       PA2=SQRT(MAX(0.,(0.5*X2*PECM)**2-PM2**2))
0370       PA3=SQRT(MAX(0.,(0.5*(2.-X1-X2-X4)*PECM)**2-PM3**2))
0371       PA4=SQRT(MAX(0.,(0.5*X4*PECM)**2-PM4**2))
0372       X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
0373       CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4)
0374       IF(ABS(CTHE4).GE.1.002) MKERR=1
0375       CTHE4=MAX(-1.,MIN(1.,CTHE4))
0376       STHE4=SQRT(1.-CTHE4**2)
0377       CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2)
0378       IF(ABS(CTHE2).GE.1.002) MKERR=1
0379       CTHE2=MAX(-1.,MIN(1.,CTHE2))
0380       STHE2=SQRT(1.-CTHE2**2)
0381       CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/
0382      &(4.*PA2*STHE2*PA4*STHE4)
0383       IF(ABS(CPHI2).GE.1.05) MKERR=1
0384       CPHI2=MAX(-1.,MIN(1.,CPHI2))
0385       IF(MKERR.EQ.1) CALL LUERRM(13,
0386      &'(LU4ENT:) unphysical kinematical variable setup')
0387
0388 C...Store partons/particles in P vectors.
0389       P(IPA,3)=PA1
0390       P(IPA,4)=SQRT(PA1**2+PM1**2)
0391       P(IPA,5)=PM1
0392       P(IPA+3,1)=PA4*STHE4
0393       P(IPA+3,3)=PA4*CTHE4
0394       P(IPA+3,4)=SQRT(PA4**2+PM4**2)
0395       P(IPA+3,5)=PM4
0396       P(IPA+1,1)=PA2*STHE2*CPHI2
0397       P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLU(0)+0.5)
0398       P(IPA+1,3)=PA2*CTHE2
0399       P(IPA+1,4)=SQRT(PA2**2+PM2**2)
0400       P(IPA+1,5)=PM2
0401       P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
0402       P(IPA+2,2)=-P(IPA+1,2)
0403       P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
0404       P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
0405       P(IPA+2,5)=PM3
0406
0407 C...Set N. Optionally fragment/decay.
0408       N=IPA+3
0409       IF(IP.EQ.0) CALL LUEXEC
0410
0411       RETURN
0412       END
0413
0414 C*********************************************************************
0415
0416       SUBROUTINE LUJOIN(NJOIN,IJOIN)
0417
0418 C...Purpose: to connect a sequence of partons with colour flow indices,
0419 C...as required for subsequent shower evolution (or other operations).
0420       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0421       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0422       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0423       DIMENSION IJOIN(*)
0424       SAVE
0425
0426 C...Check that partons are of right types to be connected.
0427       IF(NJOIN.LT.2) GOTO 120
0428       KQSUM=0
0429       DO 100 IJN=1,NJOIN
0430       I=IJOIN(IJN)
0431       IF(I.LE.0.OR.I.GT.N) GOTO 120
0432       IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
0433       KC=LUCOMP(K(I,2))
0434       IF(KC.EQ.0) GOTO 120
0435       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
0436       IF(KQ.EQ.0) GOTO 120
0437       IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
0438       IF(KQ.NE.2) KQSUM=KQSUM+KQ
0439   100 IF(IJN.EQ.1) KQS=KQ
0440       IF(KQSUM.NE.0) GOTO 120
0441
0442 C...Connect the partons sequentially (closing for gluon loop).
0443       KCS=(9-KQS)/2
0444       IF(KQS.EQ.2) KCS=INT(4.5+RLU(0))
0445       DO 110 IJN=1,NJOIN
0446       I=IJOIN(IJN)
0447       K(I,1)=3
0448       IF(IJN.NE.1) IP=IJOIN(IJN-1)
0449       IF(IJN.EQ.1) IP=IJOIN(NJOIN)
0450       IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
0451       IF(IJN.EQ.NJOIN) IN=IJOIN(1)
0452       K(I,KCS)=MSTU(5)*IN
0453       K(I,9-KCS)=MSTU(5)*IP
0454       IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
0455   110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
0456
0457 C...Error exit: no action taken.
0458       RETURN
0459   120 CALL LUERRM(12,
0460      &'(LUJOIN:) given entries can not be joined by one string')
0461
0462       RETURN
0463       END
0464
0465 C*********************************************************************
0466
0467       SUBROUTINE LUGIVE(CHIN)
0468
0469 C...Purpose: to set values of commonblock variables.
0470       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0471       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0472       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0473       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0474       COMMON/LUDAT4/CHAF(500)
0475       CHARACTER CHAF*8
0476       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,
0477      &CHNAM*4,CHVAR(17)*4,CHALP(2)*26,CHIND*8,CHINI*10,CHINR*16
0478       SAVE
0479       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
0480      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/
0481       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
0482      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
0483
0484 C...Length of character variable. Subdivide it into instructions.
0485       IF(MSTU(12).GE.1) CALL LULIST(0)
0486       CHBIT=CHIN//' '
0487       LBIT=101
0488   100 LBIT=LBIT-1
0489       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
0490       LTOT=0
0491       DO 110 LCOM=1,LBIT
0492       IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
0493       LTOT=LTOT+1
0494       CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
0495   110 CONTINUE
0496       LLOW=0
0497   120 LHIG=LLOW+1
0498   130 LHIG=LHIG+1
0499       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
0500       LBIT=LHIG-LLOW-1
0501       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
0502
0503 C...Identify commonblock variable.
0504       LNAM=1
0505   140 LNAM=LNAM+1
0506       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
0507      &LNAM.LE.4) GOTO 140
0508       CHNAM=CHBIT(1:LNAM-1)//' '
0509       DO 150 LCOM=1,LNAM-1
0510       DO 150 LALP=1,26
0511   150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
0512      &CHALP(2)(LALP:LALP)
0513       IVAR=0
0514       DO 160 IV=1,17
0515   160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
0516       IF(IVAR.EQ.0) THEN
0517         CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
0518         LLOW=LHIG
0519         IF(LLOW.LT.LTOT) GOTO 120
0520         RETURN
0521       ENDIF
0522
0523 C...Identify any indices.
0524       I=0
0525       J=0
0526       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
0527         LIND=LNAM
0528   170   LIND=LIND+1
0529         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
0530         CHIND=' '
0531         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
0532      &  AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
0533           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
0534           READ(CHIND,'(I8)') I1
0535           I=LUCOMP(I1)
0536         ELSE
0537           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
0538           READ(CHIND,'(I8)') I
0539         ENDIF
0540         LNAM=LIND
0541         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
0542       ENDIF
0543       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
0544         LIND=LNAM
0545   180   LIND=LIND+1
0546         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
0547         CHIND=' '
0548         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
0549         READ(CHIND,'(I8)') J
0550         LNAM=LIND+1
0551       ENDIF
0552
0553 C...Check that indices allowed and save old value.
0554       IERR=1
0555       IF(CHBIT(LNAM:LNAM).NE.'=') GOTO 190
0556       IF(IVAR.EQ.1) THEN
0557         IF(I.NE.0.OR.J.NE.0) GOTO 190
0558         IOLD=N
0559       ELSEIF(IVAR.EQ.2) THEN
0560         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0561         IOLD=K(I,J)
0562       ELSEIF(IVAR.EQ.3) THEN
0563         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0564         ROLD=P(I,J)
0565       ELSEIF(IVAR.EQ.4) THEN
0566         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
0567         ROLD=V(I,J)
0568       ELSEIF(IVAR.EQ.5) THEN
0569         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0570         IOLD=MSTU(I)
0571       ELSEIF(IVAR.EQ.6) THEN
0572         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0573         ROLD=PARU(I)
0574       ELSEIF(IVAR.EQ.7) THEN
0575         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0576         IOLD=MSTJ(I)
0577       ELSEIF(IVAR.EQ.8) THEN
0578         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
0579         ROLD=PARJ(I)
0580       ELSEIF(IVAR.EQ.9) THEN
0581         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
0582         IOLD=KCHG(I,J)
0583       ELSEIF(IVAR.EQ.10) THEN
0584         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.4) GOTO 190
0585         ROLD=PMAS(I,J)
0586       ELSEIF(IVAR.EQ.11) THEN
0587         IF(I.LT.1.OR.I.GT.2000.OR.J.NE.0) GOTO 190
0588         ROLD=PARF(I)
0589       ELSEIF(IVAR.EQ.12) THEN
0590         IF(I.LT.1.OR.I.GT.4.OR.J.LT.1.OR.J.GT.4) GOTO 190
0591         ROLD=VCKM(I,J)
0592       ELSEIF(IVAR.EQ.13) THEN
0593         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
0594         IOLD=MDCY(I,J)
0595       ELSEIF(IVAR.EQ.14) THEN
0596         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.2) GOTO 190
0597         IOLD=MDME(I,J)
0598       ELSEIF(IVAR.EQ.15) THEN
0599         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.NE.0) GOTO 190
0600         ROLD=BRAT(I)
0601       ELSEIF(IVAR.EQ.16) THEN
0602         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.5) GOTO 190
0603         IOLD=KFDP(I,J)
0604       ELSEIF(IVAR.EQ.17) THEN
0605         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.NE.0) GOTO 190
0606         CHOLD=CHAF(I)
0607       ENDIF
0608       IERR=0
0609   190 IF(IERR.EQ.1) THEN
0610         CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
0611      &  CHBIT(1:LNAM-1))
0612         LLOW=LHIG
0613         IF(LLOW.LT.LTOT) GOTO 120
0614         RETURN
0615       ENDIF
0616
0617 C...Print current value of variable. Loop back.
0618       IF(LNAM.GE.LBIT) THEN
0619         CHBIT(LNAM:14)=' '
0620         CHBIT(15:60)=' has the value                                '
0621         IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0622      &  IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0623           WRITE(CHBIT(51:60),'(I10)') IOLD
0624         ELSEIF(IVAR.NE.17) THEN
0625           WRITE(CHBIT(47:60),'(F14.5)') ROLD
0626         ELSE
0627           CHBIT(53:60)=CHOLD
0628         ENDIF
0629         IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
0630         LLOW=LHIG
0631         IF(LLOW.LT.LTOT) GOTO 120
0632         RETURN
0633       ENDIF
0634
0635 C...Read in new variable value.
0636       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0637      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0638         CHINI=' '
0639         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
0640         READ(CHINI,'(I10)') INEW
0641       ELSEIF(IVAR.NE.17) THEN
0642         CHINR=' '
0643         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
0644         READ(CHINR,'(F16.2)') RNEW
0645       ELSE
0646         CHNEW=CHBIT(LNAM+1:LBIT)//' '
0647       ENDIF
0648
0649 C...Store new variable value.
0650       IF(IVAR.EQ.1) THEN
0651         N=INEW
0652       ELSEIF(IVAR.EQ.2) THEN
0653         K(I,J)=INEW
0654       ELSEIF(IVAR.EQ.3) THEN
0655         P(I,J)=RNEW
0656       ELSEIF(IVAR.EQ.4) THEN
0657         V(I,J)=RNEW
0658       ELSEIF(IVAR.EQ.5) THEN
0659         MSTU(I)=INEW
0660       ELSEIF(IVAR.EQ.6) THEN
0661         PARU(I)=RNEW
0662       ELSEIF(IVAR.EQ.7) THEN
0663         MSTJ(I)=INEW
0664       ELSEIF(IVAR.EQ.8) THEN
0665         PARJ(I)=RNEW
0666       ELSEIF(IVAR.EQ.9) THEN
0667         KCHG(I,J)=INEW
0668       ELSEIF(IVAR.EQ.10) THEN
0669         PMAS(I,J)=RNEW
0670       ELSEIF(IVAR.EQ.11) THEN
0671         PARF(I)=RNEW
0672       ELSEIF(IVAR.EQ.12) THEN
0673         VCKM(I,J)=RNEW
0674       ELSEIF(IVAR.EQ.13) THEN
0675         MDCY(I,J)=INEW
0676       ELSEIF(IVAR.EQ.14) THEN
0677         MDME(I,J)=INEW
0678       ELSEIF(IVAR.EQ.15) THEN
0679         BRAT(I)=RNEW
0680       ELSEIF(IVAR.EQ.16) THEN
0681         KFDP(I,J)=INEW
0682       ELSEIF(IVAR.EQ.17) THEN
0683         CHAF(I)=CHNEW
0684       ENDIF
0685
0686 C...Write old and new value. Loop back.
0687       CHBIT(LNAM:14)=' '
0688       CHBIT(15:60)=' changed from                to               '
0689       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
0690      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
0691         WRITE(CHBIT(33:42),'(I10)') IOLD
0692         WRITE(CHBIT(51:60),'(I10)') INEW
0693       ELSEIF(IVAR.NE.17) THEN
0694         WRITE(CHBIT(29:42),'(F14.5)') ROLD
0695         WRITE(CHBIT(47:60),'(F14.5)') RNEW
0696       ELSE
0697         CHBIT(35:42)=CHOLD
0698         CHBIT(53:60)=CHNEW
0699       ENDIF
0700       IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
0701       LLOW=LHIG
0702       IF(LLOW.LT.LTOT) GOTO 120
0703
0704 C...Format statement for output on unit MSTU(11) (by default 6).
0705  1000 FORMAT(5X,A60)
0706
0707       RETURN
0708       END
0709
0710 C*********************************************************************
0711
0712       SUBROUTINE LUEXEC
0713
0714 C...Purpose: to administrate the fragmentation and decay chain.
0715       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0716       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0717       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0718       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0719       DIMENSION PS(2,6)
0720       SAVE
0721
0722 C...Initialize and reset.
0723       MSTU(24)=0
0724       IF(MSTU(12).GE.1) CALL LULIST(0)
0725       MSTU(31)=MSTU(31)+1
0726       MSTU(1)=0
0727       MSTU(2)=0
0728       MSTU(3)=0
0729       MCONS=1
0730
0731 C...Sum up momentum, energy and charge for starting entries.
0732       NSAV=N
0733       DO 100 I=1,2
0734       DO 100 J=1,6
0735   100 PS(I,J)=0.
0736       DO 120 I=1,N
0737       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
0738       DO 110 J=1,4
0739   110 PS(1,J)=PS(1,J)+P(I,J)
0740       PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
0741   120 CONTINUE
0742       PARU(21)=PS(1,4)
0743
0744 C...Prepare system for subsequent fragmentation/decay.
0745       CALL LUPREP(0)
0746
0747 C...Loop through jet fragmentation and particle decays.
0748       MBE=0
0749   130 MBE=MBE+1
0750       IP=0
0751   140 IP=IP+1
0752       KC=0
0753       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
0754       IF(KC.EQ.0) THEN
0755
0756 C...Particle decay if unstable and allowed. Save long-lived particle
0757 C...decays until second pass after Bose-Einstein effects.
0758       ELSEIF(KCHG(KC,2).EQ.0) THEN
0759         IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.
0760      &  EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
0761      &  CALL LUDECY(IP)
0762
0763 C...Decay products may develop a shower.
0764         IF(MSTJ(92).GT.0) THEN
0765           IP1=MSTJ(92)
0766           QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
0767      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
0768           CALL LUSHOW(IP1,IP1+1,QMAX)
0769           CALL LUPREP(IP1)
0770           MSTJ(92)=0
0771         ELSEIF(MSTJ(92).LT.0) THEN
0772           IP1=-MSTJ(92)
0773           CALL LUSHOW(IP1,-3,P(IP,5))
0774           CALL LUPREP(IP1)
0775           MSTJ(92)=0
0776         ENDIF
0777
0778 C...Jet fragmentation: string or independent fragmentation.
0779       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
0780         MFRAG=MSTJ(1)
0781         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
0782         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
0783           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
0784      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
0785             IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
0786           ENDIF
0787         ENDIF
0788         IF(MFRAG.EQ.1) CALL LUSTRF(IP)
0789         IF(MFRAG.EQ.2) CALL LUINDF(IP)
0790         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
0791         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
0792       ENDIF
0793
0794 C...Loop back if enough space left in LUJETS and no error abort.
0795       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
0796       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
0797         GOTO 140
0798       ELSEIF(IP.LT.N) THEN
0799         CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')
0800       ENDIF
0801
0802 C...Include simple Bose-Einstein effect parametrization if desired.
0803       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
0804         CALL LUBOEI(NSAV)
0805         GOTO 130
0806       ENDIF
0807
0808 C...Check that momentum, energy and charge were conserved.
0809       DO 160 I=1,N
0810       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
0811       DO 150 J=1,4
0812   150 PS(2,J)=PS(2,J)+P(I,J)
0813       PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
0814   160 CONTINUE
0815       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
0816      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
0817       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
0818      &'(LUEXEC:) four-momentum was not conserved')
0819       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
0820      &'(LUEXEC:) charge was not conserved')
0821
0822       RETURN
0823       END
0824
0825 C*********************************************************************
0826
0827       SUBROUTINE LUPREP(IP)
0828
0829 C...Purpose: to rearrange partons along strings, to allow small systems
0830 C...to collapse into one or two particles and to check flavours.
0831       IMPLICIT DOUBLE PRECISION(D)
0832       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0833       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0834       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
0835       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
0836       DIMENSION DPS(5),DPC(5),UE(3)
0837       SAVE
0838
0839 C...Rearrange parton shower product listing along strings: begin loop.
0840       I1=N
0841       DO 130 MQGST=1,2
0842       DO 120 I=MAX(1,IP),N
0843       IF(K(I,1).NE.3) GOTO 120
0844       KC=LUCOMP(K(I,2))
0845       IF(KC.EQ.0) GOTO 120
0846       KQ=KCHG(KC,2)
0847       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
0848
0849 C...Pick up loose string end.
0850       KCS=4
0851       IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
0852       IA=I
0853       NSTP=0
0854   100 NSTP=NSTP+1
0855       IF(NSTP.GT.4*N) THEN
0856         CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
0857         RETURN
0858       ENDIF
0859
0860 C...Copy undecayed parton.
0861       IF(K(IA,1).EQ.3) THEN
0862         IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
0863           CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS')
0864           RETURN
0865         ENDIF
0866         I1=I1+1
0867         K(I1,1)=2
0868         IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
0869         K(I1,2)=K(IA,2)
0870         K(I1,3)=IA
0871         K(I1,4)=0
0872         K(I1,5)=0
0873         DO 110 J=1,5
0874         P(I1,J)=P(IA,J)
0875   110   V(I1,J)=V(IA,J)
0876         K(IA,1)=K(IA,1)+10
0877         IF(K(I1,1).EQ.1) GOTO 120
0878       ENDIF
0879
0880 C...Go to next parton in colour space.
0881       IB=IA
0882       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
0883      &NE.0) THEN
0884         IA=MOD(K(IB,KCS),MSTU(5))
0885         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
0886         MREV=0
0887       ELSE
0888         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
0889      &  EQ.0) KCS=9-KCS
0890         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
0891         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
0892         MREV=1
0893       ENDIF
0894       IF(IA.LE.0.OR.IA.GT.N) THEN
0895         CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
0896         RETURN
0897       ENDIF
0898       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
0899      &MSTU(5)).EQ.IB) THEN
0900         IF(MREV.EQ.1) KCS=9-KCS
0901         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
0902         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
0903       ELSE
0904         IF(MREV.EQ.0) KCS=9-KCS
0905         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
0906         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
0907       ENDIF
0908       IF(IA.NE.I) GOTO 100
0909       K(I1,1)=1
0910   120 CONTINUE
0911   130 CONTINUE
0912       N=I1
0913
0914 C...Find lowest-mass colour singlet jet system, OK if above threshold.
0915       IF(MSTJ(14).LE.0) GOTO 320
0916       NS=N
0917   140 NSIN=N-NS
0918       PDM=1.+PARJ(32)
0919       IC=0
0920       DO 190 I=MAX(1,IP),NS
0921       IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
0922       ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
0923         NSIN=NSIN+1
0924         IC=I
0925         DO 150 J=1,4
0926   150   DPS(J)=P(I,J)
0927         MSTJ(93)=1
0928         DPS(5)=ULMASS(K(I,2))
0929       ELSEIF(K(I,1).EQ.2) THEN
0930         DO 160 J=1,4
0931   160   DPS(J)=DPS(J)+P(I,J)
0932       ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
0933         DO 170 J=1,4
0934   170   DPS(J)=DPS(J)+P(I,J)
0935         MSTJ(93)=1
0936         DPS(5)=DPS(5)+ULMASS(K(I,2))
0937         PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)
0938         IF(PD.LT.PDM) THEN
0939           PDM=PD
0940           DO 180 J=1,5
0941   180     DPC(J)=DPS(J)
0942           IC1=IC
0943           IC2=I
0944         ENDIF
0945         IC=0
0946       ELSE
0947         NSIN=NSIN+1
0948       ENDIF
0949   190 CONTINUE
0950       IF(PDM.GE.PARJ(32)) GOTO 320
0951
0952 C...Fill small-mass system as cluster.
0953       NSAV=N
0954       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
0955       K(N+1,1)=11
0956       K(N+1,2)=91
0957       K(N+1,3)=IC1
0958       K(N+1,4)=N+2
0959       K(N+1,5)=N+3
0960       P(N+1,1)=DPC(1)
0961       P(N+1,2)=DPC(2)
0962       P(N+1,3)=DPC(3)
0963       P(N+1,4)=DPC(4)
0964       P(N+1,5)=PECM
0965
0966 C...Form two particles from flavours of lowest-mass system, if feasible.
0967       K(N+2,1)=1
0968       K(N+3,1)=1
0969       IF(MSTU(16).NE.2) THEN
0970         K(N+2,3)=N+1
0971         K(N+3,3)=N+1
0972       ELSE
0973         K(N+2,3)=IC1
0974         K(N+3,3)=IC2
0975       ENDIF
0976       K(N+2,4)=0
0977       K(N+3,4)=0
0978       K(N+2,5)=0
0979       K(N+3,5)=0
0980       IF(IABS(K(IC1,2)).NE.21) THEN
0981         KC1=LUCOMP(K(IC1,2))
0982         KC2=LUCOMP(K(IC2,2))
0983         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
0984         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
0985         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
0986         IF(KQ1+KQ2.NE.0) GOTO 320
0987   200   CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
0988         CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
0989         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
0990       ELSE
0991         IF(IABS(K(IC2,2)).NE.21) GOTO 320
0992   210   CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
0993         CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
0994         CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
0995         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
0996       ENDIF
0997       P(N+2,5)=ULMASS(K(N+2,2))
0998       P(N+3,5)=ULMASS(K(N+3,2))
0999       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
1000       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
1001
1002 C...Perform two-particle decay of jet system, if possible.
1003       IF(PECM.GE.0.02*DPC(4)) THEN
1004         PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
1005      &  (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
1006         UE(3)=2.*RLU(0)-1.
1007         PHI=PARU(2)*RLU(0)
1008         UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1009         UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1010         DO 220 J=1,3
1011         P(N+2,J)=PA*UE(J)
1012   220   P(N+3,J)=-PA*UE(J)
1013         P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
1014         P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
1015         CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1016      &  DPC(3)/DPC(4))
1017       ELSE
1018         NP=0
1019         DO 230 I=IC1,IC2
1020   230   IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1021         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1022      &  P(IC1,3)*P(IC2,3)
1023         IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
1024         HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
1025         HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
1026         HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
1027      &  (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
1028         HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
1029         HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
1030         HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
1031         DO 240 J=1,4
1032         P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
1033   240   P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
1034       ENDIF
1035       DO 250 J=1,4
1036       V(N+1,J)=V(IC1,J)
1037       V(N+2,J)=V(IC1,J)
1038   250 V(N+3,J)=V(IC2,J)
1039       V(N+1,5)=0.
1040       V(N+2,5)=0.
1041       V(N+3,5)=0.
1042       N=N+3
1043       GOTO 300
1044
1045 C...Else form one particle from the flavours available, if possible.
1046   260 K(N+1,5)=N+2
1047       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1048         GOTO 320
1049       ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1050         CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1051       ELSE
1052         KFLN=1+INT((2.+PARJ(2))*RLU(0))
1053         CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1054       ENDIF
1055       IF(K(N+2,2).EQ.0) GOTO 260
1056       P(N+2,5)=ULMASS(K(N+2,2))
1057
1058 C...Find parton/particle which combines to largest extra mass.
1059       IR=0
1060       HA=0.
1061       DO 280 MCOMB=1,3
1062       IF(IR.NE.0) GOTO 280
1063       DO 270 I=MAX(1,IP),N
1064       IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
1065      &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
1066       IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
1067       IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
1068       IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
1069       IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
1070      &GOTO 270
1071       HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
1072       IF(HCR.GT.HA) THEN
1073         IR=I
1074         HA=HCR
1075       ENDIF
1076   270 CONTINUE
1077   280 CONTINUE
1078
1079 C...Shuffle energy and momentum to put new particle on mass shell.
1080       HB=PECM**2+HA
1081       HC=P(N+2,5)**2+HA
1082       HD=P(IR,5)**2+HA
1083 C******************CHANGES BY HIJING************
1084       HK2=0.0
1085       IF(HA**2-(PECM*P(IR,5))**2.EQ.0.0.OR.HB+HD.EQ.0.0) GO TO 285
1086 C******************
1087       HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
1088      &(HA**2-(PECM*P(IR,5))**2))-(HB+HC))/(HB+HD)
1089   285 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
1090       DO 290 J=1,4
1091       P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)
1092       P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)
1093       V(N+1,J)=V(IC1,J)
1094   290 V(N+2,J)=V(IC1,J)
1095       V(N+1,5)=0.
1096       V(N+2,5)=0.
1097       N=N+2
1098
1099 C...Mark collapsed system and store daughter pointers. Iterate.
1100   300 DO 310 I=IC1,IC2
1101       IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
1102      &THEN
1103         K(I,1)=K(I,1)+10
1104         IF(MSTU(16).NE.2) THEN
1105           K(I,4)=NSAV+1
1106           K(I,5)=NSAV+1
1107         ELSE
1108           K(I,4)=NSAV+2
1109           K(I,5)=N
1110         ENDIF
1111       ENDIF
1112   310 CONTINUE
1113       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1114
1115 C...Check flavours and invariant masses in parton systems.
1116   320 NP=0
1117       KFN=0
1118       KQS=0
1119       DO 330 J=1,5
1120   330 DPS(J)=0.
1121       DO 360 I=MAX(1,IP),N
1122       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
1123       KC=LUCOMP(K(I,2))
1124       IF(KC.EQ.0) GOTO 360
1125       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1126       IF(KQ.EQ.0) GOTO 360
1127       NP=NP+1
1128       IF(KQ.NE.2) THEN
1129         KFN=KFN+1
1130         KQS=KQS+KQ
1131         MSTJ(93)=1
1132         DPS(5)=DPS(5)+ULMASS(K(I,2))
1133       ENDIF
1134       DO 340 J=1,4
1135   340 DPS(J)=DPS(J)+P(I,J)
1136       IF(K(I,1).EQ.1) THEN
1137         IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
1138      &  LUERRM(2,'(LUPREP:) unphysical flavour combination')
1139         IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
1140      &  (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,
1141      &  '(LUPREP:) too small mass in jet system')
1142         NP=0
1143         KFN=0
1144         KQS=0
1145         DO 350 J=1,5
1146   350   DPS(J)=0.
1147       ENDIF
1148   360 CONTINUE
1149
1150       RETURN
1151       END
1152
1153 C*********************************************************************
1154
1155       SUBROUTINE LUSTRF(IP)
1156 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1157 C...jet system according to the Lund string fragmentation model.
1158       IMPLICIT DOUBLE PRECISION(D)
1159       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
1160       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1161       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1162       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
1163      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
1164      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5)
1165       SAVE
1166
1167 C...Function: four-product of two vectors.
1168       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)
1169       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
1170      &DP(I,3)*DP(J,3)
1171
1172 C...Reset counters. Identify parton system.
1173       MSTJ(91)=0
1174       NSAV=N
1175       NP=0
1176       KQSUM=0
1177       DO 100 J=1,5
1178   100 DPS(J)=0.
1179       MJU(1)=0
1180       MJU(2)=0
1181       I=IP-1
1182   110 I=I+1
1183       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1184         CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
1185         IF(MSTU(21).GE.1) RETURN
1186       ENDIF
1187       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1188       KC=LUCOMP(K(I,2))
1189       IF(KC.EQ.0) GOTO 110
1190       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1191       IF(KQ.EQ.0) GOTO 110
1192       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
1193         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1194         IF(MSTU(21).GE.1) RETURN
1195       ENDIF
1196
1197 C...Take copy of partons to be considered. Check flavour sum.
1198       NP=NP+1
1199       DO 120 J=1,5
1200       K(N+NP,J)=K(I,J)
1201       P(N+NP,J)=P(I,J)
1202   120 DPS(J)=DPS(J)+P(I,J)
1203       K(N+NP,3)=I
1204       IF(P(N+NP,4)**2.LT.P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2) THEN
1205         P(N+NP,4)=SQRT(P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2+
1206      &  P(N+NP,5)**2)
1207         DPS(4)=DPS(4)+MAX(0.,P(N+NP,4)-P(I,4))
1208       ENDIF
1209       IF(KQ.NE.2) KQSUM=KQSUM+KQ
1210       IF(K(I,1).EQ.41) THEN
1211         KQSUM=KQSUM+2*KQ
1212         IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1213         IF(KQSUM.NE.KQ) MJU(2)=N+NP
1214       ENDIF
1215       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1216       IF(KQSUM.NE.0) THEN
1217         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1218         IF(MSTU(21).GE.1) RETURN
1219       ENDIF
1220
1221 C...Boost copied system to CM frame (for better numerical precision).
1222       CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1223      &-DPS(3)/DPS(4))
1224
1225 C...Search for very nearby partons that may be recombined.
1226       NTRYR=0
1227       PARU12=PARU(12)
1228       PARU13=PARU(13)
1229       MJU(3)=MJU(1)
1230       MJU(4)=MJU(2)
1231       NR=NP
1232   130 IF(NR.GE.3) THEN
1233         PDRMIN=2.*PARU12
1234         DO 140 I=N+1,N+NR
1235         IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 140
1236         I1=I+1
1237         IF(I.EQ.N+NR) I1=N+1
1238         IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 140
1239         IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
1240      &  GOTO 140
1241         IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 140
1242         PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
1243      &  P(I1,2)**2+P(I1,3)**2))
1244         PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
1245         PDR=4.*(PAP-PVP)**2/(PARU13**2*PAP+2.*(PAP-PVP))
1246         IF(PDR.LT.PDRMIN) THEN
1247           IR=I
1248           PDRMIN=PDR
1249         ENDIF
1250   140   CONTINUE
1251
1252 C...Recombine very nearby partons to avoid machine precision problems.
1253         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1254           DO 150 J=1,4
1255   150     P(N+1,J)=P(N+1,J)+P(N+NR,J)
1256           P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1257      &    P(N+1,3)**2))
1258           NR=NR-1
1259           GOTO 130
1260         ELSEIF(PDRMIN.LT.PARU12) THEN
1261           DO 160 J=1,4
1262   160     P(IR,J)=P(IR,J)+P(IR+1,J)
1263           P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1264      &    P(IR,3)**2))
1265           DO 170 I=IR+1,N+NR-1
1266           K(I,2)=K(I+1,2)
1267           DO 170 J=1,5
1268   170     P(I,J)=P(I+1,J)
1269           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1270           NR=NR-1
1271           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1272           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1273           GOTO 130
1274         ENDIF
1275       ENDIF
1276       NTRYR=NTRYR+1
1277
1278 C...Reset particle counter. Skip ahead if no junctions are present;
1279 C...this is usually the case!
1280       NRS=MAX(5*NR+11,NP)
1281       NTRY=0
1282   180 NTRY=NTRY+1
1283       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1284         PARU12=4.*PARU12
1285         PARU13=2.*PARU13
1286         GOTO 130
1287       ELSEIF(NTRY.GT.100) THEN
1288         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1289         IF(MSTU(21).GE.1) RETURN
1290       ENDIF
1291       I=N+NRS
1292       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 500
1293       DO 490 JT=1,2
1294       NJS(JT)=0
1295       IF(MJU(JT).EQ.0) GOTO 490
1296       JS=3-2*JT
1297
1298 C...Find and sum up momentum on three sides of junction. Check flavours.
1299       DO 190 IU=1,3
1300       IJU(IU)=0
1301       DO 190 J=1,5
1302   190 PJU(IU,J)=0.
1303       IU=0
1304       DO 200 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
1305       IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1306         IU=IU+1
1307         IJU(IU)=I1
1308       ENDIF
1309       DO 200 J=1,4
1310   200 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1311       DO 210 IU=1,3
1312   210 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1313       IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1314      &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1315         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1316         IF(MSTU(21).GE.1) RETURN
1317       ENDIF
1318
1319 C...Calculate (approximate) boost to rest frame of junction.
1320       T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1321      &(PJU(1,5)*PJU(2,5))
1322       T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1323      &(PJU(1,5)*PJU(3,5))
1324       T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1325      &(PJU(2,5)*PJU(3,5))
1326       T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1327       T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1328       TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1329       T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1330       T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1331       DO 220 J=1,3
1332   220 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1333       TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1334       DO 230 IU=1,3
1335   230 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1336      &TJU(3)*PJU(IU,3)
1337
1338 C...Put junction at rest if motion could give inconsistencies.
1339       IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1340         DO 240 J=1,3
1341   240   TJU(J)=0.
1342         TJU(4)=1.
1343         PJU(1,5)=PJU(1,4)
1344         PJU(2,5)=PJU(2,4)
1345         PJU(3,5)=PJU(3,4)
1346       ENDIF
1347
1348 C...Start preparing for fragmentation of two strings from junction.
1349       ISTA=I
1350       DO 470 IU=1,2
1351       NS=IJU(IU+1)-IJU(IU)
1352
1353 C...Junction strings: find longitudinal string directions.
1354       DO 260 IS=1,NS
1355       IS1=IJU(IU)+IS-1
1356       IS2=IJU(IU)+IS
1357       DO 250 J=1,5
1358       DP(1,J)=0.5*P(IS1,J)
1359       IF(IS.EQ.1) DP(1,J)=P(IS1,J)
1360       DP(2,J)=0.5*P(IS2,J)
1361   250 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
1362       IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1363       IF(IS.EQ.NS) DP(2,5)=0.
1364       DP(3,5)=DFOUR(1,1)
1365       DP(4,5)=DFOUR(2,2)
1366       DHKC=DFOUR(1,2)
1367       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1368         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1369         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1370         DP(3,5)=0D0
1371         DP(4,5)=0D0
1372         DHKC=DFOUR(1,2)
1373       ENDIF
1374       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1375       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1376       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1377       IN1=N+NR+4*IS-3
1378       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1379       DO 260 J=1,4
1380       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1381   260 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1382
1383 C...Junction strings: initialize flavour, momentum and starting pos.
1384       ISAV=I
1385   270 NTRY=NTRY+1
1386       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1387         PARU12=4.*PARU12
1388         PARU13=2.*PARU13
1389         GOTO 130
1390       ELSEIF(NTRY.GT.100) THEN
1391         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1392         IF(MSTU(21).GE.1) RETURN
1393       ENDIF
1394       I=ISAV
1395       IRANKJ=0
1396       IE(1)=K(N+1+(JT/2)*(NP-1),3)
1397       IN(4)=N+NR+1
1398       IN(5)=IN(4)+1
1399       IN(6)=N+NR+4*NS+1
1400       DO 280 JQ=1,2
1401       DO 280 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1402       P(IN1,1)=2-JQ
1403       P(IN1,2)=JQ-1
1404   280 P(IN1,3)=1.
1405       KFL(1)=K(IJU(IU),2)
1406       PX(1)=0.
1407       PY(1)=0.
1408       GAM(1)=0.
1409       DO 290 J=1,5
1410   290 PJU(IU+3,J)=0.
1411
1412 C...Junction strings: find initial transverse directions.
1413       DO 300 J=1,4
1414       DP(1,J)=P(IN(4),J)
1415       DP(2,J)=P(IN(4)+1,J)
1416       DP(3,J)=0.
1417   300 DP(4,J)=0.
1418       DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1419       DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1420       DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1421       DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1422       DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1423       IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1424       IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1425       IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1426       IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1427       DHC12=DFOUR(1,2)
1428       DHCX1=DFOUR(3,1)/DHC12
1429       DHCX2=DFOUR(3,2)/DHC12
1430       DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1431       DHCY1=DFOUR(4,1)/DHC12
1432       DHCY2=DFOUR(4,2)/DHC12
1433       DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1434       DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1435       DO 310 J=1,4
1436       DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1437       P(IN(6),J)=DP(3,J)
1438   310 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1439      &DHCYX*DP(3,J))
1440
1441 C...Junction strings: produce new particle, origin.
1442   320 I=I+1
1443       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1444         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1445         IF(MSTU(21).GE.1) RETURN
1446       ENDIF
1447       IRANKJ=IRANKJ+1
1448       K(I,1)=1
1449       K(I,3)=IE(1)
1450       K(I,4)=0
1451       K(I,5)=0
1452
1453 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1454   330 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1455       IF(K(I,2).EQ.0) GOTO 270
1456       IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1457      &IABS(KFL(3)).GT.10) THEN
1458         IF(RLU(0).GT.PARJ(19)) GOTO 330
1459       ENDIF
1460       P(I,5)=ULMASS(K(I,2))
1461       CALL LUPTDI(KFL(1),PX(3),PY(3))
1462       PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1463       CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1464       GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1465       DO 340 J=1,3
1466   340 IN(J)=IN(3+J)
1467
1468 C...Junction strings: stepping within or from 'low' string region easy.
1469       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1470      &P(IN(1),5)**2.GE.PR(1)) THEN
1471         P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1472         P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1473         DO 350 J=1,4
1474   350   P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1475         GOTO 420
1476       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1477         P(IN(2)+2,4)=P(IN(2)+2,3)
1478         P(IN(2)+2,1)=1.
1479         IN(2)=IN(2)+4
1480         IF(IN(2).GT.N+NR+4*NS) GOTO 270
1481         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1482           P(IN(1)+2,4)=P(IN(1)+2,3)
1483           P(IN(1)+2,1)=0.
1484           IN(1)=IN(1)+4
1485         ENDIF
1486       ENDIF
1487
1488 C...Junction strings: find new transverse directions.
1489   360 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1490      &IN(1).GT.IN(2)) GOTO 270
1491       IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1492         DO 370 J=1,4
1493         DP(1,J)=P(IN(1),J)
1494         DP(2,J)=P(IN(2),J)
1495         DP(3,J)=0.
1496   370   DP(4,J)=0.
1497         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1498         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1499         DHC12=DFOUR(1,2)
1500         IF(DHC12.LE.1E-2) THEN
1501           P(IN(1)+2,4)=P(IN(1)+2,3)
1502           P(IN(1)+2,1)=0.
1503           IN(1)=IN(1)+4
1504           GOTO 360
1505         ENDIF
1506         IN(3)=N+NR+4*NS+5
1507         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1508         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1509         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1510         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1511         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1512         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1513         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1514         DHCX1=DFOUR(3,1)/DHC12
1515         DHCX2=DFOUR(3,2)/DHC12
1516         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1517         DHCY1=DFOUR(4,1)/DHC12
1518         DHCY2=DFOUR(4,2)/DHC12
1519         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1520         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1521         DO 380 J=1,4
1522         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1523         P(IN(3),J)=DP(3,J)
1524   380   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1525      &  DHCYX*DP(3,J))
1526 C...Express pT with respect to new axes, if sensible.
1527         PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1528         PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1529         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1530           PX(3)=PXP
1531           PY(3)=PYP
1532         ENDIF
1533       ENDIF
1534
1535 C...Junction strings: sum up known four-momentum, coefficients for m2.
1536       DO 400 J=1,4
1537       DHG(J)=0.
1538       P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1539      &PY(3)*P(IN(3)+1,J)
1540       DO 390 IN1=IN(4),IN(1)-4,4
1541   390 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1542       DO 400 IN2=IN(5),IN(2)-4,4
1543   400 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1544       DHM(1)=FOUR(I,I)
1545       DHM(2)=2.*FOUR(I,IN(1))
1546       DHM(3)=2.*FOUR(I,IN(2))
1547       DHM(4)=2.*FOUR(IN(1),IN(2))
1548
1549 C...Junction strings: find coefficients for Gamma expression.
1550       DO 410 IN2=IN(1)+1,IN(2),4
1551       DO 410 IN1=IN(1),IN2-1,4
1552       DHC=2.*FOUR(IN1,IN2)
1553       DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
1554       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
1555       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
1556   410 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1557
1558 C...Junction strings: solve (m2, Gamma) equation system for energies.
1559       DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1560       IF(ABS(DHS1).LT.1E-4) GOTO 270
1561       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1562      &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
1563       DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
1564       P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1565      &DHS2/DHS1)
1566       IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 270
1567       P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
1568      &(DHM(2)+DHM(4)*P(IN(2)+2,4))
1569
1570 C...Junction strings: step to new region if necessary.
1571       IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1572         P(IN(2)+2,4)=P(IN(2)+2,3)
1573         P(IN(2)+2,1)=1.
1574         IN(2)=IN(2)+4
1575         IF(IN(2).GT.N+NR+4*NS) GOTO 270
1576         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1577           P(IN(1)+2,4)=P(IN(1)+2,3)
1578           P(IN(1)+2,1)=0.
1579           IN(1)=IN(1)+4
1580         ENDIF
1581         GOTO 360
1582       ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1583         P(IN(1)+2,4)=P(IN(1)+2,3)
1584         P(IN(1)+2,1)=0.
1585         IN(1)=IN(1)+JS
1586         GOTO 710
1587       ENDIF
1588
1589 C...Junction strings: particle four-momentum, remainder, loop back.
1590   420 DO 430 J=1,4
1591       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1592   430 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1593       IF(P(I,4).LE.0.) GOTO 270
1594       PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1595      &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1596       IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1597         KFL(1)=-KFL(3)
1598         PX(1)=-PX(3)
1599         PY(1)=-PY(3)
1600         GAM(1)=GAM(3)
1601         IF(IN(3).NE.IN(6)) THEN
1602           DO 440 J=1,4
1603           P(IN(6),J)=P(IN(3),J)
1604   440     P(IN(6)+1,J)=P(IN(3)+1,J)
1605         ENDIF
1606         DO 450 JQ=1,2
1607         IN(3+JQ)=IN(JQ)
1608         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1609   450   P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1610         GOTO 320
1611       ENDIF
1612
1613 C...Junction strings: save quantities left after each string.
1614       IF(IABS(KFL(1)).GT.10) GOTO 270
1615       I=I-1
1616       KFJH(IU)=KFL(1)
1617       DO 460 J=1,4
1618   460 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1619   470 CONTINUE
1620
1621 C...Junction strings: put together to new effective string endpoint.
1622       NJS(JT)=I-ISTA
1623       KFJS(JT)=K(K(MJU(JT+2),3),2)
1624       KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1625       IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1626       IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1627      &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1628      &KFLS,KFJH(1))
1629       DO 480 J=1,4
1630       PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1631   480 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1632       PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1633      &PJS(JT,3)**2))
1634   490 CONTINUE
1635
1636 C...Open versus closed strings. Choose breakup region for latter.
1637   500 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1638         NS=MJU(2)-MJU(1)
1639         NB=MJU(1)-N
1640       ELSEIF(MJU(1).NE.0) THEN
1641         NS=N+NR-MJU(1)
1642         NB=MJU(1)-N
1643       ELSEIF(MJU(2).NE.0) THEN
1644         NS=MJU(2)-N
1645         NB=1
1646       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1647         NS=NR-1
1648         NB=1
1649       ELSE
1650         NS=NR+1
1651         W2SUM=0.
1652         DO 510 IS=1,NR
1653         P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1654   510   W2SUM=W2SUM+P(N+NR+IS,1)
1655         W2RAN=RLU(0)*W2SUM
1656         NB=0
1657   520   NB=NB+1
1658         W2SUM=W2SUM-P(N+NR+NB,1)
1659         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 520
1660       ENDIF
1661
1662 C...Find longitudinal string directions (i.e. lightlike four-vectors).
1663       DO 540 IS=1,NS
1664       IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1665       IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1666       DO 530 J=1,5
1667       DP(1,J)=P(IS1,J)
1668       IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)
1669       IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
1670       DP(2,J)=P(IS2,J)
1671       IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)
1672   530 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
1673       DP(3,5)=DFOUR(1,1)
1674       DP(4,5)=DFOUR(2,2)
1675       DHKC=DFOUR(1,2)
1676       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1677         DP(3,5)=DP(1,5)**2
1678         DP(4,5)=DP(2,5)**2
1679         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1680         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1681         DHKC=DFOUR(1,2)
1682       ENDIF
1683       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1684       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1685       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1686       IN1=N+NR+4*IS-3
1687       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1688       DO 540 J=1,4
1689       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1690   540 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1691
1692 C...Begin initialization: sum up energy, set starting position.
1693       ISAV=I
1694   550 NTRY=NTRY+1
1695       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1696         PARU12=4.*PARU12
1697         PARU13=2.*PARU13
1698         GOTO 130
1699       ELSEIF(NTRY.GT.100) THEN
1700         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1701         IF(MSTU(21).GE.1) RETURN
1702       ENDIF
1703       I=ISAV
1704       DO 560 J=1,4
1705       P(N+NRS,J)=0.
1706       DO 560 IS=1,NR
1707   560 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1708       DO 570 JT=1,2
1709       IRANK(JT)=0
1710       IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1711       IF(NS.GT.NR) IRANK(JT)=1
1712       IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1713       IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1714       IN(3*JT+2)=IN(3*JT+1)+1
1715       IN(3*JT+3)=N+NR+4*NS+2*JT-1
1716       DO 570 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1717       P(IN1,1)=2-JT
1718       P(IN1,2)=JT-1
1719   570 P(IN1,3)=1.
1720
1721 C...Initialize flavour and pT variables for open string.
1722       IF(NS.LT.NR) THEN
1723         PX(1)=0.
1724         PY(1)=0.
1725         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1726         PX(2)=-PX(1)
1727         PY(2)=-PY(1)
1728         DO 580 JT=1,2
1729         KFL(JT)=K(IE(JT),2)
1730         IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1731         MSTJ(93)=1
1732         PMQ(JT)=ULMASS(KFL(JT))
1733   580   GAM(JT)=0.
1734
1735 C...Closed string: random initial breakup flavour, pT and vertex.
1736       ELSE
1737         KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1738         CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
1739         KFL(2)=-KFL(1)
1740         IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
1741           KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
1742         ELSEIF(IABS(KFL(1)).GT.10) THEN
1743           KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
1744         ENDIF
1745         CALL LUPTDI(KFL(1),PX(1),PY(1))
1746         PX(2)=-PX(1)
1747         PY(2)=-PY(1)
1748         PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
1749   590   CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
1750         ZR=PR3/(Z*P(N+NR+1,5)**2)
1751         IF(ZR.GE.1.) GOTO 590
1752         DO 600 JT=1,2
1753         MSTJ(93)=1
1754         PMQ(JT)=ULMASS(KFL(JT))
1755         GAM(JT)=PR3*(1.-Z)/Z
1756         IN1=N+NR+3+4*(JT/2)*(NS-1)
1757         P(IN1,JT)=1.-Z
1758         P(IN1,3-JT)=JT-1
1759         P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
1760         P(IN1+1,JT)=ZR
1761         P(IN1+1,3-JT)=2-JT
1762   600   P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
1763       ENDIF
1764
1765 C...Find initial transverse directions (i.e. spacelike four-vectors).
1766       DO 640 JT=1,2
1767       IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
1768         IN1=IN(3*JT+1)
1769         IN3=IN(3*JT+3)
1770         DO 610 J=1,4
1771         DP(1,J)=P(IN1,J)
1772         DP(2,J)=P(IN1+1,J)
1773         DP(3,J)=0.
1774   610   DP(4,J)=0.
1775         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1776         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1777         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1778         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1779         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1780         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1781         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1782         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1783         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1784         DHC12=DFOUR(1,2)
1785         DHCX1=DFOUR(3,1)/DHC12
1786         DHCX2=DFOUR(3,2)/DHC12
1787         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1788         DHCY1=DFOUR(4,1)/DHC12
1789         DHCY2=DFOUR(4,2)/DHC12
1790         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1791         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1792         DO 620 J=1,4
1793         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1794         P(IN3,J)=DP(3,J)
1795   620   P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1796      &  DHCYX*DP(3,J))
1797       ELSE
1798         DO 630 J=1,4
1799         P(IN3+2,J)=P(IN3,J)
1800   630   P(IN3+3,J)=P(IN3+1,J)
1801       ENDIF
1802   640 CONTINUE
1803
1804 C...Remove energy used up in junction string fragmentation.
1805       IF(MJU(1)+MJU(2).GT.0) THEN
1806         DO 660 JT=1,2
1807         IF(NJS(JT).EQ.0) GOTO 660
1808         DO 650 J=1,4
1809   650   P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
1810   660   CONTINUE
1811       ENDIF
1812
1813 C...Produce new particle: side, origin.
1814   670 I=I+1
1815       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1816         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1817         IF(MSTU(21).GE.1) RETURN
1818       ENDIF
1819       JT=1.5+RLU(0)
1820       IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
1821       JR=3-JT
1822       JS=3-2*JT
1823       IRANK(JT)=IRANK(JT)+1
1824       K(I,1)=1
1825       K(I,3)=IE(JT)
1826       K(I,4)=0
1827       K(I,5)=0
1828
1829 C...Generate flavour, hadron and pT.
1830   680 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
1831       IF(K(I,2).EQ.0) GOTO 550
1832       IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
1833      &IABS(KFL(3)).GT.10) THEN
1834         IF(RLU(0).GT.PARJ(19)) GOTO 680
1835       ENDIF
1836       P(I,5)=ULMASS(K(I,2))
1837       CALL LUPTDI(KFL(JT),PX(3),PY(3))
1838       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
1839
1840 C...Final hadrons for small invariant mass.
1841       MSTJ(93)=1
1842       PMQ(3)=ULMASS(KFL(3))
1843       WMIN=PARJ(32+MSTJ(11))+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
1844       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
1845      &WMIN-0.5*PARJ(36)*PMQ(3)
1846       WREM2=FOUR(N+NRS,N+NRS)
1847       IF(WREM2.LT.0.10) GOTO 550
1848       IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
1849      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 810
1850
1851 C...Choose z, which gives Gamma. Shift z for heavy flavours.
1852       CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
1853       KFL1A=IABS(KFL(1))
1854       KFL2A=IABS(KFL(2))
1855       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1856      &MOD(KFL2A/1000,10)).GE.4) THEN
1857         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1858         PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
1859         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
1860         PR(JR)=(PMQ(JR)+PARJ(32+MSTJ(11)))**2+(PX(JR)-PX(3))**2+
1861      &  (PY(JR)-PY(3))**2
1862         IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 810
1863       ENDIF
1864       GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
1865       DO 690 J=1,3
1866   690 IN(J)=IN(3*JT+J)
1867
1868 C...Stepping within or from 'low' string region easy.
1869       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1870      &P(IN(1),5)**2.GE.PR(JT)) THEN
1871         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
1872         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
1873         DO 700 J=1,4
1874   700   P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
1875         GOTO 770
1876       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1877         P(IN(JR)+2,4)=P(IN(JR)+2,3)
1878         P(IN(JR)+2,JT)=1.
1879         IN(JR)=IN(JR)+4*JS
1880         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1881         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1882           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1883           P(IN(JT)+2,JT)=0.
1884           IN(JT)=IN(JT)+4*JS
1885         ENDIF
1886       ENDIF
1887
1888 C...Find new transverse directions (i.e. spacelike string vectors).
1889   710 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
1890      &IN(1).GT.IN(2)) GOTO 550
1891       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
1892         DO 720 J=1,4
1893         DP(1,J)=P(IN(1),J)
1894         DP(2,J)=P(IN(2),J)
1895         DP(3,J)=0.
1896   720   DP(4,J)=0.
1897         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1898         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1899         DHC12=DFOUR(1,2)
1900         IF(DHC12.LE.1E-2) THEN
1901           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1902           P(IN(JT)+2,JT)=0.
1903           IN(JT)=IN(JT)+4*JS
1904           GOTO 710
1905         ENDIF
1906         IN(3)=N+NR+4*NS+5
1907         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1908         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1909         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1910         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1911         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1912         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1913         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1914         DHCX1=DFOUR(3,1)/DHC12
1915         DHCX2=DFOUR(3,2)/DHC12
1916         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1917         DHCY1=DFOUR(4,1)/DHC12
1918         DHCY2=DFOUR(4,2)/DHC12
1919         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1920         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1921         DO 730 J=1,4
1922         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1923         P(IN(3),J)=DP(3,J)
1924   730   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1925      &  DHCYX*DP(3,J))
1926 C...Express pT with respect to new axes, if sensible.
1927         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
1928      &  FOUR(IN(3*JT+3)+1,IN(3)))
1929         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
1930      &  FOUR(IN(3*JT+3)+1,IN(3)+1))
1931         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1932           PX(3)=PXP
1933           PY(3)=PYP
1934         ENDIF
1935       ENDIF
1936
1937 C...Sum up known four-momentum. Gives coefficients for m2 expression.
1938       DO 750 J=1,4
1939       DHG(J)=0.
1940       P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
1941      &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
1942       DO 740 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
1943   740 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1944       DO 750 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
1945   750 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1946       DHM(1)=FOUR(I,I)
1947       DHM(2)=2.*FOUR(I,IN(1))
1948       DHM(3)=2.*FOUR(I,IN(2))
1949       DHM(4)=2.*FOUR(IN(1),IN(2))
1950
1951 C...Find coefficients for Gamma expression.
1952       DO 760 IN2=IN(1)+1,IN(2),4
1953       DO 760 IN1=IN(1),IN2-1,4
1954       DHC=2.*FOUR(IN1,IN2)
1955       DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
1956       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
1957       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
1958   760 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1959
1960 C...Solve (m2, Gamma) equation system for energies taken.
1961       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
1962       IF(ABS(DHS1).LT.1E-4) GOTO 550
1963       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
1964      &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
1965       DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
1966       P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1967      &DHS2/DHS1)
1968       IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 550
1969       P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
1970      &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
1971
1972 C...Step to new region if necessary.
1973       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
1974         P(IN(JR)+2,4)=P(IN(JR)+2,3)
1975         P(IN(JR)+2,JT)=1.
1976         IN(JR)=IN(JR)+4*JS
1977         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1978         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1979           P(IN(JT)+2,4)=P(IN(JT)+2,3)
1980           P(IN(JT)+2,JT)=0.
1981           IN(JT)=IN(JT)+4*JS
1982         ENDIF
1983         GOTO 710
1984       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
1985         P(IN(JT)+2,4)=P(IN(JT)+2,3)
1986         P(IN(JT)+2,JT)=0.
1987         IN(JT)=IN(JT)+4*JS
1988         GOTO 710
1989       ENDIF
1990
1991 C...Four-momentum of particle. Remaining quantities. Loop back.
1992   770 DO 780 J=1,4
1993       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1994   780 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
1995       IF(P(I,4).LE.0.) GOTO 550
1996       KFL(JT)=-KFL(3)
1997       PMQ(JT)=PMQ(3)
1998       PX(JT)=-PX(3)
1999       PY(JT)=-PY(3)
2000       GAM(JT)=GAM(3)
2001       IF(IN(3).NE.IN(3*JT+3)) THEN
2002         DO 790 J=1,4
2003         P(IN(3*JT+3),J)=P(IN(3),J)
2004   790   P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2005       ENDIF
2006       DO 800 JQ=1,2
2007       IN(3*JT+JQ)=IN(JQ)
2008       P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
2009   800 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
2010       GOTO 670
2011
2012 C...Final hadron: side, flavour, hadron, mass.
2013   810 I=I+1
2014       K(I,1)=1
2015       K(I,3)=IE(JR)
2016       K(I,4)=0
2017       K(I,5)=0
2018       CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
2019       IF(K(I,2).EQ.0) GOTO 550
2020       P(I,5)=ULMASS(K(I,2))
2021       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2022
2023 C...Final two hadrons: find common setup of four-vectors.
2024       JQ=1
2025       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
2026      &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
2027       DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
2028       DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
2029       DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
2030       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
2031         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
2032         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
2033         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
2034      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
2035       ENDIF
2036
2037 C...Solve kinematics for final two hadrons, if possible.
2038       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
2039       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
2040       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 180
2041       IF(FD.GE.1.) GOTO 550
2042       FA=WREM2+PR(JT)-PR(JR)
2043       IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(37+MSTJ(11))
2044       IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-100.,LOG(FD)*
2045      &PARJ(37+MSTJ(11))*(PR(1)+PR(2))**2))
2046       FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
2047       KFL1A=IABS(KFL(1))
2048       KFL2A=IABS(KFL(2))
2049       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2050      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
2051      &4.*WREM2*PR(JT))),FLOAT(JS))
2052       DO 820 J=1,4
2053       P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
2054      &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
2055      &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
2056   820 P(I,J)=P(N+NRS,J)-P(I-1,J)
2057
2058 C...Mark jets as fragmented and give daughter pointers.
2059       N=I-NRS+1
2060       DO 830 I=NSAV+1,NSAV+NP
2061       IM=K(I,3)
2062       K(IM,1)=K(IM,1)+10
2063       IF(MSTU(16).NE.2) THEN
2064         K(IM,4)=NSAV+1
2065         K(IM,5)=NSAV+1
2066       ELSE
2067         K(IM,4)=NSAV+2
2068         K(IM,5)=N
2069       ENDIF
2070   830 CONTINUE
2071
2072 C...Document string system. Move up particles.
2073       NSAV=NSAV+1
2074       K(NSAV,1)=11
2075       K(NSAV,2)=92
2076       K(NSAV,3)=IP
2077       K(NSAV,4)=NSAV+1
2078       K(NSAV,5)=N
2079       DO 840 J=1,4
2080       P(NSAV,J)=DPS(J)
2081   840 V(NSAV,J)=V(IP,J)
2082       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2083       V(NSAV,5)=0.
2084       DO 850 I=NSAV+1,N
2085       DO 850 J=1,5
2086       K(I,J)=K(I+NRS-1,J)
2087       P(I,J)=P(I+NRS-1,J)
2088   850 V(I,J)=0.
2089
2090 C...Order particles in rank along the chain. Update mother pointer.
2091       DO 860 I=NSAV+1,N
2092       DO 860 J=1,5
2093       K(I-NSAV+N,J)=K(I,J)
2094   860 P(I-NSAV+N,J)=P(I,J)
2095       I1=NSAV
2096       DO 880 I=N+1,2*N-NSAV
2097       IF(K(I,3).NE.IE(1)) GOTO 880
2098       I1=I1+1
2099       DO 870 J=1,5
2100       K(I1,J)=K(I,J)
2101   870 P(I1,J)=P(I,J)
2102       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2103   880 CONTINUE
2104       DO 900 I=2*N-NSAV,N+1,-1
2105       IF(K(I,3).EQ.IE(1)) GOTO 900
2106       I1=I1+1
2107       DO 890 J=1,5
2108       K(I1,J)=K(I,J)
2109   890 P(I1,J)=P(I,J)
2110       IF(MSTU(16).NE.2) K(I1,3)=NSAV
2111   900 CONTINUE
2112
2113 C...Boost back particle system. Set production vertices.
2114       CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2115      &DPS(3)/DPS(4))
2116       DO 910 I=NSAV+1,N
2117       DO 910 J=1,4
2118   910 V(I,J)=V(IP,J)
2119
2120       RETURN
2121       END
2122
2123 C*********************************************************************
2124
2125       SUBROUTINE LUINDF(IP)
2126
2127 C...Purpose: to handle the fragmentation of a jet system (or a single
2128 C...jet) according to independent fragmentation models.
2129       IMPLICIT DOUBLE PRECISION(D)
2130       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2131       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2132       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2133       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
2134      &KFLO(2),PXO(2),PYO(2),WO(2)
2135       SAVE
2136
2137 C...Reset counters. Identify parton system and take copy. Check flavour.
2138       NSAV=N
2139       NJET=0
2140       KQSUM=0
2141       DO 100 J=1,5
2142   100 DPS(J)=0.
2143       I=IP-1
2144   110 I=I+1
2145       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
2146         CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
2147         IF(MSTU(21).GE.1) RETURN
2148       ENDIF
2149       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2150       KC=LUCOMP(K(I,2))
2151       IF(KC.EQ.0) GOTO 110
2152       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2153       IF(KQ.EQ.0) GOTO 110
2154       NJET=NJET+1
2155       IF(KQ.NE.2) KQSUM=KQSUM+KQ
2156       DO 120 J=1,5
2157       K(NSAV+NJET,J)=K(I,J)
2158       P(NSAV+NJET,J)=P(I,J)
2159   120 DPS(J)=DPS(J)+P(I,J)
2160       K(NSAV+NJET,3)=I
2161       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
2162      &K(I+1,1).EQ.2)) GOTO 110
2163       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
2164         CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
2165         IF(MSTU(21).GE.1) RETURN
2166       ENDIF
2167
2168 C...Boost copied system to CM frame. Find CM energy and sum flavours.
2169       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2170      &-DPS(2)/DPS(4),-DPS(3)/DPS(4))
2171       PECM=0.
2172       DO 130 J=1,3
2173   130 NFI(J)=0
2174       DO 140 I=NSAV+1,NSAV+NJET
2175       PECM=PECM+P(I,4)
2176       KFA=IABS(K(I,2))
2177       IF(KFA.LE.3) THEN
2178         NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
2179       ELSEIF(KFA.GT.1000) THEN
2180         KFLA=MOD(KFA/1000,10)
2181         KFLB=MOD(KFA/100,10)
2182         IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
2183         IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
2184       ENDIF
2185   140 CONTINUE
2186
2187 C...Loop over attempts made. Reset counters.
2188       NTRY=0
2189   150 NTRY=NTRY+1
2190       N=NSAV+NJET
2191       IF(NTRY.GT.200) THEN
2192         CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
2193         IF(MSTU(21).GE.1) RETURN
2194       ENDIF
2195       DO 160 J=1,3
2196       NFL(J)=NFI(J)
2197       IFET(J)=0
2198   160 KFLF(J)=0
2199
2200 C...Loop over jets to be fragmented.
2201       DO 230 IP1=NSAV+1,NSAV+NJET
2202       MSTJ(91)=0
2203       NSAV1=N
2204
2205 C...Initial flavour and momentum values. Jet along +z axis.
2206       KFLH=IABS(K(IP1,2))
2207       IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2208       KFLO(2)=0
2209       WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2210
2211 C...Initial values for quark or diquark jet.
2212   170 IF(IABS(K(IP1,2)).NE.21) THEN
2213         NSTR=1
2214         KFLO(1)=K(IP1,2)
2215         CALL LUPTDI(0,PXO(1),PYO(1))
2216         WO(1)=WF
2217
2218 C...Initial values for gluon treated like random quark jet.
2219       ELSEIF(MSTJ(2).LE.2) THEN
2220         NSTR=1
2221         IF(MSTJ(2).EQ.2) MSTJ(91)=1
2222         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2223         CALL LUPTDI(0,PXO(1),PYO(1))
2224         WO(1)=WF
2225
2226 C...Initial values for gluon treated like quark-antiquark jet pair,
2227 C...sharing energy according to Altarelli-Parisi splitting function.
2228       ELSE
2229         NSTR=2
2230         IF(MSTJ(2).EQ.4) MSTJ(91)=1
2231         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2232         KFLO(2)=-KFLO(1)
2233         CALL LUPTDI(0,PXO(1),PYO(1))
2234         PXO(2)=-PXO(1)
2235         PYO(2)=-PYO(1)
2236         WO(1)=WF*RLU(0)**(1./3.)
2237         WO(2)=WF-WO(1)
2238       ENDIF
2239
2240 C...Initial values for rank, flavour, pT and W+.
2241       DO 220 ISTR=1,NSTR
2242   180 I=N
2243       IRANK=0
2244       KFL1=KFLO(ISTR)
2245       PX1=PXO(ISTR)
2246       PY1=PYO(ISTR)
2247       W=WO(ISTR)
2248
2249 C...New hadron. Generate flavour and hadron species.
2250   190 I=I+1
2251       IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
2252         CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')
2253         IF(MSTU(21).GE.1) RETURN
2254       ENDIF
2255       IRANK=IRANK+1
2256       K(I,1)=1
2257       K(I,3)=IP1
2258       K(I,4)=0
2259       K(I,5)=0
2260   200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
2261       IF(K(I,2).EQ.0) GOTO 180
2262       IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
2263      &IABS(KFL2).GT.10) THEN
2264         IF(RLU(0).GT.PARJ(19)) GOTO 200
2265       ENDIF
2266
2267 C...Find hadron mass. Generate four-momentum.
2268       P(I,5)=ULMASS(K(I,2))
2269       CALL LUPTDI(KFL1,PX2,PY2)
2270       P(I,1)=PX1+PX2
2271       P(I,2)=PY1+PY2
2272       PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2273       CALL LUZDIS(KFL1,KFL2,PR,Z)
2274       P(I,3)=0.5*(Z*W-PR/(Z*W))
2275       P(I,4)=0.5*(Z*W+PR/(Z*W))
2276       IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
2277      &P(I,3).LE.0.001) THEN
2278         IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
2279         P(I,3)=0.0001
2280         P(I,4)=SQRT(PR)
2281         Z=P(I,4)/W
2282       ENDIF
2283
2284 C...Remaining flavour and momentum.
2285       KFL1=-KFL2
2286       PX1=-PX2
2287       PY1=-PY2
2288       W=(1.-Z)*W
2289       DO 210 J=1,5
2290   210 V(I,J)=0.
2291
2292 C...Check if pL acceptable. Go back for new hadron if enough energy.
2293       IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) I=I-1
2294       IF(W.GT.PARJ(31)) GOTO 190
2295   220 N=I
2296       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2297       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2298
2299 C...Rotate jet to new direction.
2300       THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2301       PHI=ULANGL(P(IP1,1),P(IP1,2))
2302       CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2303       K(K(IP1,3),4)=NSAV1+1
2304       K(K(IP1,3),5)=N
2305
2306 C...End of jet generation loop. Skip conservation in some cases.
2307   230 CONTINUE
2308       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2309       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2310
2311 C...Subtract off produced hadron flavours, finished if zero.
2312       DO 240 I=NSAV+NJET+1,N
2313       KFA=IABS(K(I,2))
2314       KFLA=MOD(KFA/1000,10)
2315       KFLB=MOD(KFA/100,10)
2316       KFLC=MOD(KFA/10,10)
2317       IF(KFLA.EQ.0) THEN
2318         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2319         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2320       ELSE
2321         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2322         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2323         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2324       ENDIF
2325   240 CONTINUE
2326       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2327      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2328       IF(NREQ.EQ.0) GOTO 320
2329
2330 C...Take away flavour of low-momentum particles until enough freedom.
2331       NREM=0
2332   250 IREM=0
2333       P2MIN=PECM**2
2334       DO 260 I=NSAV+NJET+1,N
2335       P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2336       IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2337   260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2338       IF(IREM.EQ.0) GOTO 150
2339       K(IREM,1)=7
2340       KFA=IABS(K(IREM,2))
2341       KFLA=MOD(KFA/1000,10)
2342       KFLB=MOD(KFA/100,10)
2343       KFLC=MOD(KFA/10,10)
2344       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2345       IF(K(IREM,1).EQ.8) GOTO 250
2346       IF(KFLA.EQ.0) THEN
2347         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2348         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2349         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2350       ELSE
2351         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2352         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2353         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2354       ENDIF
2355       NREM=NREM+1
2356       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2357      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2358       IF(NREQ.GT.NREM) GOTO 250
2359       DO 270 I=NSAV+NJET+1,N
2360   270 IF(K(I,1).EQ.8) K(I,1)=1
2361
2362 C...Find combination of existing and new flavours for hadron.
2363   280 NFET=2
2364       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2365       IF(NREQ.LT.NREM) NFET=1
2366       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2367       DO 290 J=1,NFET
2368       IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0)
2369       KFLF(J)=ISIGN(1,NFL(1))
2370       IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2371   290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2372       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2373      &GOTO 280
2374       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2375      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2376      &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2377       IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2378       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2379       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2380       IF(NFET.LE.2) KFLF(3)=0
2381       IF(KFLF(3).NE.0) THEN
2382         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2383      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2384         IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2385      &  KFLFC=KFLFC+ISIGN(2,KFLFC)
2386       ELSE
2387         KFLFC=KFLF(1)
2388       ENDIF
2389       CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2390       IF(KF.EQ.0) GOTO 280
2391       DO 300 J=1,MAX(2,NFET)
2392   300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2393
2394 C...Store hadron at random among free positions.
2395       NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2396       DO 310 I=NSAV+NJET+1,N
2397       IF(K(I,1).EQ.7) NPOS=NPOS-1
2398       IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2399       K(I,1)=1
2400       K(I,2)=KF
2401       P(I,5)=ULMASS(K(I,2))
2402       P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2403   310 CONTINUE
2404       NREM=NREM-1
2405       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2406      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2407       IF(NREM.GT.0) GOTO 280
2408
2409 C...Compensate for missing momentum in global scheme (3 options).
2410   320 MTMP = MOD(MSTJ(3),5)
2411       IF(MTMP.NE.0.AND.MTMP.NE.4) THEN
2412         DO 330 J=1,3
2413         PSI(J)=0.
2414         DO 330 I=NSAV+NJET+1,N
2415   330   PSI(J)=PSI(J)+P(I,J)
2416         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2417         PWS=0.
2418         DO 340 I=NSAV+NJET+1,N
2419         IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2420         IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2421      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2422   340   IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2423         DO 360 I=NSAV+NJET+1,N
2424         IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2425         IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2426      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2427         IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2428         DO 350 J=1,3
2429   350   P(I,J)=P(I,J)-PSI(J)*PW/PWS
2430   360   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2431
2432 C...Compensate for missing momentum withing each jet separately.
2433       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2434         DO 370 I=N+1,N+NJET
2435         K(I,1)=0
2436         DO 370 J=1,5
2437   370   P(I,J)=0.
2438         DO 390 I=NSAV+NJET+1,N
2439         IR1=K(I,3)
2440         IR2=N+IR1-NSAV
2441         K(IR2,1)=K(IR2,1)+1
2442         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2443      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2444         DO 380 J=1,3
2445   380   P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2446         P(IR2,4)=P(IR2,4)+P(I,4)
2447   390   P(IR2,5)=P(IR2,5)+PLS
2448         PSS=0.
2449         DO 400 I=N+1,N+NJET
2450   400   IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2451         DO 420 I=NSAV+NJET+1,N
2452         IR1=K(I,3)
2453         IR2=N+IR1-NSAV
2454         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2455      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2456         DO 410 J=1,3
2457   410   P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2458      &  P(IR1,J)
2459   420   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2460       ENDIF
2461
2462 C...Scale momenta for energy conservation.
2463       IF(MOD(MSTJ(3),5).NE.0) THEN
2464         PMS=0.
2465         PES=0.
2466         PQS=0.
2467         DO 430 I=NSAV+NJET+1,N
2468         PMS=PMS+P(I,5)
2469         PES=PES+P(I,4)
2470   430   PQS=PQS+P(I,5)**2/P(I,4)
2471         IF(PMS.GE.PECM) GOTO 150
2472         NECO=0
2473   440   NECO=NECO+1
2474         PFAC=(PECM-PQS)/(PES-PQS)
2475         PES=0.
2476         PQS=0.
2477         DO 460 I=NSAV+NJET+1,N
2478         DO 450 J=1,3
2479   450   P(I,J)=PFAC*P(I,J)
2480         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2481         PES=PES+P(I,4)
2482   460   PQS=PQS+P(I,5)**2/P(I,4)
2483         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2484       ENDIF
2485
2486 C...Origin of produced particles and parton daughter pointers.
2487   470 DO 480 I=NSAV+NJET+1,N
2488       IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2489   480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2490       DO 490 I=NSAV+1,NSAV+NJET
2491       I1=K(I,3)
2492       K(I1,1)=K(I1,1)+10
2493       IF(MSTU(16).NE.2) THEN
2494         K(I1,4)=NSAV+1
2495         K(I1,5)=NSAV+1
2496       ELSE
2497         K(I1,4)=K(I1,4)-NJET+1
2498         K(I1,5)=K(I1,5)-NJET+1
2499         IF(K(I1,5).LT.K(I1,4)) THEN
2500           K(I1,4)=0
2501           K(I1,5)=0
2502         ENDIF
2503       ENDIF
2504   490 CONTINUE
2505
2506 C...Document independent fragmentation system. Remove copy of jets.
2507       NSAV=NSAV+1
2508       K(NSAV,1)=11
2509       K(NSAV,2)=93
2510       K(NSAV,3)=IP
2511       K(NSAV,4)=NSAV+1
2512       K(NSAV,5)=N-NJET+1
2513       DO 500 J=1,4
2514       P(NSAV,J)=DPS(J)
2515   500 V(NSAV,J)=V(IP,J)
2516       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2517       V(NSAV,5)=0.
2518       DO 510 I=NSAV+NJET,N
2519       DO 510 J=1,5
2520       K(I-NJET+1,J)=K(I,J)
2521       P(I-NJET+1,J)=P(I,J)
2522   510 V(I-NJET+1,J)=V(I,J)
2523       N=N-NJET+1
2524
2525 C...Boost back particle system. Set production vertices.
2526       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2527      &DPS(2)/DPS(4),DPS(3)/DPS(4))
2528       DO 520 I=NSAV+1,N
2529       DO 520 J=1,4
2530   520 V(I,J)=V(IP,J)
2531
2532       RETURN
2533       END
2534
2535 C*********************************************************************
2536
2537       SUBROUTINE LUDECY(IP)
2538
2539 C...Purpose: to handle the decay of unstable particles.
2540       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2541       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2542       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2543       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2544       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2545      &WTCOR(10)
2546       SAVE
2547       DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2548
2549 C...Functions: momentum in two-particle decays, four-product and
2550 C...matrix element times phase space in weak decays.
2551       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2552       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)
2553       HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2554      &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2555
2556 C...Initial values.
2557       NTRY=0
2558       NSAV=N
2559       KFA=IABS(K(IP,2))
2560       KFS=ISIGN(1,K(IP,2))
2561       KC=LUCOMP(KFA)
2562       MSTJ(92)=0
2563
2564 C...Choose lifetime and determine decay vertex.
2565       IF(K(IP,1).EQ.5) THEN
2566         V(IP,5)=0.
2567       ELSEIF(K(IP,1).NE.4) THEN
2568         V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2569       ENDIF
2570       DO 100 J=1,4
2571   100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2572
2573 C...Determine whether decay allowed or not.
2574       MOUT=0
2575       IF(MSTJ(22).EQ.2) THEN
2576         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2577       ELSEIF(MSTJ(22).EQ.3) THEN
2578         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2579       ELSEIF(MSTJ(22).EQ.4) THEN
2580         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2581         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2582       ENDIF
2583       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2584         K(IP,1)=4
2585         RETURN
2586       ENDIF
2587
2588 C...Check existence of decay channels. Particle/antiparticle rules.
2589       KCA=KC
2590       IF(MDCY(KC,2).GT.0) THEN
2591         MDMDCY=MDME(MDCY(KC,2),2)
2592         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2593       ENDIF
2594       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2595         CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2596         RETURN
2597       ENDIF
2598       IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2599       IF(KCHG(KC,3).EQ.0) THEN
2600         KFSP=1
2601         KFSN=0
2602         IF(RLU(0).GT.0.5) KFS=-KFS
2603       ELSEIF(KFS.GT.0) THEN
2604         KFSP=1
2605         KFSN=0
2606       ELSE
2607         KFSP=0
2608         KFSN=1
2609       ENDIF
2610
2611 C...Sum branching ratios of allowed decay channels.
2612       NOPE=0
2613       BRSU=0.
2614       DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2615       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2616      &KFSN*MDME(IDL,1).NE.3) GOTO 120
2617       IF(MDME(IDL,2).GT.100) GOTO 120
2618       NOPE=NOPE+1
2619       BRSU=BRSU+BRAT(IDL)
2620   120 CONTINUE
2621       IF(NOPE.EQ.0) THEN
2622         CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2623         RETURN
2624       ENDIF
2625
2626 C...Select decay channel among allowed ones.
2627   130 RBR=BRSU*RLU(0)
2628       IDL=MDCY(KCA,2)-1
2629   140 IDL=IDL+1
2630       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2631      &KFSN*MDME(IDL,1).NE.3) THEN
2632         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2633       ELSEIF(MDME(IDL,2).GT.100) THEN
2634         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2635       ELSE
2636         IDC=IDL
2637         RBR=RBR-BRAT(IDL)
2638         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2639       ENDIF
2640
2641 C...Start readout of decay channel: matrix element, reset counters.
2642       MMAT=MDME(IDC,2)
2643   150 NTRY=NTRY+1
2644       IF(NTRY.GT.1000) THEN
2645         CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2646         IF(MSTU(21).GE.1) RETURN
2647       ENDIF
2648       I=N
2649       NP=0
2650       NQ=0
2651       MBST=0
2652       IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2653       DO 160 J=1,4
2654       PV(1,J)=0.
2655   160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2656       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2657       PV(1,5)=P(IP,5)
2658       PS=0.
2659       PSQ=0.
2660       MREM=0
2661
2662 C...Read out decay products. Convert to standard flavour code.
2663       JTMAX=5
2664       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2665       DO 170 JT=1,JTMAX
2666       IF(JT.LE.5) KP=KFDP(IDC,JT)
2667       IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
2668       IF(KP.EQ.0) GOTO 170
2669       KPA=IABS(KP)
2670       KCP=LUCOMP(KPA)
2671       IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
2672         KFP=KP
2673       ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
2674         KFP=KFS*KP
2675       ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
2676         KFP=-KFS*MOD(KFA/10,10)
2677       ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
2678         KFP=KFS*(100*MOD(KFA/10,100)+3)
2679       ELSEIF(KPA.EQ.81) THEN
2680         KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
2681       ELSEIF(KP.EQ.82) THEN
2682         CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
2683         IF(KFP.EQ.0) GOTO 150
2684         MSTJ(93)=1
2685         IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
2686       ELSEIF(KP.EQ.-82) THEN
2687         KFP=-KFP
2688         IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
2689       ENDIF
2690       IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
2691
2692 C...Add decay product to event record or to quark flavour list.
2693       KFPA=IABS(KFP)
2694       KQP=KCHG(KCP,2)
2695       IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
2696         NQ=NQ+1
2697         KFLO(NQ)=KFP
2698         MSTJ(93)=2
2699         PSQ=PSQ+ULMASS(KFLO(NQ))
2700       ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
2701      &THEN
2702         NQ=NQ-1
2703         PS=PS-P(I,5)
2704         K(I,1)=1
2705         KFI=K(I,2)
2706         CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
2707         IF(K(I,2).EQ.0) GOTO 150
2708         MSTJ(93)=1
2709         P(I,5)=ULMASS(K(I,2))
2710         PS=PS+P(I,5)
2711       ELSE
2712         I=I+1
2713         NP=NP+1
2714         IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
2715         IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
2716         K(I,1)=1+MOD(NQ,2)
2717         IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
2718         IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
2719         K(I,2)=KFP
2720         K(I,3)=IP
2721         K(I,4)=0
2722         K(I,5)=0
2723         P(I,5)=ULMASS(KFP)
2724         IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
2725         PS=PS+P(I,5)
2726       ENDIF
2727   170 CONTINUE
2728
2729 C...Choose decay multiplicity in phase space model.
2730   180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
2731         PSP=PS
2732         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
2733         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
2734   190   NTRY=NTRY+1
2735         IF(NTRY.GT.1000) THEN
2736           CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2737           IF(MSTU(21).GE.1) RETURN
2738         ENDIF
2739         IF(MMAT.LE.20) THEN
2740           GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
2741      &    SIN(PARU(2)*RLU(0))
2742           ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS
2743           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
2744           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
2745           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
2746           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
2747         ELSE
2748           ND=MMAT-20
2749         ENDIF
2750
2751 C...Form hadrons from flavour content.
2752         DO 200 JT=1,4
2753   200   KFL1(JT)=KFLO(JT)
2754         IF(ND.EQ.NP+NQ/2) GOTO 220
2755         DO 210 I=N+NP+1,N+ND-NQ/2
2756         JT=1+INT((NQ-1)*RLU(0))
2757         CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
2758         IF(K(I,2).EQ.0) GOTO 190
2759   210   KFL1(JT)=-KFL2
2760   220   JT=2
2761         JT2=3
2762         JT3=4
2763         IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
2764         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
2765      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
2766         IF(JT.EQ.3) JT2=2
2767         IF(JT.EQ.4) JT3=2
2768         CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
2769         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
2770         IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
2771         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
2772
2773 C...Check that sum of decay product masses not too large.
2774         PS=PSP
2775         DO 230 I=N+NP+1,N+ND
2776         K(I,1)=1
2777         K(I,3)=IP
2778         K(I,4)=0
2779         K(I,5)=0
2780         P(I,5)=ULMASS(K(I,2))
2781   230   PS=PS+P(I,5)
2782         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
2783
2784 C...Rescale energy to subtract off spectator quark mass.
2785       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
2786      &AND.NP.GE.3) THEN
2787         PS=PS-P(N+NP,5)
2788         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
2789         DO 240 J=1,5
2790         P(N+NP,J)=PQT*PV(1,J)
2791   240   PV(1,J)=(1.-PQT)*PV(1,J)
2792         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
2793         ND=NP-1
2794         MREM=1
2795
2796 C...Phase space factors imposed in W decay.
2797       ELSEIF(MMAT.EQ.46) THEN
2798         MSTJ(93)=1
2799         PSMC=ULMASS(K(N+1,2))
2800         MSTJ(93)=1
2801         PSMC=PSMC+ULMASS(K(N+2,2))
2802         IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
2803         HR1=(P(N+1,5)/PV(1,5))**2
2804         HR2=(P(N+2,5)/PV(1,5))**2
2805         IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
2806      &  LT.2.*RLU(0)) GOTO 130
2807         ND=NP
2808
2809 C...Fully specified final state: check mass broadening effects.
2810       ELSE
2811         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
2812         ND=NP
2813       ENDIF
2814
2815 C...Select W mass in decay Q -> W + q, without W propagator.
2816       IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
2817         HLQ=(PARJ(32)/PV(1,5))**2
2818         HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
2819         HRQ=(P(N+2,5)/PV(1,5))**2
2820   250   HW=HLQ+RLU(0)*(HUQ-HLQ)
2821         IF(HMEPS(HW).LT.RLU(0)) GOTO 250
2822         P(N+1,5)=PV(1,5)*SQRT(HW)
2823
2824 C...Ditto, including W propagator. Divide mass range into three regions.
2825       ELSEIF(MMAT.EQ.45) THEN
2826         HQW=(PV(1,5)/PMAS(24,1))**2
2827         HLW=(PARJ(32)/PMAS(24,1))**2
2828         HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
2829         HRQ=(P(N+2,5)/PV(1,5))**2
2830         HG=PMAS(24,2)/PMAS(24,1)
2831         HATL=ATAN((HLW-1.)/HG)
2832         HM=MIN(1.,HUW-0.001)
2833         HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2834   260   HM=HM-HG
2835         HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2836         HSAV1=HMEPS(HM/HQW)
2837         HSAV2=1./((HM-1.)**2+HG**2)
2838         IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
2839           HMV1=HMV2
2840           GOTO 260
2841         ENDIF
2842         HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
2843         HM1=1.-SQRT(1./HMV-HG**2)
2844         IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
2845           HM=HM1
2846         ELSEIF(HMV2.LE.HMV1) THEN
2847           HM=MAX(HLW,HM-MIN(0.1,1.-HM))
2848         ENDIF
2849         HATM=ATAN((HM-1.)/HG)
2850         HWT1=(HATM-HATL)/HG
2851         HWT2=HMV*(MIN(1.,HUW)-HM)
2852         HWT3=0.
2853         IF(HUW.GT.1.) THEN
2854           HATU=ATAN((HUW-1.)/HG)
2855           HMP1=HMEPS(1./HQW)
2856           HWT3=HMP1*HATU/HG
2857         ENDIF
2858
2859 C...Select mass region and W mass there. Accept according to weight.
2860   270   HREG=RLU(0)*(HWT1+HWT2+HWT3)
2861         IF(HREG.LE.HWT1) THEN
2862           HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
2863           HACC=HMEPS(HW/HQW)
2864         ELSEIF(HREG.LE.HWT1+HWT2) THEN
2865           HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
2866           HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
2867         ELSE
2868           HW=1.+HG*TAN(RLU(0)*HATU)
2869           HACC=HMEPS(HW/HQW)/HMP1
2870         ENDIF
2871         IF(HACC.LT.RLU(0)) GOTO 270
2872         P(N+1,5)=PMAS(24,1)*SQRT(HW)
2873       ENDIF
2874
2875 C...Determine position of grandmother, number of sisters, Q -> W sign.
2876       NM=0
2877       MSGN=0
2878       IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
2879         IM=K(IP,3)
2880         IF(IM.LT.0.OR.IM.GE.IP) IM=0
2881         IF(IM.NE.0) KFAM=IABS(K(IM,2))
2882         IF(IM.NE.0.AND.MMAT.EQ.3) THEN
2883           DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
2884   280     IF(K(IL,3).EQ.IM) NM=NM+1
2885           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
2886      &    MOD(KFAM/1000,10).NE.0) NM=0
2887         ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
2888           MSGN=ISIGN(1,K(IM,2)*K(IP,2))
2889           IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
2890      &    MSGN*(-1)**MOD(KFAM/100,10)
2891         ENDIF
2892       ENDIF
2893
2894 C...Kinematics of one-particle decays.
2895       IF(ND.EQ.1) THEN
2896         DO 290 J=1,4
2897   290   P(N+1,J)=P(IP,J)
2898         GOTO 510
2899       ENDIF
2900
2901 C...Calculate maximum weight ND-particle decay.
2902       PV(ND,5)=P(N+ND,5)
2903       IF(ND.GE.3) THEN
2904         WTMAX=1./WTCOR(ND-2)
2905         PMAX=PV(1,5)-PS+P(N+ND,5)
2906         PMIN=0.
2907         DO 300 IL=ND-1,1,-1
2908         PMAX=PMAX+P(N+IL,5)
2909         PMIN=PMIN+P(N+IL+1,5)
2910   300   WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
2911       ENDIF
2912
2913 C...Find virtual gamma mass in Dalitz decay.
2914   310 IF(ND.EQ.2) THEN
2915       ELSEIF(MMAT.EQ.2) THEN
2916         PMES=4.*PMAS(11,1)**2
2917         PMRHO2=PMAS(131,1)**2
2918         PGRHO2=PMAS(131,2)**2
2919   320   PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
2920         WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
2921      &  (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
2922      &  ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
2923         IF(WT.LT.RLU(0)) GOTO 320
2924         PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
2925
2926 C...M-generator gives weight. If rejected, try again.
2927       ELSE
2928   330   RORD(1)=1.
2929         DO 350 IL1=2,ND-1
2930         RSAV=RLU(0)
2931         DO 340 IL2=IL1-1,1,-1
2932         IF(RSAV.LE.RORD(IL2)) GOTO 350
2933   340   RORD(IL2+1)=RORD(IL2)
2934   350   RORD(IL2+1)=RSAV
2935         RORD(ND)=0.
2936         WT=1.
2937         DO 360 IL=ND-1,1,-1
2938         PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
2939   360   WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2940         IF(WT.LT.RLU(0)*WTMAX) GOTO 330
2941       ENDIF
2942
2943 C...Perform two-particle decays in respective CM frame.
2944   370 DO 390 IL=1,ND-1
2945       PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2946       UE(3)=2.*RLU(0)-1.
2947       PHI=PARU(2)*RLU(0)
2948       UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
2949       UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
2950       DO 380 J=1,3
2951       P(N+IL,J)=PA*UE(J)
2952   380 PV(IL+1,J)=-PA*UE(J)
2953       P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
2954   390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
2955
2956 C...Lorentz transform decay products to lab frame.
2957       DO 400 J=1,4
2958   400 P(N+ND,J)=PV(ND,J)
2959       DO 430 IL=ND-1,1,-1
2960       DO 410 J=1,3
2961   410 BE(J)=PV(IL,J)/PV(IL,4)
2962       GA=PV(IL,4)/PV(IL,5)
2963       DO 430 I=N+IL,N+ND
2964       BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2965       DO 420 J=1,3
2966   420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2967   430 P(I,4)=GA*(P(I,4)+BEP)
2968
2969 C...Matrix elements for omega and phi decays.
2970       IF(MMAT.EQ.1) THEN
2971         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
2972      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
2973      &  +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
2974         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
2975
2976 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
2977       ELSEIF(MMAT.EQ.2) THEN
2978         FOUR12=FOUR(N+1,N+2)
2979         FOUR13=FOUR(N+1,N+3)
2980         FOUR23=0.5*PMST-0.25*PMES
2981         WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
2982      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
2983         IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
2984
2985 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
2986 C...V vector), of form cos**2(theta02) in V1 rest frame.
2987       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
2988         IF((P(IP,5)**2*FOUR(IM,N+1)-FOUR(IP,IM)*FOUR(IP,N+1))**2.LE.
2989      &  RLU(0)*(FOUR(IP,IM)**2-(P(IP,5)*P(IM,5))**2)*(FOUR(IP,N+1)**2-
2990      &  (P(IP,5)*P(N+1,5))**2)) GOTO 370
2991
2992 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
2993       ELSEIF(MMAT.EQ.4) THEN
2994         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
2995         HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
2996         HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
2997         WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
2998      &  ((1.-HX3)/(HX1*HX2))**2
2999         IF(WT.LT.2.*RLU(0)) GOTO 310
3000         IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
3001      &  GOTO 310
3002
3003 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3004       ELSEIF(MMAT.EQ.41) THEN
3005         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3006         IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
3007
3008 C...Matrix elements for weak decays (only semileptonic for c and b)
3009       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
3010         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
3011         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
3012         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3013       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
3014         DO 440 J=1,4
3015         P(N+NP+1,J)=0.
3016         DO 440 IS=N+3,N+NP
3017   440   P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3018         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
3019         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
3020         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3021
3022 C...Angular distribution in W decay.
3023       ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
3024         IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
3025         IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
3026         IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
3027       ENDIF
3028
3029 C...Scale back energy and reattach spectator.
3030       IF(MREM.EQ.1) THEN
3031         DO 450 J=1,5
3032   450   PV(1,J)=PV(1,J)/(1.-PQT)
3033         ND=ND+1
3034         MREM=0
3035       ENDIF
3036
3037 C...Low invariant mass for system with spectator quark gives particle,
3038 C...not two jets. Readjust momenta accordingly.
3039       IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
3040         MSTJ(93)=1
3041         PM2=ULMASS(K(N+2,2))
3042         MSTJ(93)=1
3043         PM3=ULMASS(K(N+3,2))
3044         IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
3045      &  (PARJ(32)+PM2+PM3)**2) GOTO 510
3046         K(N+2,1)=1
3047         KFTEMP=K(N+2,2)
3048         CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
3049         IF(K(N+2,2).EQ.0) GOTO 150
3050         P(N+2,5)=ULMASS(K(N+2,2))
3051         PS=P(N+1,5)+P(N+2,5)
3052         PV(2,5)=P(N+2,5)
3053         MMAT=0
3054         ND=2
3055         GOTO 370
3056       ELSEIF(MMAT.EQ.44) THEN
3057         MSTJ(93)=1
3058         PM3=ULMASS(K(N+3,2))
3059         MSTJ(93)=1
3060         PM4=ULMASS(K(N+4,2))
3061         IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
3062      &  (PARJ(32)+PM3+PM4)**2) GOTO 480
3063         K(N+3,1)=1
3064         KFTEMP=K(N+3,2)
3065         CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
3066         IF(K(N+3,2).EQ.0) GOTO 150
3067         P(N+3,5)=ULMASS(K(N+3,2))
3068         DO 460 J=1,3
3069   460   P(N+3,J)=P(N+3,J)+P(N+4,J)
3070         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)
3071         HA=P(N+1,4)**2-P(N+2,4)**2
3072         HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
3073         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
3074      &  (P(N+1,3)-P(N+2,3))**2
3075         HD=(PV(1,4)-P(N+3,4))**2
3076         HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
3077         HF=HD*HC-HB**2
3078         HG=HD*HC-HA*HB
3079         HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3080         DO 470 J=1,3
3081         PCOR=HH*(P(N+1,J)-P(N+2,J))
3082         P(N+1,J)=P(N+1,J)+PCOR
3083   470   P(N+2,J)=P(N+2,J)-PCOR
3084         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)
3085         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)
3086         ND=ND-1
3087       ENDIF
3088
3089 C...Check invariant mass of W jets. May give one particle or start over.
3090   480 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
3091         PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
3092         MSTJ(93)=1
3093         PM1=ULMASS(K(N+1,2))
3094         MSTJ(93)=1
3095         PM2=ULMASS(K(N+2,2))
3096         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 490
3097         KFLDUM=INT(1.5+RLU(0))
3098         CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
3099         CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
3100         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
3101         PSM=ULMASS(KF1)+ULMASS(KF2)
3102         IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 490
3103         IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 490
3104         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
3105         K(N+1,1)=1
3106         KFTEMP=K(N+1,2)
3107         CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
3108         IF(K(N+1,2).EQ.0) GOTO 150
3109         P(N+1,5)=ULMASS(K(N+1,2))
3110         K(N+2,2)=K(N+3,2)
3111         P(N+2,5)=P(N+3,5)
3112         PS=P(N+1,5)+P(N+2,5)
3113         PV(2,5)=P(N+3,5)
3114         MMAT=0
3115         ND=2
3116         GOTO 370
3117       ENDIF
3118
3119 C...Phase space decay of partons from W decay.
3120   490 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
3121         KFLO(1)=K(N+1,2)
3122         KFLO(2)=K(N+2,2)
3123         K(N+1,1)=K(N+3,1)
3124         K(N+1,2)=K(N+3,2)
3125         DO 500 J=1,5
3126         PV(1,J)=P(N+1,J)+P(N+2,J)
3127   500   P(N+1,J)=P(N+3,J)
3128         PV(1,5)=PMR
3129         N=N+1
3130         NP=0
3131         NQ=2
3132         PS=0.
3133         MSTJ(93)=2
3134         PSQ=ULMASS(KFLO(1))
3135         MSTJ(93)=2
3136         PSQ=PSQ+ULMASS(KFLO(2))
3137         MMAT=11
3138         GOTO 180
3139       ENDIF
3140
3141 C...Boost back for rapidly moving particle.
3142   510 N=N+ND
3143       IF(MBST.EQ.1) THEN
3144         DO 520 J=1,3
3145   520   BE(J)=P(IP,J)/P(IP,4)
3146         GA=P(IP,4)/P(IP,5)
3147         DO 540 I=NSAV+1,N
3148         BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3149         DO 530 J=1,3
3150   530   P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3151   540   P(I,4)=GA*(P(I,4)+BEP)
3152       ENDIF
3153
3154 C...Fill in position of decay vertex.
3155       DO 560 I=NSAV+1,N
3156       DO 550 J=1,4
3157   550 V(I,J)=VDCY(J)
3158   560 V(I,5)=0.
3159
3160 C...Set up for parton shower evolution from jets.
3161       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
3162         K(NSAV+1,1)=3
3163         K(NSAV+2,1)=3
3164         K(NSAV+3,1)=3
3165         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3166         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3167         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3168         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3169         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3170         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3171         MSTJ(92)=-(NSAV+1)
3172       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3173         K(NSAV+2,1)=3
3174         K(NSAV+3,1)=3
3175         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3176         K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3177         K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3178         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3179         MSTJ(92)=NSAV+2
3180       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3181      &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
3182         K(NSAV+1,1)=3
3183         K(NSAV+2,1)=3
3184         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3185         K(NSAV+1,5)=MSTU(5)*(NSAV+2)
3186         K(NSAV+2,4)=MSTU(5)*(NSAV+1)
3187         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3188         MSTJ(92)=NSAV+1
3189       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3190      &THEN
3191         K(NSAV+1,1)=3
3192         K(NSAV+2,1)=3
3193         K(NSAV+3,1)=3
3194         KCP=LUCOMP(K(NSAV+1,2))
3195         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3196         JCON=4
3197         IF(KQP.LT.0) JCON=5
3198         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
3199         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
3200         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
3201         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
3202         MSTJ(92)=NSAV+1
3203       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3204         K(NSAV+1,1)=3
3205         K(NSAV+3,1)=3
3206         K(NSAV+1,4)=MSTU(5)*(NSAV+3)
3207         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3208         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3209         K(NSAV+3,5)=MSTU(5)*(NSAV+1)
3210         MSTJ(92)=NSAV+1
3211       ENDIF
3212
3213 C...Mark decayed particle.
3214       IF(K(IP,1).EQ.5) K(IP,1)=15
3215       IF(K(IP,1).LE.10) K(IP,1)=11
3216       K(IP,4)=NSAV+1
3217       K(IP,5)=N
3218
3219       RETURN
3220       END
3221
3222 C*********************************************************************
3223
3224       SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
3225
3226 C...Purpose: to generate a new flavour pair and combine off a hadron.
3227       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3228       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3229       SAVE
3230
3231 C...Default flavour values. Input consistency checks.
3232       KF1A=IABS(KFL1)
3233       KF2A=IABS(KFL2)
3234       KFL3=0
3235       KF=0
3236       IF(KF1A.EQ.0) RETURN
3237       IF(KF2A.NE.0) THEN
3238         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
3239         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
3240         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
3241       ENDIF
3242
3243 C...Check if tabulated flavour probabilities are to be used.
3244       IF(MSTJ(15).EQ.1) THEN
3245         KTAB1=-1
3246         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3247         KFL1A=MOD(KF1A/1000,10)
3248         KFL1B=MOD(KF1A/100,10)
3249         KFL1S=MOD(KF1A,10)
3250         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
3251      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
3252         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
3253         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
3254         KTAB2=0
3255         IF(KF2A.NE.0) THEN
3256           KTAB2=-1
3257           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3258           KFL2A=MOD(KF2A/1000,10)
3259           KFL2B=MOD(KF2A/100,10)
3260           KFL2S=MOD(KF2A,10)
3261           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
3262      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
3263           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
3264         ENDIF
3265         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3266       ENDIF
3267
3268 C...Parameters and breaking diquark parameter combinations.
3269   100 PAR2=PARJ(2)
3270       PAR3=PARJ(3)
3271       PAR4=3.*PARJ(4)
3272       IF(MSTJ(12).GE.2) THEN
3273         PAR3M=SQRT(PARJ(3))
3274         PAR4M=1./(3.*SQRT(PARJ(4)))
3275         PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3276         PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3277         PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3278      &  PAR2*PAR3M*PARJ(6)*PARJ(7))
3279         PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3280         PARSM=MAX(PARS0,PARS1,PARS2)
3281         PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3282       ENDIF
3283
3284 C...Choice of whether to generate meson or baryon.
3285       MBARY=0
3286       KFDA=0
3287       IF(KF1A.LE.10) THEN
3288         IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3289      &  MBARY=1
3290         IF(KF2A.GT.10) MBARY=2
3291         IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3292       ELSE
3293         MBARY=2
3294         IF(KF1A.LE.10000) KFDA=KF1A
3295       ENDIF
3296
3297 C...Possibility of process diquark -> meson + new diquark.
3298       IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3299         KFLDA=MOD(KFDA/1000,10)
3300         KFLDB=MOD(KFDA/100,10)
3301         KFLDS=MOD(KFDA,10)
3302         WTDQ=PARS0
3303         IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3304         IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3305         IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3306         IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3307         IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3308       ENDIF
3309
3310 C...Flavour for meson, possibly with new flavour.
3311       IF(MBARY.LE.0) THEN
3312         KFS=ISIGN(1,KFL1)
3313         IF(MBARY.EQ.0) THEN
3314           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3315           KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3316           KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3317           IF(KFLA.NE.KF1A) KFS=-KFS
3318
3319 C...Splitting of diquark into meson plus new diquark.
3320         ELSE
3321           KFL1A=MOD(KF1A/1000,10)
3322           KFL1B=MOD(KF1A/100,10)
3323   110     KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3324           KFL1E=KFL1A+KFL1B-KFL1D
3325           IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3326      &    RLU(0).LT.PARDM)) THEN
3327             KFL1D=KFL1A+KFL1B-KFL1D
3328             KFL1E=KFL1A+KFL1B-KFL1E
3329           ENDIF
3330           KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3331           IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3332      &    OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3333      &    GOTO 110
3334           KFLDS=3
3335           IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3336           KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3337      &    KFLDS,-KFL1)
3338           KFLA=MAX(KFL1D,KFL3A)
3339           KFLB=MIN(KFL1D,KFL3A)
3340           IF(KFLA.NE.KFL1D) KFS=-KFS
3341         ENDIF
3342
3343 C...Form meson, with spin and flavour mixing for diagonal states.
3344         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3345         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3346         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3347         IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3348           IF(RLU(0).LT.PARJ(14)) KMUL=2
3349         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3350           RMUL=RLU(0)
3351           IF(RMUL.LT.PARJ(15)) KMUL=3
3352           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3353           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3354         ENDIF
3355         KFLS=3
3356         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3357         IF(KMUL.EQ.5) KFLS=5
3358         IF(KFLA.NE.KFLB) THEN
3359           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3360         ELSE
3361           RMIX=RLU(0)
3362           IMIX=2*KFLA+10*KMUL
3363           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3364      &    INT(RMIX+PARF(IMIX)))+KFLS
3365           IF(KFLA.GE.4) KF=110*KFLA+KFLS
3366         ENDIF
3367         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3368         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3369
3370 C...Generate diquark flavour.
3371       ELSE
3372   120   IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3373           KFLA=KF1A
3374   130     KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3375           KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3376           KFLDS=1
3377           IF(KFLB.GE.KFLC) KFLDS=3
3378           IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3379           IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3380           KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3381
3382 C...Take diquark flavour from input.
3383         ELSEIF(KF1A.LE.10) THEN
3384           KFLA=KF1A
3385           KFLB=MOD(KF2A/1000,10)
3386           KFLC=MOD(KF2A/100,10)
3387           KFLDS=MOD(KF2A,10)
3388
3389 C...Generate (or take from input) quark to go with diquark.
3390         ELSE
3391           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3392           KFLA=KF2A+IABS(KFL3)
3393           KFLB=MOD(KF1A/1000,10)
3394           KFLC=MOD(KF1A/100,10)
3395           KFLDS=MOD(KF1A,10)
3396         ENDIF
3397
3398 C...SU(6) factors for formation of baryon. Try again if fails.
3399         KBARY=KFLDS
3400         IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3401         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3402         WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3403         IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3404           WTDQ=PARS0
3405           IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3406           IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3407           IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3408           IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3409           IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3410         ENDIF
3411         IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3412
3413 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3414         KFLD=MAX(KFLA,KFLB,KFLC)
3415         KFLF=MIN(KFLA,KFLB,KFLC)
3416         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3417         KFLS=2
3418         IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3419      &  PARF(60+KBARY)) KFLS=4
3420         KFLL=0
3421         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3422           IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3423           IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3424           IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3425         ENDIF
3426         IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3427         IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3428       ENDIF
3429       RETURN
3430
3431 C...Use tabulated probabilities to select new flavour and hadron.
3432   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3433         KT3L=1
3434         KT3U=6
3435       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3436         KT3L=1
3437         KT3U=6
3438       ELSEIF(KTAB2.EQ.0) THEN
3439         KT3L=1
3440         KT3U=22
3441       ELSE
3442         KT3L=KTAB2
3443         KT3U=KTAB2
3444       ENDIF
3445       RFL=0.
3446       DO 150 KTS=0,2
3447       DO 150 KT3=KT3L,KT3U
3448       RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3449   150 CONTINUE
3450       RFL=RLU(0)*RFL
3451       DO 160 KTS=0,2
3452       KTABS=KTS
3453       DO 160 KT3=KT3L,KT3U
3454       KTAB3=KT3
3455       RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3456   160 IF(RFL.LE.0.) GOTO 170
3457   170 CONTINUE
3458
3459 C...Reconstruct flavour of produced quark/diquark.
3460       IF(KTAB3.LE.6) THEN
3461         KFL3A=KTAB3
3462         KFL3B=0
3463         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3464       ELSE
3465         KFL3A=1
3466         IF(KTAB3.GE.8) KFL3A=2
3467         IF(KTAB3.GE.11) KFL3A=3
3468         IF(KTAB3.GE.16) KFL3A=4
3469         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3470         KFL3=1000*KFL3A+100*KFL3B+1
3471         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3472      &  KFL3+2
3473         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3474       ENDIF
3475
3476 C...Reconstruct meson code.
3477       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3478      &KFL3B.NE.0)) THEN
3479         RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3480      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3481         KF=110+2*KTABS+1
3482         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3483         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3484      &  25*KTABS)) KF=330+2*KTABS+1
3485       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3486         KFLA=MAX(KTAB1,KTAB3)
3487         KFLB=MIN(KTAB1,KTAB3)
3488         KFS=ISIGN(1,KFL1)
3489         IF(KFLA.NE.KF1A) KFS=-KFS
3490         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3491       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3492         KFS=ISIGN(1,KFL1)
3493         IF(KFL1A.EQ.KFL3A) THEN
3494           KFLA=MAX(KFL1B,KFL3B)
3495           KFLB=MIN(KFL1B,KFL3B)
3496           IF(KFLA.NE.KFL1B) KFS=-KFS
3497         ELSEIF(KFL1A.EQ.KFL3B) THEN
3498           KFLA=KFL3A
3499           KFLB=KFL1B
3500           KFS=-KFS
3501         ELSEIF(KFL1B.EQ.KFL3A) THEN
3502           KFLA=KFL1A
3503           KFLB=KFL3B
3504         ELSEIF(KFL1B.EQ.KFL3B) THEN
3505           KFLA=MAX(KFL1A,KFL3A)
3506           KFLB=MIN(KFL1A,KFL3A)
3507           IF(KFLA.NE.KFL1A) KFS=-KFS
3508         ELSE
3509           CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3510           GOTO 100
3511         ENDIF
3512         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3513
3514 C...Reconstruct baryon code.
3515       ELSE
3516         IF(KTAB1.GE.7) THEN
3517           KFLA=KFL3A
3518           KFLB=KFL1A
3519           KFLC=KFL1B
3520         ELSE
3521           KFLA=KFL1A
3522           KFLB=KFL3A
3523           KFLC=KFL3B
3524         ENDIF
3525         KFLD=MAX(KFLA,KFLB,KFLC)
3526         KFLF=MIN(KFLA,KFLB,KFLC)
3527         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3528         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3529         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3530       ENDIF
3531
3532 C...Check that constructed flavour code is an allowed one.
3533       IF(KFL2.NE.0) KFL3=0
3534       KC=LUCOMP(KF)
3535       IF(KC.EQ.0) THEN
3536         CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3537      &  'failed')
3538         GOTO 100
3539       ENDIF
3540
3541       RETURN
3542       END
3543
3544 C*********************************************************************
3545
3546       SUBROUTINE LUPTDI(KFL,PX,PY)
3547
3548 C...Purpose: to generate transverse momentum according to a Gaussian.
3549       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3550       SAVE
3551
3552 C...Generate p_T and azimuthal angle, gives p_x and p_y.
3553       KFLA=IABS(KFL)
3554       PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3555       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3556       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3557       PHI=PARU(2)*RLU(0)
3558       PX=PT*COS(PHI)
3559       PY=PT*SIN(PHI)
3560
3561       RETURN
3562       END
3563
3564 C*********************************************************************
3565
3566       SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3567
3568 C...Purpose: to generate the longitudinal splitting variable z.
3569       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3570       SAVE /LUDAT1/
3571
3572 C...Check if heavy flavour fragmentation.
3573       KFLA=IABS(KFL1)
3574       KFLB=IABS(KFL2)
3575       ZDIVC=0.
3576       ZDIV=0.
3577       fint=0.
3578       KFLH=KFLA
3579       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3580
3581 C...Lund symmetric scaling function: determine parameters of shape.
3582       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3)) THEN
3583         FA=PARJ(41)
3584         IF(MSTJ(91).EQ.1) FA=PARJ(43)
3585         IF(KFLB.GE.10) FA=FA+PARJ(45)
3586         FB=PARJ(42)*PR
3587         IF(MSTJ(91).EQ.1) FB=PARJ(44)*PR
3588         FC=1.
3589         IF(KFLA.GE.10) FC=FC-PARJ(45)
3590         IF(KFLB.GE.10) FC=FC+PARJ(45)
3591         MC=1
3592         IF(ABS(FC-1.).GT.0.01) MC=2
3593
3594 C...Determine position of maximum. Special cases for a = 0 or a = c.
3595         IF(FA.LT.0.02) THEN
3596           MA=1
3597           ZMAX=1.
3598           IF(FC.GT.FB) ZMAX=FB/FC
3599         ELSEIF(ABS(FC-FA).LT.0.01) THEN
3600           MA=2
3601           ZMAX=FB/(FB+FC)
3602         ELSE
3603           MA=3
3604           ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3605           IF(ZMAX.GT.0.99.AND.FB.GT.100.) ZMAX=1.-FA/FB
3606         ENDIF
3607
3608 C...Subdivide z range if distribution very peaked near endpoint.
3609         MMAX=2
3610         IF(ZMAX.LT.0.1) THEN
3611           MMAX=1
3612           ZDIV=2.75*ZMAX
3613           IF(MC.EQ.1) THEN
3614             FINT=1.-LOG(ZDIV)
3615           ELSE
3616             ZDIVC=ZDIV**(1.-FC)
3617             FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3618           ENDIF
3619         ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3620           MMAX=3
3621           FSCB=SQRT(4.+(FC/FB)**2)
3622           ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3623           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3624           ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3625           FINT=1.+FB*(1.-ZDIV)
3626         ENDIF
3627
3628 C...Choice of z, preweighted for peaks at low or high z.
3629   100   Z=RLU(0)
3630         FPRE=1.
3631         IF(MMAX.EQ.1) THEN
3632           IF(FINT*RLU(0).LE.1.) THEN
3633             Z=ZDIV*Z
3634           ELSEIF(MC.EQ.1) THEN
3635             Z=ZDIV**Z
3636             FPRE=ZDIV/Z
3637           ELSE
3638             Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
3639             FPRE=(ZDIV/Z)**FC
3640           ENDIF
3641         ELSEIF(MMAX.EQ.3) THEN
3642           IF(FINT*RLU(0).LE.1.) THEN
3643             Z=ZDIV+LOG(Z)/FB
3644             FPRE=EXP(FB*(Z-ZDIV))
3645           ELSE
3646             Z=ZDIV+Z*(1.-ZDIV)
3647           ENDIF
3648         ENDIF
3649
3650 C...Weighting according to correct formula.
3651         IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100
3652         FVAL=(ZMAX/Z)**FC*EXP(FB*(1./ZMAX-1./Z))
3653         IF(MA.GE.2) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL
3654         IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
3655
3656 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
3657       ELSE
3658         FC=PARJ(50+MAX(1,KFLH))
3659         IF(MSTJ(91).EQ.1) FC=PARJ(59)
3660   110   Z=RLU(0)
3661         IF(FC.GE.0..AND.FC.LE.1.) THEN
3662           IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
3663         ELSEIF(FC.GT.-1.) THEN
3664           IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
3665         ELSE
3666           IF(FC.GT.0.) Z=1.-Z**(1./FC)
3667           IF(FC.LT.0.) Z=Z**(-1./FC)
3668         ENDIF
3669       ENDIF
3670
3671       RETURN
3672       END
3673
3674 C*********************************************************************
3675
3676       SUBROUTINE LUSHOW(IP1,IP2,QMAX)
3677
3678 C...Purpose: to generate timelike parton showers from given partons.
3679       IMPLICIT DOUBLE PRECISION(D)
3680       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3681       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3682       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3683       DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
3684      &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4)
3685       SAVE
3686
3687 C...Initialization of cutoff masses etc.
3688       IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
3689      &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
3690       PMTH(1,21)=ULMASS(21)
3691       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
3692       PMTH(3,21)=2.*PMTH(2,21)
3693       PMTH(4,21)=PMTH(3,21)
3694       PMTH(5,21)=PMTH(3,21)
3695       PMTH(1,22)=ULMASS(22)
3696       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
3697       PMTH(3,22)=2.*PMTH(2,22)
3698       PMTH(4,22)=PMTH(3,22)
3699       PMTH(5,22)=PMTH(3,22)
3700       PMQTH1=PARJ(82)
3701       IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
3702       PMQTH2=PMTH(2,21)
3703       IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
3704       DO 100 IF=1,8
3705       PMTH(1,IF)=ULMASS(IF)
3706       PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
3707       PMTH(3,IF)=PMTH(2,IF)+PMQTH2
3708       PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
3709   100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
3710       PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
3711       ALAMS=PARJ(81)**2
3712       ALFM=LOG(PT2MIN/ALAMS)
3713
3714 C...Store positions of shower initiating partons.
3715       M3JC=0
3716       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
3717         NPA=1
3718         IPA(1)=IP1
3719       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
3720      &MSTU(32))) THEN
3721         NPA=2
3722         IPA(1)=IP1
3723         IPA(2)=IP2
3724       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
3725      &AND.IP2.GE.-3) THEN
3726         NPA=IABS(IP2)
3727         DO 110 I=1,NPA
3728   110   IPA(I)=IP1+I-1
3729       ELSE
3730         CALL LUERRM(12,
3731      &  '(LUSHOW:) failed to reconstruct showering system')
3732         IF(MSTU(21).GE.1) RETURN
3733       ENDIF
3734
3735 C...Check on phase space available for emission.
3736       IREJ=0
3737       DO 120 J=1,5
3738   120 PS(J)=0.
3739       PM=0.
3740       DO 130 I=1,NPA
3741       KFLA(I)=IABS(K(IPA(I),2))
3742       PMA(I)=P(IPA(I),5)
3743       IF(KFLA(I).NE.0.AND.(KFLA(I).LE.8.OR.KFLA(I).EQ.21))
3744      &PMA(I)=PMTH(3,KFLA(I))
3745       PM=PM+PMA(I)
3746       IF(KFLA(I).EQ.0.OR.(KFLA(I).GT.8.AND.KFLA(I).NE.21).OR.
3747      &PMA(I).GT.QMAX) IREJ=IREJ+1
3748       DO 130 J=1,4
3749   130 PS(J)=PS(J)+P(IPA(I),J)
3750       IF(IREJ.EQ.NPA) RETURN
3751       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
3752       IF(NPA.EQ.1) PS(5)=PS(4)
3753       IF(PS(5).LE.PM+PMQTH1) RETURN
3754       IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
3755         IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
3756      &  KFLA(2).LE.8) M3JC=1
3757         IF(MSTJ(47).GE.2) M3JC=1
3758       ENDIF
3759
3760 C...Define imagined single initiator of shower for parton system.
3761       NS=N
3762       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
3763         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
3764         IF(MSTU(21).GE.1) RETURN
3765       ENDIF
3766       IF(NPA.GE.2) THEN
3767         K(N+1,1)=11
3768         K(N+1,2)=21
3769         K(N+1,3)=0
3770         K(N+1,4)=0
3771         K(N+1,5)=0
3772         P(N+1,1)=0.
3773         P(N+1,2)=0.
3774         P(N+1,3)=0.
3775         P(N+1,4)=PS(5)
3776         P(N+1,5)=PS(5)
3777         V(N+1,5)=PS(5)**2
3778         N=N+1
3779       ENDIF
3780
3781 C...Loop over partons that may branch.
3782       NEP=NPA
3783       IM=NS
3784       IF(NPA.EQ.1) IM=NS-1
3785   140 IM=IM+1
3786       IF(N.GT.NS) THEN
3787         IF(IM.GT.N) GOTO 380
3788         KFLM=IABS(K(IM,2))
3789         IF(KFLM.EQ.0.OR.(KFLM.GT.8.AND.KFLM.NE.21)) GOTO 140
3790         IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
3791         IGM=K(IM,3)
3792       ELSE
3793         IGM=-1
3794       ENDIF
3795       IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
3796         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
3797         IF(MSTU(21).GE.1) RETURN
3798       ENDIF
3799
3800 C...Position of aunt (sister to branching parton).
3801 C...Origin and flavour of daughters.
3802       IAU=0
3803       IF(IGM.GT.0) THEN
3804         IF(K(IM-1,3).EQ.IGM) IAU=IM-1
3805         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
3806       ENDIF
3807       IF(IGM.GE.0) THEN
3808         K(IM,4)=N+1
3809         DO 150 I=1,NEP
3810   150   K(N+I,3)=IM
3811       ELSE
3812         K(N+1,3)=IPA(1)
3813       ENDIF
3814       IF(IGM.LE.0) THEN
3815         DO 160 I=1,NEP
3816   160   K(N+I,2)=K(IPA(I),2)
3817       ELSEIF(KFLM.NE.21) THEN
3818         K(N+1,2)=K(IM,2)
3819         K(N+2,2)=K(IM,5)
3820       ELSEIF(K(IM,5).EQ.21) THEN
3821         K(N+1,2)=21
3822         K(N+2,2)=21
3823       ELSE
3824         K(N+1,2)=K(IM,5)
3825         K(N+2,2)=-K(IM,5)
3826       ENDIF
3827
3828 C...Reset flags on daughers and tries made.
3829       DO 170 IP=1,NEP
3830       K(N+IP,1)=3
3831       K(N+IP,4)=0
3832       K(N+IP,5)=0
3833       KFLD(IP)=IABS(K(N+IP,2))
3834       ITRY(IP)=0
3835       ISL(IP)=0
3836       ISI(IP)=0
3837   170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1
3838       ISLM=0
3839
3840 C...Maximum virtuality of daughters.
3841       IF(IGM.LE.0) THEN
3842         DO 180 I=1,NPA
3843         IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
3844      &  PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
3845         P(N+I,5)=MIN(QMAX,PS(5))
3846         IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
3847   180   IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
3848       ELSE
3849         IF(MSTJ(43).LE.2) PEM=V(IM,2)
3850         IF(MSTJ(43).GE.3) PEM=P(IM,4)
3851         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
3852         P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
3853         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
3854       ENDIF
3855       DO 190 I=1,NEP
3856       PMSD(I)=P(N+I,5)
3857       IF(ISI(I).EQ.1) THEN
3858         IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))
3859       ENDIF
3860   190 V(N+I,5)=P(N+I,5)**2
3861
3862 C...Choose one of the daughters for evolution.
3863   200 INUM=0
3864       IF(NEP.EQ.1) INUM=1
3865       DO 210 I=1,NEP
3866   210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
3867       DO 220 I=1,NEP
3868       IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
3869         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I
3870       ENDIF
3871   220 CONTINUE
3872       IF(INUM.EQ.0) THEN
3873         RMAX=0.
3874         DO 230 I=1,NEP
3875         IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
3876           RPM=P(N+I,5)/PMSD(I)
3877           IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN
3878             RMAX=RPM
3879             INUM=I
3880           ENDIF
3881         ENDIF
3882   230   CONTINUE
3883       ENDIF
3884
3885 C...Store information on choice of evolving daughter.
3886       INUM=MAX(1,INUM)
3887       IEP(1)=N+INUM
3888       DO 240 I=2,NEP
3889       IEP(I)=IEP(I-1)+1
3890   240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
3891       DO 250 I=1,NEP
3892   250 KFL(I)=IABS(K(IEP(I),2))
3893       ITRY(INUM)=ITRY(INUM)+1
3894       IF(ITRY(INUM).GT.200) THEN
3895         CALL LUERRM(14,'(LUSHOW:) caught in infinite loop')
3896         IF(MSTU(21).GE.1) RETURN
3897       ENDIF
3898       Z=0.5
3899       IF(KFL(1).EQ.0.OR.(KFL(1).GT.8.AND.KFL(1).NE.21)) GOTO 300
3900       IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300
3901
3902 C...Calculate allowed z range.
3903       IF(NEP.EQ.1) THEN
3904         PMED=PS(4)
3905       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3906         PMED=P(IM,5)
3907       ELSE
3908         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
3909         IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
3910       ENDIF
3911       IF(MOD(MSTJ(43),2).EQ.1) THEN
3912         ZC=PMTH(2,21)/PMED
3913         ZCE=PMTH(2,22)/PMED
3914       ELSE
3915         ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
3916         IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
3917         ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
3918         IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
3919       ENDIF
3920       ZC=MIN(ZC,0.491)
3921       ZCE=MIN(ZCE,0.491)
3922       IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
3923      &MIN(ZC,ZCE).GT.0.49)) THEN
3924         P(IEP(1),5)=PMTH(1,KFL(1))
3925         V(IEP(1),5)=P(IEP(1),5)**2
3926         GOTO 300
3927       ENDIF
3928
3929 C...Integral of Altarelli-Parisi z kernel for QCD.
3930       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
3931         FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
3932       ELSEIF(MSTJ(49).EQ.0) THEN
3933         FBR=(8./3.)*LOG((1.-ZC)/ZC)
3934
3935 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
3936       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
3937         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
3938       ELSEIF(MSTJ(49).EQ.1) THEN
3939         FBR=(1.-2.*ZC)/3.
3940         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
3941
3942 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
3943       ELSEIF(KFL(1).EQ.21) THEN
3944         FBR=6.*MSTJ(45)*(0.5-ZC)
3945       ELSE
3946         FBR=2.*LOG((1.-ZC)/ZC)
3947       ENDIF
3948
3949 C...Integral of Altarelli-Parisi kernel for photon emission.
3950       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8)
3951      &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
3952
3953 C...Inner veto algorithm starts. Find maximum mass for evolution.
3954   260 PMS=V(IEP(1),5)
3955       IF(IGM.GE.0) THEN
3956         PM2=0.
3957         DO 270 I=2,NEP
3958         PM=P(IEP(I),5)
3959         IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=
3960      &  PMTH(2,KFL(I))
3961   270   PM2=PM2+PM
3962         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
3963       ENDIF
3964
3965 C...Select mass for daughter in QCD evolution.
3966       B0=27./6.
3967       DO 280 IF=4,MSTJ(45)
3968   280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
3969       IF(MSTJ(44).LE.0) THEN
3970         PMSQCD=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
3971       ELSEIF(MSTJ(44).EQ.1) THEN
3972         PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
3973       ELSE
3974         PMSQCD=PMS*RLU(0)**(ALFM*B0/FBR)
3975       ENDIF
3976       IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
3977      &PMTH(2,KFL(1))**2
3978       V(IEP(1),5)=PMSQCD
3979       MCE=1
3980
3981 C...Select mass for daughter in QED evolution.
3982       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN
3983         PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
3984         IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
3985      &  PMTH(2,KFL(1))**2
3986         IF(PMSQED.GT.PMSQCD) THEN
3987           V(IEP(1),5)=PMSQED
3988           MCE=2
3989         ENDIF
3990       ENDIF
3991
3992 C...Check whether daughter mass below cutoff.
3993       P(IEP(1),5)=SQRT(V(IEP(1),5))
3994       IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
3995         P(IEP(1),5)=PMTH(1,KFL(1))
3996         V(IEP(1),5)=P(IEP(1),5)**2
3997         GOTO 300
3998       ENDIF
3999
4000 C...Select z value of branching: q -> qgamma.
4001       IF(MCE.EQ.2) THEN
4002         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
4003         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4004         K(IEP(1),5)=22
4005
4006 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4007       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
4008         Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4009         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4010         K(IEP(1),5)=21
4011       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
4012         Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4013         IF(RLU(0).GT.0.5) Z=1.-Z
4014         IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
4015         K(IEP(1),5)=21
4016       ELSEIF(MSTJ(49).NE.1) THEN
4017         Z=ZC+(1.-2.*ZC)*RLU(0)
4018         IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
4019         KFLB=1+INT(MSTJ(45)*RLU(0))
4020         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4021         IF(PMQ.GE.1.) GOTO 260
4022         PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
4023         IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
4024      &  RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
4025         K(IEP(1),5)=KFLB
4026
4027 C...Ditto for scalar gluon model.
4028       ELSEIF(KFL(1).NE.21) THEN
4029         Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
4030         K(IEP(1),5)=21
4031       ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4032         Z=ZC+(1.-2.*ZC)*RLU(0)
4033         K(IEP(1),5)=21
4034       ELSE
4035         Z=ZC+(1.-2.*ZC)*RLU(0)
4036         KFLB=1+INT(MSTJ(45)*RLU(0))
4037         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4038         IF(PMQ.GE.1.) GOTO 260
4039         K(IEP(1),5)=KFLB
4040       ENDIF
4041       IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
4042         IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
4043         IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
4044       ENDIF
4045
4046 C...Check if z consistent with chosen m.
4047       IF(KFL(1).EQ.21) THEN
4048         KFLGD1=IABS(K(IEP(1),5))
4049         KFLGD2=KFLGD1
4050       ELSE
4051         KFLGD1=KFL(1)
4052         KFLGD2=IABS(K(IEP(1),5))
4053       ENDIF
4054       IF(NEP.EQ.1) THEN
4055         PED=PS(4)
4056       ELSEIF(NEP.GE.3) THEN
4057         PED=P(IEP(1),4)
4058       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4059         PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
4060       ELSE
4061         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
4062         IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
4063       ENDIF
4064       IF(MOD(MSTJ(43),2).EQ.1) THEN
4065         PMQTH3=0.5*PARJ(82)
4066         IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4067         PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
4068         PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
4069         ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4070      &  4.*PMQ1*PMQ2)))
4071         ZH=1.+PMQ1-PMQ2
4072       ELSE
4073         ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4074         ZH=1.
4075       ENDIF
4076       ZL=0.5*(ZH-ZD)
4077       ZU=0.5*(ZH+ZD)
4078       IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
4079       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
4080      &(1.-ZU)))
4081       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4082
4083 C...Three-jet matrix element correction.
4084       IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
4085         X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
4086         X2=1.-V(IEP(1),5)/V(NS+1,5)
4087         X3=(1.-X1)+(1.-X2)
4088         IF(MCE.EQ.2) THEN
4089           KI1=K(IPA(INUM),2)
4090           KI2=K(IPA(3-INUM),2)
4091           QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
4092           QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
4093           WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
4094      &    QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
4095           WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
4096         ELSEIF(MSTJ(49).NE.1) THEN
4097           WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
4098      &    (1.-X2)/X3*(X2/(2.-X1))**2
4099           WME=X1**2+X2**2
4100         ELSE
4101           WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
4102           WME=X3**2
4103         ENDIF
4104         IF(WME.LT.RLU(0)*WSHOW) GOTO 260
4105
4106 C...Impose angular ordering by rejection of nonordered emission.
4107       ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
4108         MAOM=1
4109         ZM=V(IM,1)
4110         IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
4111         THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
4112         IAOM=IM
4113   290   IF(K(IAOM,5).EQ.22) THEN
4114           IAOM=K(IAOM,3)
4115           IF(K(IAOM,3).LE.NS) MAOM=0
4116           IF(MAOM.EQ.1) GOTO 290
4117         ENDIF
4118         IF(MAOM.EQ.1) THEN
4119           THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
4120           IF(THE2ID.LT.THE2IM) GOTO 260
4121         ENDIF
4122       ENDIF
4123
4124 C...Impose user-defined maximum angle at first branching.
4125       IF(MSTJ(48).EQ.1) THEN
4126         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
4127           THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
4128           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4129         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
4130           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4131           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4132         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
4133           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4134           IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
4135         ENDIF
4136       ENDIF
4137
4138 C...End of inner veto algorithm. Check if only one leg evolved so far.
4139   300 V(IEP(1),1)=Z
4140       ISL(1)=0
4141       ISL(2)=0
4142       IF(NEP.EQ.1) GOTO 330
4143       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
4144       DO 310 I=1,NEP
4145       IF(ITRY(I).EQ.0.AND.KFLD(I).GT.0.AND.(KFLD(I).LE.8.OR.KFLD(I).EQ.
4146      &21)) THEN
4147         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
4148       ENDIF
4149   310 CONTINUE
4150
4151 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4152       IF(NEP.EQ.3) THEN
4153         PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
4154         PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
4155         PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
4156         PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
4157      &  PA1S**2-PA2S**2-PA3S**2)/PA1S
4158         IF(PTS.LE.0.) GOTO 200
4159       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
4160         DO 320 I1=N+1,N+2
4161         KFLDA=IABS(K(I1,2))
4162         IF(KFLDA.EQ.0.OR.(KFLDA.GT.8.AND.KFLDA.NE.21)) GOTO 320
4163         IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
4164         IF(KFLDA.EQ.21) THEN
4165           KFLGD1=IABS(K(I1,5))
4166           KFLGD2=KFLGD1
4167         ELSE
4168           KFLGD1=KFLDA
4169           KFLGD2=IABS(K(I1,5))
4170         ENDIF
4171         I2=2*N+3-I1
4172         IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4173           PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
4174         ELSE
4175           IF(I1.EQ.N+1) ZM=V(IM,1)
4176           IF(I1.EQ.N+2) ZM=1.-V(IM,1)
4177           PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
4178      &    4.*V(N+1,5)*V(N+2,5))
4179           PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
4180         ENDIF
4181         IF(MOD(MSTJ(43),2).EQ.1) THEN
4182           PMQTH3=0.5*PARJ(82)
4183           IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4184           PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
4185           PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
4186           ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4187      &    4.*PMQ1*PMQ2)))
4188           ZH=1.+PMQ1-PMQ2
4189         ELSE
4190           ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
4191           ZH=1.
4192         ENDIF
4193         ZL=0.5*(ZH-ZD)
4194         ZU=0.5*(ZH+ZD)
4195         IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
4196         IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
4197         IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
4198         IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4199   320   CONTINUE
4200         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
4201           ISL(3-ISLM)=0
4202           ISLM=3-ISLM
4203         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
4204           ZDR1=MAX(0.,V(N+1,3)/V(N+1,4)-1.)
4205           ZDR2=MAX(0.,V(N+2,3)/V(N+2,4)-1.)
4206           IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
4207           IF(ISL(1).EQ.1) ISL(2)=0
4208           IF(ISL(1).EQ.0) ISLM=1
4209           IF(ISL(2).EQ.0) ISLM=2
4210         ENDIF
4211         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
4212       ENDIF
4213       IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
4214      &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
4215         PMQ1=V(N+1,5)/V(IM,5)
4216         PMQ2=V(N+2,5)/V(IM,5)
4217         ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
4218      &  4.*PMQ1*PMQ2)))
4219         ZH=1.+PMQ1-PMQ2
4220         ZL=0.5*(ZH-ZD)
4221         ZU=0.5*(ZH+ZD)
4222         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
4223       ENDIF
4224
4225 C...Accepted branch. Construct four-momentum for initial partons.
4226   330 MAZIP=0
4227       MAZIC=0
4228       IF(NEP.EQ.1) THEN
4229         P(N+1,1)=0.
4230         P(N+1,2)=0.
4231         P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
4232      &  P(N+1,5))))
4233         P(N+1,4)=P(IPA(1),4)
4234         V(N+1,2)=P(N+1,4)
4235       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
4236         PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
4237         P(N+1,1)=0.
4238         P(N+1,2)=0.
4239         P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
4240         P(N+1,4)=PED1
4241         P(N+2,1)=0.
4242         P(N+2,2)=0.
4243         P(N+2,3)=-P(N+1,3)
4244         P(N+2,4)=P(IM,5)-PED1
4245         V(N+1,2)=P(N+1,4)
4246         V(N+2,2)=P(N+2,4)
4247       ELSEIF(NEP.EQ.3) THEN
4248         P(N+1,1)=0.
4249         P(N+1,2)=0.
4250         P(N+1,3)=SQRT(MAX(0.,PA1S))
4251         P(N+2,1)=SQRT(PTS)
4252         P(N+2,2)=0.
4253         P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4254         P(N+3,1)=-P(N+2,1)
4255         P(N+3,2)=0.
4256         P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4257         V(N+1,2)=P(N+1,4)
4258         V(N+2,2)=P(N+2,4)
4259         V(N+3,2)=P(N+3,4)
4260
4261 C...Construct transverse momentum for ordinary branching in shower.
4262       ELSE
4263         ZM=V(IM,1)
4264         PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4265         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4266         IF(PZM.LE.0.) THEN
4267           PTS=0.
4268         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4269           PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4270      &    ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4271         ELSE
4272           PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4273         ENDIF
4274         PT=SQRT(MAX(0.,PTS))
4275
4276 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4277         HAZIP=0.
4278         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4279      &  AND.IAU.NE.0) THEN
4280           IF(K(IGM,3).NE.0) MAZIP=1
4281           ZAU=V(IGM,1)
4282           IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4283           IF(MAZIP.EQ.0) ZAU=0.
4284           IF(K(IGM,2).NE.21) THEN
4285             HAZIP=2.*ZAU/(1.+ZAU**2)
4286           ELSE
4287             HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4288           ENDIF
4289           IF(K(N+1,2).NE.21) THEN
4290             HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4291           ELSE
4292             HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4293           ENDIF
4294         ENDIF
4295
4296 C...Find coefficient of azimuthal asymmetry due to soft gluon
4297 C...interference.
4298         HAZIC=0.
4299         IF(MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.K(N+2,2).EQ.21).
4300      &  AND.IAU.NE.0) THEN
4301           IF(K(IGM,3).NE.0) MAZIC=N+1
4302           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4303           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4304      &    ZM.GT.0.5) MAZIC=N+2
4305           IF(K(IAU,2).EQ.22) MAZIC=0
4306           ZS=ZM
4307           IF(MAZIC.EQ.N+2) ZS=1.-ZM
4308           ZGM=V(IGM,1)
4309           IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4310           IF(MAZIC.EQ.0) ZGM=1.
4311           HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4312           HAZIC=MIN(0.95,HAZIC)
4313         ENDIF
4314       ENDIF
4315
4316 C...Construct kinematics for ordinary branching in shower.
4317   340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4318         IF(MOD(MSTJ(43),2).EQ.1) THEN
4319           P(N+1,4)=PEM*V(IM,1)
4320         ELSE
4321           P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4322      &    SQRT(PMLS)*ZM)/V(IM,5)
4323         ENDIF
4324         PHI=PARU(2)*RLU(0)
4325         P(N+1,1)=PT*COS(PHI)
4326         P(N+1,2)=PT*SIN(PHI)
4327         IF(PZM.GT.0.) THEN
4328           P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4329         ELSE
4330           P(N+1,3)=0.
4331         ENDIF
4332         P(N+2,1)=-P(N+1,1)
4333         P(N+2,2)=-P(N+1,2)
4334         P(N+2,3)=PZM-P(N+1,3)
4335         P(N+2,4)=PEM-P(N+1,4)
4336         IF(MSTJ(43).LE.2) THEN
4337           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4338           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4339         ENDIF
4340       ENDIF
4341
4342 C...Rotate and boost daughters.
4343       IF(IGM.GT.0) THEN
4344         IF(MSTJ(43).LE.2) THEN
4345           BEX=P(IGM,1)/P(IGM,4)
4346           BEY=P(IGM,2)/P(IGM,4)
4347           BEZ=P(IGM,3)/P(IGM,4)
4348           GA=P(IGM,4)/P(IGM,5)
4349           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4350      &    P(IM,4))
4351         ELSE
4352           BEX=0.
4353           BEY=0.
4354           BEZ=0.
4355           GA=1.
4356           GABEP=0.
4357         ENDIF
4358         THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4359      &  (P(IM,2)+GABEP*BEY)**2))
4360         PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4361         DO 350 I=N+1,N+2
4362         DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4363      &  SIN(THE)*COS(PHI)*P(I,3)
4364         DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4365      &  SIN(THE)*SIN(PHI)*P(I,3)
4366         DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
4367         DP(4)=P(I,4)
4368         DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
4369         DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
4370         P(I,1)=DP(1)+DGABP*BEX
4371         P(I,2)=DP(2)+DGABP*BEY
4372         P(I,3)=DP(3)+DGABP*BEZ
4373   350   P(I,4)=GA*(DP(4)+DBP)
4374       ENDIF
4375
4376 C...Weight with azimuthal distribution, if required.
4377       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4378         DO 360 J=1,3
4379         DPT(1,J)=P(IM,J)
4380         DPT(2,J)=P(IAU,J)
4381   360   DPT(3,J)=P(N+1,J)
4382         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4383         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4384         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4385         DO 370 J=1,3
4386         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4387   370   DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4388         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4389         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4390         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
4391           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4392      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
4393           IF(MAZIP.NE.0) THEN
4394             IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4395      &      GOTO 340
4396           ENDIF
4397           IF(MAZIC.NE.0) THEN
4398             IF(MAZIC.EQ.N+2) CAD=-CAD
4399             IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4400      &      LT.RLU(0)) GOTO 340
4401           ENDIF
4402         ENDIF
4403       ENDIF
4404
4405 C...Continue loop over partons that may branch, until none left.
4406       IF(IGM.GE.0) K(IM,1)=14
4407       N=N+NEP
4408       NEP=2
4409       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4410         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4411         IF(MSTU(21).GE.1) N=NS
4412         IF(MSTU(21).GE.1) RETURN
4413       ENDIF
4414       GOTO 140
4415
4416 C...Set information on imagined shower initiator.
4417   380 IF(NPA.GE.2) THEN
4418         K(NS+1,1)=11
4419         K(NS+1,2)=94
4420         K(NS+1,3)=IP1
4421         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4422         K(NS+1,4)=NS+2
4423         K(NS+1,5)=NS+1+NPA
4424         IIM=1
4425       ELSE
4426         IIM=0
4427       ENDIF
4428
4429 C...Reconstruct string drawing information.
4430       DO 390 I=NS+1+IIM,N
4431       IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4432         K(I,1)=1
4433       ELSEIF(K(I,1).LE.10) THEN
4434         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4435         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4436       ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4437         ID1=MOD(K(I,4),MSTU(5))
4438         IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4439         ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4440         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4441         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4442         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4443         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4444         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4445         K(ID2,5)=K(ID2,5)+MSTU(5)*I
4446       ELSE
4447         ID1=MOD(K(I,4),MSTU(5))
4448         ID2=ID1+1
4449         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4450         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4451         K(ID1,4)=K(ID1,4)+MSTU(5)*I
4452         K(ID1,5)=K(ID1,5)+MSTU(5)*I
4453         K(ID2,4)=0
4454         K(ID2,5)=0
4455       ENDIF
4456   390 CONTINUE
4457
4458 C...Transformation from CM frame.
4459       IF(NPA.GE.2) THEN
4460         BEX=PS(1)/PS(4)
4461         BEY=PS(2)/PS(4)
4462         BEZ=PS(3)/PS(4)
4463         GA=PS(4)/PS(5)
4464         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4465      &  /(1.+GA)-P(IPA(1),4))
4466       ELSE
4467         BEX=0.
4468         BEY=0.
4469         BEZ=0.
4470         GABEP=0.
4471       ENDIF
4472       THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4473      &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4474       PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4475       IF(NPA.EQ.3) THEN
4476         CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4477      &  SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4478      &  BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4479      &  GABEP*BEY))
4480         CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4481       ENDIF
4482       DBEX=DBLE(BEX)
4483       DBEY=DBLE(BEY)
4484       DBEZ=DBLE(BEZ)
4485       CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4486
4487 C...Decay vertex of shower.
4488       DO 400 I=NS+1,N
4489       DO 400 J=1,5
4490   400 V(I,J)=V(IP1,J)
4491
4492 C...Delete trivial shower, else connect initiators.
4493       IF(N.EQ.NS+NPA+IIM) THEN
4494         N=NS
4495       ELSE
4496         DO 410 IP=1,NPA
4497         K(IPA(IP),1)=14
4498         K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4499         K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4500         K(NS+IIM+IP,3)=IPA(IP)
4501         IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4502         K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4503   410   K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4504       ENDIF
4505
4506       RETURN
4507       END
4508
4509 C*********************************************************************
4510
4511       SUBROUTINE LUBOEI(NSAV)
4512
4513 C...Purpose: to modify event so as to approximately take into account
4514 C...Bose-Einstein effects according to a simple phenomenological
4515 C...parametrization.
4516       IMPLICIT DOUBLE PRECISION(D)
4517       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4518       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4519       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4520       SAVE
4521       DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4522
4523 C...Boost event to overall CM frame. Calculate CM energy.
4524       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4525       DO 100 J=1,4
4526   100 DPS(J)=0.
4527       DO 120 I=1,N
4528       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4529       DO 110 J=1,4
4530   110 DPS(J)=DPS(J)+P(I,J)
4531   120 CONTINUE
4532       CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4533      &-DPS(3)/DPS(4))
4534       PECM=0.
4535       DO 130 I=1,N
4536   130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4537
4538 C...Reserve copy of particles by species at end of record.
4539       NBE(0)=N+MSTU(3)
4540       DO 160 IBE=1,MIN(9,MSTJ(51))
4541       NBE(IBE)=NBE(IBE-1)
4542       DO 150 I=NSAV+1,N
4543       IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4544       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4545       IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4546         CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')
4547         RETURN
4548       ENDIF
4549       NBE(IBE)=NBE(IBE)+1
4550       K(NBE(IBE),1)=I
4551       DO 140 J=1,3
4552   140 P(NBE(IBE),J)=0.
4553   150 CONTINUE
4554   160 CONTINUE
4555
4556 C...Tabulate integral for subsequent momentum shift.
4557       DO 210 IBE=1,MIN(9,MSTJ(51))
4558       IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4559       IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4560      &LE.1) GOTO 180
4561       IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4562      &NBE(7)-NBE(6)).LE.1) GOTO 180
4563       IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4564       IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4565       IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4566       IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4567       IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4568       QDEL=0.1*MIN(PMHQ,PARJ(93))
4569       IF(MSTJ(51).EQ.1) THEN
4570         NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4571         BEEX=EXP(0.5*QDEL/PARJ(93))
4572         BERT=EXP(-QDEL/PARJ(93))
4573       ELSE
4574         NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4575       ENDIF
4576       DO 170 IBIN=1,NBIN
4577       QBIN=QDEL*(IBIN-0.5)
4578       BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4579       IF(MSTJ(51).EQ.1) THEN
4580         BEEX=BEEX*BERT
4581         BEI(IBIN)=BEI(IBIN)*BEEX
4582       ELSE
4583         BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4584       ENDIF
4585   170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4586
4587 C...Loop through particle pairs and find old relative momentum.
4588   180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4589       I1=K(I1M,1)
4590       DO 200 I2M=I1M+1,NBE(IBE)
4591       I2=K(I2M,1)
4592       Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
4593      &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
4594       QOLD=SQRT(Q2OLD)
4595
4596 C...Calculate new relative momentum.
4597       IF(QOLD.LT.0.5*QDEL) THEN
4598         QMOV=QOLD/3.
4599       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
4600         RBIN=QOLD/QDEL
4601         IBIN=RBIN
4602         RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
4603         QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
4604      &  SQRT(Q2OLD+PMHQ**2)/Q2OLD
4605       ELSE
4606         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
4607       ENDIF
4608       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
4609
4610 C...Calculate and save shift to be performed on three-momenta.
4611       HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
4612       HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
4613       HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
4614       DO 190 J=1,3
4615       PD=HA*(P(I2,J)-P(I1,J))
4616       P(I1M,J)=P(I1M,J)+PD
4617   190 P(I2M,J)=P(I2M,J)-PD
4618   200 CONTINUE
4619   210 CONTINUE
4620
4621 C...Shift momenta and recalculate energies.
4622       DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))
4623       I=K(IM,1)
4624       DO 220 J=1,3
4625   220 P(I,J)=P(I,J)+P(IM,J)
4626   230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4627
4628 C...Rescale all momenta for energy conservation.
4629       PES=0.
4630       PQS=0.
4631       DO 240 I=1,N
4632       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
4633       PES=PES+P(I,4)
4634       PQS=PQS+P(I,5)**2/P(I,4)
4635   240 CONTINUE
4636       FAC=(PECM-PQS)/(PES-PQS)
4637       DO 260 I=1,N
4638       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
4639       DO 250 J=1,3
4640   250 P(I,J)=FAC*P(I,J)
4641       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4642   260 CONTINUE
4643
4644 C...Boost back to correct reference frame.
4645       CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
4646
4647       RETURN
4648       END
4649
4650 C*********************************************************************
4651
4652       FUNCTION ULMASS(KF)
4653
4654 C...Purpose: to give the mass of a particle/parton.
4655       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4656       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4657       SAVE
4658
4659 C...Reset variables. Compressed code.
4660       ULMASS=0.
4661       KFA=IABS(KF)
4662       KC=LUCOMP(KF)
4663       IF(KC.EQ.0) RETURN
4664       PARF(106)=PMAS(6,1)
4665       PARF(107)=PMAS(7,1)
4666       PARF(108)=PMAS(8,1)
4667
4668 C...Guarantee use of constituent masses for internal checks.
4669       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
4670         ULMASS=PARF(100+KFA)
4671         IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
4672
4673 C...Masses that can be read directly off table.
4674       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4675         ULMASS=PMAS(KC,1)
4676
4677 C...Find constituent partons and their masses.
4678       ELSE
4679         KFLA=MOD(KFA/1000,10)
4680         KFLB=MOD(KFA/100,10)
4681         KFLC=MOD(KFA/10,10)
4682         KFLS=MOD(KFA,10)
4683         KFLR=MOD(KFA/10000,10)
4684         PMA=PARF(100+KFLA)
4685         PMB=PARF(100+KFLB)
4686         PMC=PARF(100+KFLC)
4687
4688 C...Construct masses for various meson, diquark and baryon cases.
4689         IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4690           IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
4691           IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
4692           ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
4693         ELSEIF(KFLA.EQ.0) THEN
4694           KMUL=2
4695           IF(KFLS.EQ.1) KMUL=3
4696           IF(KFLR.EQ.2) KMUL=4
4697           IF(KFLS.EQ.5) KMUL=5
4698           ULMASS=PARF(113+KMUL)+PMB+PMC
4699         ELSEIF(KFLC.EQ.0) THEN
4700           IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
4701           IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
4702           ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
4703           IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
4704           IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
4705      &    2.*PARF(112)/3.)
4706         ELSE
4707           IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
4708             PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
4709           ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
4710             PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
4711           ELSEIF(KFLS.EQ.2) THEN
4712             PMSPL=-3./(PMB*PMC)
4713           ELSE
4714             PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
4715           ENDIF
4716           ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
4717         ENDIF
4718       ENDIF
4719
4720 C...Optional mass broadening according to truncated Breit-Wigner
4721 C...(either in m or in m^2).
4722       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
4723         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
4724           ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
4725      &    ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
4726         ELSE
4727           PM0=ULMASS
4728           PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
4729      &    (PM0*PMAS(KC,2)))
4730           PMUPP=ATAN((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))
4731           ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
4732      &    (PMUPP-PMLOW)*RLU(0))))
4733         ENDIF
4734       ENDIF
4735       MSTJ(93)=0
4736
4737       RETURN
4738       END
4739
4740 C*********************************************************************
4741
4742       SUBROUTINE LUNAME(KF,CHAU)
4743
4744 C...Purpose: to give the particle/parton name as a character string.
4745       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4746       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4747       COMMON/LUDAT4/CHAF(500)
4748       CHARACTER CHAF*8
4749       CHARACTER CHAU*16
4750       SAVE
4751
4752 C...Initial values. Charge. Subdivide code.
4753       CHAU=' '
4754       KFA=IABS(KF)
4755       KC=LUCOMP(KF)
4756       IF(KC.EQ.0) RETURN
4757       KQ=LUCHGE(KF)
4758       KFLA=MOD(KFA/1000,10)
4759       KFLB=MOD(KFA/100,10)
4760       KFLC=MOD(KFA/10,10)
4761       KFLS=MOD(KFA,10)
4762       KFLR=MOD(KFA/10000,10)
4763
4764 C...Read out root name and spin for simple particle.
4765       IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
4766         CHAU=CHAF(KC)
4767         LEN=0
4768         DO 100 LEM=1,8
4769   100   IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
4770
4771 C...Construct root name for diquark. Add on spin.
4772       ELSEIF(KFLC.EQ.0) THEN
4773         CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
4774         IF(KFLS.EQ.1) CHAU(3:4)='_0'
4775         IF(KFLS.EQ.3) CHAU(3:4)='_1'
4776         LEN=4
4777
4778 C...Construct root name for heavy meson. Add on spin and heavy flavour.
4779       ELSEIF(KFLA.EQ.0) THEN
4780         IF(KFLB.EQ.5) CHAU(1:1)='B'
4781         IF(KFLB.EQ.6) CHAU(1:1)='T'
4782         IF(KFLB.EQ.7) CHAU(1:1)='L'
4783         IF(KFLB.EQ.8) CHAU(1:1)='H'
4784         LEN=1
4785         IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4786         ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4787           CHAU(2:2)='*'
4788           LEN=2
4789         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4790           CHAU(2:3)='_1'
4791           LEN=3
4792         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4793           CHAU(2:4)='*_0'
4794           LEN=4
4795         ELSEIF(KFLR.EQ.2) THEN
4796           CHAU(2:4)='*_1'
4797           LEN=4
4798         ELSEIF(KFLS.EQ.5) THEN
4799           CHAU(2:4)='*_2'
4800           LEN=4
4801         ENDIF
4802         IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4803           CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
4804           LEN=LEN+2
4805         ELSEIF(KFLC.GE.3) THEN
4806           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4807           LEN=LEN+1
4808         ENDIF
4809
4810 C...Construct root name and spin for heavy baryon.
4811       ELSE
4812         IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
4813           CHAU='Sigma '
4814           IF(KFLC.GT.KFLB) CHAU='Lambda'
4815           IF(KFLS.EQ.4) CHAU='Sigma*'
4816           LEN=5
4817           IF(CHAU(6:6).NE.' ') LEN=6
4818         ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
4819           CHAU='Xi '
4820           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
4821           IF(KFLS.EQ.4) CHAU='Xi*'
4822           LEN=2
4823           IF(CHAU(3:3).NE.' ') LEN=3
4824         ELSE
4825           CHAU='Omega '
4826           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
4827           IF(KFLS.EQ.4) CHAU='Omega*'
4828           LEN=5
4829           IF(CHAU(6:6).NE.' ') LEN=6
4830         ENDIF
4831
4832 C...Add on heavy flavour content for heavy baryon.
4833         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
4834         LEN=LEN+2
4835         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
4836           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
4837           LEN=LEN+2
4838         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
4839           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
4840           LEN=LEN+1
4841         ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
4842           CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
4843           LEN=LEN+2
4844         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
4845           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4846           LEN=LEN+1
4847         ENDIF
4848       ENDIF
4849
4850 C...Add on bar sign for antiparticle (where necessary).
4851       IF(KF.GT.0.OR.LEN.EQ.0) THEN
4852       ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN
4853       ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
4854       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
4855       ELSEIF(MSTU(15).LE.1) THEN
4856         CHAU(LEN+1:LEN+1)='~'
4857         LEN=LEN+1
4858       ELSE
4859         CHAU(LEN+1:LEN+3)='bar'
4860         LEN=LEN+3
4861       ENDIF
4862
4863 C...Add on charge where applicable (conventional cases skipped).
4864       IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
4865       IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
4866       IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
4867       IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
4868       IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
4869       ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
4870       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
4871      &KFLB.NE.1) THEN
4872       ELSEIF(KQ.EQ.0) THEN
4873         CHAU(LEN+1:LEN+1)='0'
4874       ENDIF
4875
4876       RETURN
4877       END
4878
4879 C*********************************************************************
4880
4881       FUNCTION LUCHGE(KF)
4882
4883 C...Purpose: to give three times the charge for a particle/parton.
4884       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4885       SAVE
4886
4887 C...Initial values. Simple case of direct readout.
4888       LUCHGE=0
4889       KFA=IABS(KF)
4890       KC=LUCOMP(KFA)
4891       IF(KC.EQ.0) THEN
4892       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4893         LUCHGE=KCHG(KC,1)
4894
4895 C...Construction from quark content for heavy meson, diquark, baryon.
4896       ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
4897         LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
4898      &  (-1)**MOD(KFA/100,10)
4899       ELSEIF(MOD(KFA/10,10).EQ.0) THEN
4900         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
4901       ELSE
4902         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
4903      &  KCHG(MOD(KFA/10,10),1)
4904       ENDIF
4905
4906 C...Add on correct sign.
4907       LUCHGE=LUCHGE*ISIGN(1,KF)
4908
4909       RETURN
4910       END
4911
4912 C*********************************************************************
4913
4914       FUNCTION LUCOMP(KF)
4915
4916 C...Purpose: to compress the standard KF codes for use in mass and decay
4917 C...arrays; also to check whether a given code actually is defined.
4918       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4919       SAVE
4920
4921 C...Subdivide KF code into constituent pieces.
4922       LUCOMP=0
4923       KFA=IABS(KF)
4924       KFLA=MOD(KFA/1000,10)
4925       KFLB=MOD(KFA/100,10)
4926       KFLC=MOD(KFA/10,10)
4927       KFLS=MOD(KFA,10)
4928       KFLR=MOD(KFA/10000,10)
4929
4930 C...Simple cases: direct translation or special codes.
4931       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
4932       ELSEIF(KFA.LE.100) THEN
4933         LUCOMP=KFA
4934         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
4935       ELSEIF(KFLS.EQ.0) THEN
4936         IF(KF.EQ.130) LUCOMP=221
4937         IF(KF.EQ.310) LUCOMP=222
4938         IF(KFA.EQ.210) LUCOMP=281
4939         IF(KFA.EQ.2110) LUCOMP=282
4940         IF(KFA.EQ.2210) LUCOMP=283
4941
4942 C...Mesons.
4943       ELSEIF(KFA-10000*KFLR.LT.1000) THEN
4944         IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
4945         ELSEIF(KFLB.LT.KFLC) THEN
4946         ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
4947         ELSEIF(KFLB.EQ.KFLC) THEN
4948           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4949             LUCOMP=110+KFLB
4950           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4951             LUCOMP=130+KFLB
4952           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4953             LUCOMP=150+KFLB
4954           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4955             LUCOMP=170+KFLB
4956           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4957             LUCOMP=190+KFLB
4958           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4959             LUCOMP=210+KFLB
4960           ENDIF
4961         ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
4962           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4963             LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
4964           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4965             LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
4966           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4967             LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
4968           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4969             LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
4970           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4971             LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
4972           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4973             LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
4974           ENDIF
4975         ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
4976      &  OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
4977           LUCOMP=80+KFLB
4978         ENDIF
4979
4980 C...Diquarks.
4981       ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
4982         IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
4983         ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
4984         ELSEIF(KFLA.LT.KFLB) THEN
4985         ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
4986         ELSE
4987           LUCOMP=90
4988         ENDIF
4989
4990 C...Spin 1/2 baryons.
4991       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
4992         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
4993         ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
4994         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
4995           LUCOMP=80+KFLA
4996         ELSEIF(KFLB.LT.KFLC) THEN
4997           LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
4998         ELSE
4999           LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5000         ENDIF
5001
5002 C...Spin 3/2 baryons.
5003       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
5004         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5005         ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
5006         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
5007           LUCOMP=80+KFLA
5008         ELSE
5009           LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5010         ENDIF
5011       ENDIF
5012
5013       RETURN
5014       END
5015
5016 C*********************************************************************
5017
5018       SUBROUTINE LUERRM(MERR,CHMESS)
5019
5020 C...Purpose: to inform user of errors in program execution.
5021       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5022       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5023       CHARACTER CHMESS*(*)
5024       SAVE
5025
5026 C...Write first few warnings, then be silent.
5027       IF(MERR.LE.10) THEN
5028         MSTU(27)=MSTU(27)+1
5029         MSTU(28)=MERR
5030         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000)
5031      &  MERR,MSTU(31),CHMESS
5032
5033 C...Write first few errors, then be silent or stop program.
5034       ELSEIF(MERR.LE.20) THEN
5035         MSTU(23)=MSTU(23)+1
5036         MSTU(24)=MERR-10
5037         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100)
5038      &  MERR-10,MSTU(31),CHMESS
5039         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
5040           WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS
5041           WRITE(MSTU(11),1200)
5042           IF(MERR.NE.17) CALL LULIST(2)
5043           STOP
5044         ENDIF
5045
5046 C...Stop program in case of irreparable error.
5047       ELSE
5048         WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS
5049         STOP
5050       ENDIF
5051
5052 C...Formats for output.
5053  1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
5054      &' LUEXEC calls:'/5X,A)
5055  1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
5056      &' LUEXEC calls:'/5X,A)
5057  1200 FORMAT(5X,'Execution will be stopped after listing of last ',
5058      &'event!')
5059  1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
5060      &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
5061
5062       RETURN
5063       END
5064
5065 C*********************************************************************
5066
5067       FUNCTION ULALPS(Q2)
5068
5069 C...Purpose: to give the value of alpha_strong.
5070       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5071       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5072       SAVE
5073
5074 C...Constant alpha_strong trivial.
5075       IF(MSTU(111).LE.0) THEN
5076         ULALPS=PARU(111)
5077         MSTU(118)=MSTU(112)
5078         PARU(117)=0.
5079         PARU(118)=PARU(111)
5080         RETURN
5081       ENDIF
5082
5083 C...Find effective Q2, number of flavours and Lambda.
5084       Q2EFF=Q2
5085       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
5086       NF=MSTU(112)
5087       ALAM2=PARU(112)**2
5088   100 IF(NF.GT.MAX(2,MSTU(113))) THEN
5089         Q2THR=PARU(113)*PMAS(NF,1)**2
5090         IF(Q2EFF.LT.Q2THR) THEN
5091           NF=NF-1
5092           ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
5093           GOTO 100
5094         ENDIF
5095       ENDIF
5096   110 IF(NF.LT.MIN(8,MSTU(114))) THEN
5097         Q2THR=PARU(113)*PMAS(NF+1,1)**2
5098         IF(Q2EFF.GT.Q2THR) THEN
5099           NF=NF+1
5100           ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
5101           GOTO 110
5102         ENDIF
5103       ENDIF
5104       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
5105       PARU(117)=SQRT(ALAM2)
5106
5107 C...Evaluate first or second order alpha_strong.
5108       B0=(33.-2.*NF)/6.
5109       ALGQ=LOG(Q2EFF/ALAM2)
5110       IF(MSTU(111).EQ.1) THEN
5111         ULALPS=PARU(2)/(B0*ALGQ)
5112       ELSE
5113         B1=(153.-19.*NF)/6.
5114         ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ))
5115       ENDIF
5116       MSTU(118)=NF
5117       PARU(118)=ULALPS
5118
5119       RETURN
5120       END
5121
5122 C*********************************************************************
5123
5124       FUNCTION ULANGL(X,Y)
5125
5126 C...Purpose: to reconstruct an angle from given x and y coordinates.
5127       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5128       SAVE
5129
5130       ULANGL=0.
5131       R=SQRT(X**2+Y**2)
5132       IF(R.LT.1E-20) RETURN
5133       IF(ABS(X)/R.LT.0.8) THEN
5134         ULANGL=SIGN(ACOS(X/R),Y)
5135       ELSE
5136         ULANGL=ASIN(Y/R)
5137         IF(X.LT.0..AND.ULANGL.GE.0.) THEN
5138           ULANGL=PARU(1)-ULANGL
5139         ELSEIF(X.LT.0.) THEN
5140           ULANGL=-PARU(1)-ULANGL
5141         ENDIF
5142       ENDIF
5143
5144       RETURN
5145       END
5146
5147 C*********************************************************************
5148
5149       SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
5150
5151 C...Purpose: to perform rotations and boosts.
5152       IMPLICIT DOUBLE PRECISION(D)
5153       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5154       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5155       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5156       SAVE
5157
5158 C...Find range of rotation/boost. Convert boost to double precision.
5159       IMIN=1
5160       IF(MSTU(1).GT.0) IMIN=MSTU(1)
5161       IMAX=N
5162       IF(MSTU(2).GT.0) IMAX=MSTU(2)
5163       DBX=BEX
5164       DBY=BEY
5165       DBZ=BEZ
5166       GOTO 100
5167
5168 C...Entry for specific range and double precision boost.
5169       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5170       IMIN=IMI
5171       IF(IMIN.LE.0) IMIN=1
5172       IMAX=IMA
5173       IF(IMAX.LE.0) IMAX=N
5174       DBX=DBEX
5175       DBY=DBEY
5176       DBZ=DBEZ
5177
5178 C...Check range of rotation/boost.
5179   100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5180         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5181         RETURN
5182       ENDIF
5183
5184 C...Rotate, typically from z axis to direction (theta,phi).
5185       IF(THE**2+PHI**2.GT.1E-20) THEN
5186         ROT(1,1)=COS(THE)*COS(PHI)
5187         ROT(1,2)=-SIN(PHI)
5188         ROT(1,3)=SIN(THE)*COS(PHI)
5189         ROT(2,1)=COS(THE)*SIN(PHI)
5190         ROT(2,2)=COS(PHI)
5191         ROT(2,3)=SIN(THE)*SIN(PHI)
5192         ROT(3,1)=-SIN(THE)
5193         ROT(3,2)=0.
5194         ROT(3,3)=COS(THE)
5195         DO 130 I=IMIN,IMAX
5196         IF(K(I,1).LE.0) GOTO 130
5197         DO 110 J=1,3
5198         PR(J)=P(I,J)
5199   110   VR(J)=V(I,J)
5200         DO 120 J=1,3
5201         P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5202   120   V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5203   130   CONTINUE
5204       ENDIF
5205
5206 C...Boost, typically from rest to momentum/energy=beta.
5207       IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5208         DB=SQRT(DBX**2+DBY**2+DBZ**2)
5209         IF(DB.GT.0.99999999D0) THEN
5210 C...Rescale boost vector if too close to unity.
5211           CALL LUERRM(3,'(LUROBO:) boost vector too large')
5212           DBX=DBX*(0.99999999D0/DB)
5213           DBY=DBY*(0.99999999D0/DB)
5214           DBZ=DBZ*(0.99999999D0/DB)
5215           DB=0.99999999D0
5216         ENDIF
5217         DGA=1D0/SQRT(1D0-DB**2)
5218         DO 150 I=IMIN,IMAX
5219         IF(K(I,1).LE.0) GOTO 150
5220         DO 140 J=1,4
5221         DP(J)=P(I,J)
5222   140   DV(J)=V(I,J)
5223         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5224         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5225         P(I,1)=DP(1)+DGABP*DBX
5226         P(I,2)=DP(2)+DGABP*DBY
5227         P(I,3)=DP(3)+DGABP*DBZ
5228         P(I,4)=DGA*(DP(4)+DBP)
5229         DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5230         DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5231         V(I,1)=DV(1)+DGABV*DBX
5232         V(I,2)=DV(2)+DGABV*DBY
5233         V(I,3)=DV(3)+DGABV*DBZ
5234         V(I,4)=DGA*(DV(4)+DBV)
5235   150   CONTINUE
5236       ENDIF
5237
5238       RETURN
5239       END
5240
5241 C*********************************************************************
5242 C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST
5243 C       THE FOUR MOMENTUM ONLY
5244 C*********************************************************************
5245
5246       SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)
5247
5248 C...Purpose: to perform rotations and boosts.
5249       IMPLICIT DOUBLE PRECISION(D)
5250       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5251       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5252       DIMENSION ROT(3,3),PR(3),DP(4)
5253       SAVE
5254
5255 C...Find range of rotation/boost. Convert boost to double precision.
5256       IMIN=1
5257       IF(MSTU(1).GT.0) IMIN=MSTU(1)
5258       IMAX=N
5259       IF(MSTU(2).GT.0) IMAX=MSTU(2)
5260       DBX=BEX
5261       DBY=BEY
5262       DBZ=BEZ
5263
5264 C...Check range of rotation/boost.
5265       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5266         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5267         RETURN
5268       ENDIF
5269
5270 C...Rotate, typically from z axis to direction (theta,phi).
5271       IF(THE**2+PHI**2.GT.1E-20) THEN
5272         ROT(1,1)=COS(THE)*COS(PHI)
5273         ROT(1,2)=-SIN(PHI)
5274         ROT(1,3)=SIN(THE)*COS(PHI)
5275         ROT(2,1)=COS(THE)*SIN(PHI)
5276         ROT(2,2)=COS(PHI)
5277         ROT(2,3)=SIN(THE)*SIN(PHI)
5278         ROT(3,1)=-SIN(THE)
5279         ROT(3,2)=0.
5280         ROT(3,3)=COS(THE)
5281         DO 130 I=IMIN,IMAX
5282         IF(K(I,1).LE.0) GOTO 130
5283         DO 110 J=1,3
5284   110   PR(J)=P(I,J)
5285         DO 120 J=1,3
5286   120   P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5287   130   CONTINUE
5288       ENDIF
5289
5290 C...Boost, typically from rest to momentum/energy=beta.
5291       IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5292         DB=SQRT(DBX**2+DBY**2+DBZ**2)
5293         IF(DB.GT.0.99999999D0) THEN
5294 C...Rescale boost vector if too close to unity.
5295           CALL LUERRM(3,'(LUROBO:) boost vector too large')
5296           DBX=DBX*(0.99999999D0/DB)
5297           DBY=DBY*(0.99999999D0/DB)
5298           DBZ=DBZ*(0.99999999D0/DB)
5299           DB=0.99999999D0
5300         ENDIF
5301         DGA=1D0/SQRT(1D0-DB**2)
5302         DO 150 I=IMIN,IMAX
5303         IF(K(I,1).LE.0) GOTO 150
5304         DO 140 J=1,4
5305   140   DP(J)=P(I,J)
5306         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5307         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5308         P(I,1)=DP(1)+DGABP*DBX
5309         P(I,2)=DP(2)+DGABP*DBY
5310         P(I,3)=DP(3)+DGABP*DBZ
5311         P(I,4)=DGA*(DP(4)+DBP)
5312   150   CONTINUE
5313       ENDIF
5314
5315       RETURN
5316       END
5317
5318 C*********************************************************************
5319
5320       SUBROUTINE LUEDIT(MEDIT)
5321
5322 C...Purpose: to perform global manipulations on the event record,
5323 C...in particular to exclude unstable or undetectable partons/particles.
5324       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5325       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5326       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5327       DIMENSION NS(2),PTS(2),PLS(2)
5328       SAVE
5329
5330 C...Remove unwanted partons/particles.
5331       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5332         IMAX=N
5333         IF(MSTU(2).GT.0) IMAX=MSTU(2)
5334         I1=MAX(1,MSTU(1))-1
5335         DO 110 I=MAX(1,MSTU(1)),IMAX
5336         IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5337         IF(MEDIT.EQ.1) THEN
5338           IF(K(I,1).GT.10) GOTO 110
5339         ELSEIF(MEDIT.EQ.2) THEN
5340           IF(K(I,1).GT.10) GOTO 110
5341           KC=LUCOMP(K(I,2))
5342           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5343      &    GOTO 110
5344         ELSEIF(MEDIT.EQ.3) THEN
5345           IF(K(I,1).GT.10) GOTO 110
5346           KC=LUCOMP(K(I,2))
5347           IF(KC.EQ.0) GOTO 110
5348           IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5349         ELSEIF(MEDIT.EQ.5) THEN
5350           IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5351           KC=LUCOMP(K(I,2))
5352           IF(KC.EQ.0) GOTO 110
5353           IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5354         ENDIF
5355
5356 C...Pack remaining partons/particles. Origin no longer known.
5357         I1=I1+1
5358         DO 100 J=1,5
5359         K(I1,J)=K(I,J)
5360         P(I1,J)=P(I,J)
5361   100   V(I1,J)=V(I,J)
5362         K(I1,3)=0
5363   110   CONTINUE
5364         N=I1
5365
5366 C...Selective removal of class of entries. New position of retained.
5367       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5368         I1=0
5369         DO 120 I=1,N
5370         K(I,3)=MOD(K(I,3),MSTU(5))
5371         IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5372         IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5373         IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5374      &  K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5375         IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5376      &  K(I,2).EQ.94)) GOTO 120
5377         IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5378         I1=I1+1
5379         K(I,3)=K(I,3)+MSTU(5)*I1
5380   120   CONTINUE
5381
5382 C...Find new event history information and replace old.
5383         DO 140 I=1,N
5384         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5385         ID=I
5386   130   IM=MOD(K(ID,3),MSTU(5))
5387         IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5388           IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5389      &    K(IM,2).NE.94) THEN
5390             ID=IM
5391             GOTO 130
5392           ENDIF
5393         ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5394           IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5395             ID=IM
5396             GOTO 130
5397           ENDIF
5398         ENDIF
5399         K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5400         IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5401         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5402           IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5403      &    K(K(I,4),3)/MSTU(5)
5404           IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5405      &    K(K(I,5),3)/MSTU(5)
5406         ELSE
5407           KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5408           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5409           KCD=MOD(K(I,4),MSTU(5))
5410           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5411           K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5412           KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5413           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5414           KCD=MOD(K(I,5),MSTU(5))
5415           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5416           K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5417         ENDIF
5418   140   CONTINUE
5419
5420 C...Pack remaining entries.
5421         I1=0
5422         DO 160 I=1,N
5423         IF(K(I,3)/MSTU(5).EQ.0) GOTO 160
5424         I1=I1+1
5425         DO 150 J=1,5
5426         K(I1,J)=K(I,J)
5427         P(I1,J)=P(I,J)
5428   150   V(I1,J)=V(I,J)
5429         K(I1,3)=MOD(K(I1,3),MSTU(5))
5430   160   CONTINUE
5431         N=I1
5432
5433 C...Save top entries at bottom of LUJETS commonblock.
5434       ELSEIF(MEDIT.EQ.21) THEN
5435         IF(2*N.GE.MSTU(4)) THEN
5436           CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS')
5437           RETURN
5438         ENDIF
5439         DO 170 I=1,N
5440         DO 170 J=1,5
5441         K(MSTU(4)-I,J)=K(I,J)
5442         P(MSTU(4)-I,J)=P(I,J)
5443   170   V(MSTU(4)-I,J)=V(I,J)
5444         MSTU(32)=N
5445
5446 C...Restore bottom entries of commonblock LUJETS to top.
5447       ELSEIF(MEDIT.EQ.22) THEN
5448         DO 180 I=1,MSTU(32)
5449         DO 180 J=1,5
5450         K(I,J)=K(MSTU(4)-I,J)
5451         P(I,J)=P(MSTU(4)-I,J)
5452   180   V(I,J)=V(MSTU(4)-I,J)
5453         N=MSTU(32)
5454
5455 C...Mark primary entries at top of commonblock LUJETS as untreated.
5456       ELSEIF(MEDIT.EQ.23) THEN
5457         I1=0
5458         DO 190 I=1,N
5459         KH=K(I,3)
5460         IF(KH.GE.1) THEN
5461           IF(K(KH,1).GT.20) KH=0
5462         ENDIF
5463         IF(KH.NE.0) GOTO 200
5464         I1=I1+1
5465   190   IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5466   200   N=I1
5467
5468 C...Place largest axis along z axis and second largest in xy plane.
5469       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5470         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5471      &  P(MSTU(61),2)),0D0,0D0,0D0)
5472         CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5473      &  P(MSTU(61),1)),0.,0D0,0D0,0D0)
5474         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5475      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)
5476         IF(MEDIT.EQ.31) RETURN
5477
5478 C...Rotate to put slim jet along +z axis.
5479         DO 210 IS=1,2
5480         NS(IS)=0
5481         PTS(IS)=0.
5482   210   PLS(IS)=0.
5483         DO 220 I=1,N
5484         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 220
5485         IF(MSTU(41).GE.2) THEN
5486           KC=LUCOMP(K(I,2))
5487           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5488      &    KC.EQ.18) GOTO 220
5489           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5490      &    GOTO 220
5491         ENDIF
5492         IS=2.-SIGN(0.5,P(I,3))
5493         NS(IS)=NS(IS)+1
5494         PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
5495   220   CONTINUE
5496         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
5497      &  CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
5498
5499 C...Rotate to put second largest jet into -z,+x quadrant.
5500         DO 230 I=1,N
5501         IF(P(I,3).GE.0.) GOTO 230
5502         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
5503         IF(MSTU(41).GE.2) THEN
5504           KC=LUCOMP(K(I,2))
5505           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5506      &    KC.EQ.18) GOTO 230
5507           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5508      &    GOTO 230
5509         ENDIF
5510         IS=2.-SIGN(0.5,P(I,1))
5511         PLS(IS)=PLS(IS)-P(I,3)
5512   230   CONTINUE
5513         IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
5514      &  0D0,0D0,0D0)
5515       ENDIF
5516
5517       RETURN
5518       END
5519
5520 C*********************************************************************
5521
5522       SUBROUTINE LULIST(MLIST)
5523
5524 C...Purpose: to give program heading, or list an event, or particle
5525 C...data, or current parameter values.
5526       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5527       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5528       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5529       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5530       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
5531       DIMENSION PS(6)
5532       SAVE
5533       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
5534      &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
5535
5536       CHMO(1)=CHMO(1)
5537 C...Initialization printout: version number and date of last change.
5538 C      IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
5539 C        WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185),
5540 C     &  CHMO(MSTU(184)),MSTU(183)
5541 C        MSTU(12)=0
5542 C        IF(MLIST.EQ.0) RETURN
5543 C      ENDIF
5544
5545 C...List event data, including additional lines after N.
5546       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
5547         IF(MLIST.EQ.1) WRITE(MSTU(11),1100)
5548         IF(MLIST.EQ.2) WRITE(MSTU(11),1200)
5549         IF(MLIST.EQ.3) WRITE(MSTU(11),1300)
5550         LMX=12
5551         IF(MLIST.GE.2) LMX=16
5552         ISTR=0
5553         IMAX=N
5554         IF(MSTU(2).GT.0) IMAX=MSTU(2)
5555         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
5556         IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
5557
5558 C...Get particle name, pad it and check it is not too long.
5559         CALL LUNAME(K(I,2),CHAP)
5560         LEN=0
5561         DO 100 LEM=1,16
5562   100   IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
5563         MDL=(K(I,1)+19)/10
5564         LDL=0
5565         IF(MDL.EQ.2.OR.MDL.GE.8) THEN
5566           CHAC=CHAP
5567           IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
5568         ELSE
5569           LDL=1
5570           IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
5571           IF(LEN.EQ.0) THEN
5572             CHAC=CHDL(MDL)(1:2*LDL)//' '
5573           ELSE
5574             CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
5575      &      CHDL(MDL)(LDL+1:2*LDL)//' '
5576             IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
5577           ENDIF
5578         ENDIF
5579
5580 C...Add information on string connection.
5581         IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
5582      &  THEN
5583           KC=LUCOMP(K(I,2))
5584           KCC=0
5585           IF(KC.NE.0) KCC=KCHG(KC,2)
5586           IF(KCC.NE.0.AND.ISTR.EQ.0) THEN
5587             ISTR=1
5588             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
5589           ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
5590             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
5591           ELSEIF(KCC.NE.0) THEN
5592             ISTR=0
5593             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
5594           ENDIF
5595         ENDIF
5596
5597 C...Write data for particle/jet.
5598         IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
5599           WRITE(MSTU(11),1400) I,CHAC(1:12),(K(I,J1),J1=1,3),
5600      &    (P(I,J2),J2=1,5)
5601         ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
5602           WRITE(MSTU(11),1500) I,CHAC(1:12),(K(I,J1),J1=1,3),
5603      &    (P(I,J2),J2=1,5)
5604         ELSEIF(MLIST.EQ.1) THEN
5605           WRITE(MSTU(11),1600) I,CHAC(1:12),(K(I,J1),J1=1,3),
5606      &    (P(I,J2),J2=1,5)
5607         ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
5608      &  K(I,1).EQ.14)) THEN
5609           WRITE(MSTU(11),1700) I,CHAC,(K(I,J1),J1=1,3),
5610      &    K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
5611      &    K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
5612      &    (P(I,J2),J2=1,5)
5613         ELSE
5614           WRITE(MSTU(11),1800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
5615         ENDIF
5616         IF(MLIST.EQ.3) WRITE(MSTU(11),1900) (V(I,J),J=1,5)
5617
5618 C...Insert extra separator lines specified by user.
5619         IF(MSTU(70).GE.1) THEN
5620           ISEP=0
5621           DO 110 J=1,MIN(10,MSTU(70))
5622   110     IF(I.EQ.MSTU(70+J)) ISEP=1
5623           IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000)
5624           IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100)
5625         ENDIF
5626   120   CONTINUE
5627
5628 C...Sum of charges and momenta.
5629         DO 130 J=1,6
5630   130   PS(J)=PLU(0,J)
5631         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
5632           WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)
5633         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
5634           WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)
5635         ELSEIF(MLIST.EQ.1) THEN
5636           WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)
5637         ELSE
5638           WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)
5639         ENDIF
5640
5641 C...Give simple list of KF codes defined in program.
5642       ELSEIF(MLIST.EQ.11) THEN
5643         WRITE(MSTU(11),2600)
5644         DO 140 KF=1,40
5645         CALL LUNAME(KF,CHAP)
5646         CALL LUNAME(-KF,CHAN)
5647         IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),2700) KF,CHAP
5648   140   IF(CHAN.NE.' ') WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5649         DO 150 KFLS=1,3,2
5650         DO 150 KFLA=1,8
5651         DO 150 KFLB=1,KFLA-(3-KFLS)/2
5652         KF=1000*KFLA+100*KFLB+KFLS
5653         CALL LUNAME(KF,CHAP)
5654         CALL LUNAME(-KF,CHAN)
5655   150   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5656         DO 170 KMUL=0,5
5657         KFLS=3
5658         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
5659         IF(KMUL.EQ.5) KFLS=5
5660         KFLR=0
5661         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
5662         IF(KMUL.EQ.4) KFLR=2
5663         DO 170 KFLB=1,8
5664         DO 160 KFLC=1,KFLB-1
5665         KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
5666         CALL LUNAME(KF,CHAP)
5667         CALL LUNAME(-KF,CHAN)
5668   160   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5669         KF=10000*KFLR+110*KFLB+KFLS
5670         CALL LUNAME(KF,CHAP)
5671   170   WRITE(MSTU(11),2700) KF,CHAP
5672         KF=130
5673         CALL LUNAME(KF,CHAP)
5674         WRITE(MSTU(11),2700) KF,CHAP
5675         KF=310
5676         CALL LUNAME(KF,CHAP)
5677         WRITE(MSTU(11),2700) KF,CHAP
5678         DO 190 KFLSP=1,3
5679         KFLS=2+2*(KFLSP/3)
5680         DO 190 KFLA=1,8
5681         DO 190 KFLB=1,KFLA
5682         DO 180 KFLC=1,KFLB
5683         IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
5684         IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
5685         IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
5686         IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
5687         CALL LUNAME(KF,CHAP)
5688         CALL LUNAME(-KF,CHAN)
5689         WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5690   180   CONTINUE
5691   190   CONTINUE
5692
5693 C...List parton/particle data table. Check whether to be listed.
5694       ELSEIF(MLIST.EQ.12) THEN
5695         WRITE(MSTU(11),2800)
5696         MSTJ24=MSTJ(24)
5697         MSTJ(24)=0
5698         KFMAX=20883
5699         IF(MSTU(2).NE.0) KFMAX=MSTU(2)
5700         DO 220 KF=MAX(1,MSTU(1)),KFMAX
5701         KC=LUCOMP(KF)
5702         IF(KC.EQ.0) GOTO 220
5703         IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
5704         IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
5705      &  MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
5706
5707 C...Find particle name and mass. Print information.
5708         CALL LUNAME(KF,CHAP)
5709         IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
5710         CALL LUNAME(-KF,CHAN)
5711         PM=ULMASS(KF)
5712         WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
5713      &  KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
5714
5715 C...Particle decay: channel number, branching ration, matrix element,
5716 C...decay products.
5717         IF(KF.GT.100.AND.KC.LE.100) GOTO 220
5718         DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5719         DO 200 J=1,5
5720   200   CALL LUNAME(KFDP(IDC,J),CHAD(J))
5721   210   WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5722      &  (CHAD(J),J=1,5)
5723   220   CONTINUE
5724         MSTJ(24)=MSTJ24
5725
5726 C...List parameter value table.
5727       ELSEIF(MLIST.EQ.13) THEN
5728         WRITE(MSTU(11),3100)
5729         DO 230 I=1,200
5730   230   WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
5731       ENDIF
5732
5733 C...Format statements for output on unit MSTU(11) (by default 6).
5734 C 1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/
5735 C     &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)
5736  1100 FORMAT(///28X,'Event listing (summary)'//4X,'I  particle/jet KS',
5737      &5X,'KF orig    p_x      p_y      p_z       E        m'/)
5738  1200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',
5739      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
5740      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)
5741  1300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',
5742      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
5743      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,
5744      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)
5745  1400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
5746  1500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
5747  1600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
5748  1700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
5749  1800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
5750  1900 FORMAT(66X,5(1X,F12.3))
5751  2000 FORMAT(1X,78('='))
5752  2100 FORMAT(1X,130('='))
5753  2200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
5754  2300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
5755  2400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
5756  2500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
5757      &5F13.5)
5758  2600 FORMAT(///20X,'List of KF codes in program'/)
5759  2700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
5760  2800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
5761      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,
5762      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
5763      &1X,'ME',3X,'Br.rat.',4X,'decay products')
5764  2900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
5765      &2X,F12.5,3X,I2)
5766  3000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
5767  3100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
5768      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
5769  3200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
5770
5771       RETURN
5772       END
5773
5774 C*********************************************************************
5775
5776       SUBROUTINE LUUPDA(MUPDA,LFN)
5777
5778 C...Purpose: to facilitate the updating of particle and decay data.
5779       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5780       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5781       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5782       COMMON/LUDAT4/CHAF(500)
5783       CHARACTER CHAF*8
5784       CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
5785      &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
5786       SAVE
5787       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
5788      &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
5789      &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',
5790      &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/
5791
5792 C...Write information on file for editing.
5793       IF(MSTU(12).GE.1) CALL LULIST(0)
5794       IF(MUPDA.EQ.1) THEN
5795         DO 110 KC=1,MSTU(6)
5796         WRITE(LFN,1000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
5797      &  (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
5798         DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5799   100   WRITE(LFN,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5800      &  (KFDP(IDC,J),J=1,5)
5801   110   CONTINUE
5802
5803 C...Reset variables and read information from edited file.
5804       ELSEIF(MUPDA.EQ.2) THEN
5805         DO 120 I=1,MSTU(7)
5806         MDME(I,1)=1
5807         MDME(I,2)=0
5808         BRAT(I)=0.
5809         DO 120 J=1,5
5810   120   KFDP(I,J)=0
5811         KC=0
5812         IDC=0
5813         NDC=0
5814   130   READ(LFN,1200,END=140) CHINL
5815         IF(CHINL(2:5).NE.'    ') THEN
5816           CHKC=CHINL(2:5)
5817           IF(KC.NE.0) THEN
5818             MDCY(KC,2)=0
5819             IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
5820             MDCY(KC,3)=NDC
5821           ENDIF
5822           READ(CHKC,1300) KC
5823           IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,
5824      &    '(LUUPDA:) Read KC code illegal, KC ='//CHKC)
5825           READ(CHINL,1000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
5826      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
5827           NDC=0
5828         ELSE
5829           IDC=IDC+1
5830           NDC=NDC+1
5831           IF(IDC.GE.MSTU(7)) CALL LUERRM(27,
5832      &    '(LUUPDA:) Decay data arrays full by KC ='//CHKC)
5833           READ(CHINL,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5834      &    (KFDP(IDC,J),J=1,5)
5835         ENDIF
5836         GOTO 130
5837   140   MDCY(KC,2)=0
5838         IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
5839         MDCY(KC,3)=NDC
5840
5841 C...Perform possible tests that new information is consistent.
5842         MSTJ24=MSTJ(24)
5843         MSTJ(24)=0
5844         DO 170 KC=1,MSTU(6)
5845         WRITE(CHKC,1300) KC
5846         IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
5847      &  PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,
5848      &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
5849         BRSUM=0.
5850         DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5851         IF(MDME(IDC,2).GT.80) GOTO 160
5852         KQ=KCHG(KC,1)
5853         PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
5854         MERR=0
5855         DO 150 J=1,5
5856         KP=KFDP(IDC,J)
5857         IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
5858         ELSEIF(LUCOMP(KP).EQ.0) THEN
5859           MERR=3
5860         ELSE
5861           KQ=KQ-LUCHGE(KP)
5862           PMS=PMS-ULMASS(KP)
5863         ENDIF
5864   150   CONTINUE
5865         IF(KQ.NE.0) MERR=MAX(2,MERR)
5866         IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
5867      &  (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
5868      &  MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
5869         IF(MERR.EQ.3) CALL LUERRM(17,
5870      &  '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)
5871         IF(MERR.EQ.2) CALL LUERRM(17,
5872      &  '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)
5873         IF(MERR.EQ.1) CALL LUERRM(7,
5874      &  '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)
5875         BRSUM=BRSUM+BRAT(IDC)
5876   160   CONTINUE
5877         WRITE(CHTMP,1500) BRSUM
5878         IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
5879      &  LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
5880      &  ' for KC ='//CHKC)
5881   170   CONTINUE
5882         MSTJ(24)=MSTJ24
5883
5884 C...Initialize writing of DATA statements for inclusion in program.
5885       ELSEIF(MUPDA.EQ.3) THEN
5886         DO 240 IVAR=1,19
5887         NDIM=MSTU(6)
5888         IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
5889         NLIN=1
5890         CHLIN=' '
5891         CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
5892         LLIN=35
5893         CHOLD='START'
5894
5895 C...Loop through variables for conversion to characters.
5896         DO 220 IDIM=1,NDIM
5897         IF(IVAR.EQ.1) WRITE(CHTMP,1400) KCHG(IDIM,1)
5898         IF(IVAR.EQ.2) WRITE(CHTMP,1400) KCHG(IDIM,2)
5899         IF(IVAR.EQ.3) WRITE(CHTMP,1400) KCHG(IDIM,3)
5900         IF(IVAR.EQ.4) WRITE(CHTMP,1500) PMAS(IDIM,1)
5901         IF(IVAR.EQ.5) WRITE(CHTMP,1500) PMAS(IDIM,2)
5902         IF(IVAR.EQ.6) WRITE(CHTMP,1500) PMAS(IDIM,3)
5903         IF(IVAR.EQ.7) WRITE(CHTMP,1500) PMAS(IDIM,4)
5904         IF(IVAR.EQ.8) WRITE(CHTMP,1400) MDCY(IDIM,1)
5905         IF(IVAR.EQ.9) WRITE(CHTMP,1400) MDCY(IDIM,2)
5906         IF(IVAR.EQ.10) WRITE(CHTMP,1400) MDCY(IDIM,3)
5907         IF(IVAR.EQ.11) WRITE(CHTMP,1400) MDME(IDIM,1)
5908         IF(IVAR.EQ.12) WRITE(CHTMP,1400) MDME(IDIM,2)
5909         IF(IVAR.EQ.13) WRITE(CHTMP,1500) BRAT(IDIM)
5910         IF(IVAR.EQ.14) WRITE(CHTMP,1400) KFDP(IDIM,1)
5911         IF(IVAR.EQ.15) WRITE(CHTMP,1400) KFDP(IDIM,2)
5912         IF(IVAR.EQ.16) WRITE(CHTMP,1400) KFDP(IDIM,3)
5913         IF(IVAR.EQ.17) WRITE(CHTMP,1400) KFDP(IDIM,4)
5914         IF(IVAR.EQ.18) WRITE(CHTMP,1400) KFDP(IDIM,5)
5915         IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
5916
5917 C...Length of variable, trailing decimal zeros, quotation marks.
5918         LLOW=1
5919         LHIG=1
5920         DO 180 LL=1,12
5921         IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
5922   180   IF(CHTMP(LL:LL).NE.' ') LHIG=LL
5923         CHNEW=CHTMP(LLOW:LHIG)//' '
5924         LNEW=1+LHIG-LLOW
5925         IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
5926           LNEW=LNEW+1
5927   190     LNEW=LNEW-1
5928           IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190
5929           IF(LNEW.EQ.1) CHNEW(1:2)='0.'
5930           IF(LNEW.EQ.1) LNEW=2
5931         ELSEIF(IVAR.EQ.19) THEN
5932           DO 200 LL=LNEW,1,-1
5933           IF(CHNEW(LL:LL).EQ.'''') THEN
5934             CHTMP=CHNEW
5935             CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
5936             LNEW=LNEW+1
5937           ENDIF
5938   200     CONTINUE
5939           CHTMP=CHNEW
5940           CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
5941           LNEW=LNEW+2
5942         ENDIF
5943
5944 C...Form composite character string, often including repetition counter.
5945         IF(CHNEW.NE.CHOLD) THEN
5946           NRPT=1
5947           CHOLD=CHNEW
5948           CHCOM=CHNEW
5949           LCOM=LNEW
5950         ELSE
5951           LRPT=LNEW+1
5952           IF(NRPT.GE.2) LRPT=LNEW+3
5953           IF(NRPT.GE.10) LRPT=LNEW+4
5954           IF(NRPT.GE.100) LRPT=LNEW+5
5955           IF(NRPT.GE.1000) LRPT=LNEW+6
5956           LLIN=LLIN-LRPT
5957           NRPT=NRPT+1
5958           WRITE(CHTMP,1400) NRPT
5959           LRPT=1
5960           IF(NRPT.GE.10) LRPT=2
5961           IF(NRPT.GE.100) LRPT=3
5962           IF(NRPT.GE.1000) LRPT=4
5963           CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
5964           LCOM=LRPT+1+LNEW
5965         ENDIF
5966
5967 C...Add characters to end of line, to new line (after storing old line),
5968 C...or to new block of lines (after writing old block).
5969         IF(LLIN+LCOM.LE.70) THEN
5970           CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
5971           LLIN=LLIN+LCOM+1
5972         ELSEIF(NLIN.LE.19) THEN
5973           CHLIN(LLIN+1:72)=' '
5974           CHBLK(NLIN)=CHLIN
5975           NLIN=NLIN+1
5976           CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
5977           LLIN=6+LCOM+1
5978         ELSE
5979           CHLIN(LLIN:72)='/'//' '
5980           CHBLK(NLIN)=CHLIN
5981           WRITE(CHTMP,1400) IDIM-NRPT
5982           CHBLK(1)(30:33)=CHTMP(9:12)
5983           DO 210 ILIN=1,NLIN
5984   210     WRITE(LFN,1600) CHBLK(ILIN)
5985           NLIN=1
5986           CHLIN=' '
5987           CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I=    ,    )/'//
5988      &    CHCOM(1:LCOM)//','
5989           WRITE(CHTMP,1400) IDIM-NRPT+1
5990           CHLIN(25:28)=CHTMP(9:12)
5991           LLIN=35+LCOM+1
5992         ENDIF
5993   220   CONTINUE
5994
5995 C...Write final block of lines.
5996         CHLIN(LLIN:72)='/'//' '
5997         CHBLK(NLIN)=CHLIN
5998         WRITE(CHTMP,1400) NDIM
5999         CHBLK(1)(30:33)=CHTMP(9:12)
6000         DO 230 ILIN=1,NLIN
6001   230   WRITE(LFN,1600) CHBLK(ILIN)
6002   240   CONTINUE
6003       ENDIF
6004
6005 C...Formats for reading and writing particle data.
6006  1000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
6007  1100 FORMAT(5X,2I5,F12.5,5I8)
6008  1200 FORMAT(A80)
6009  1300 FORMAT(I4)
6010  1400 FORMAT(I12)
6011  1500 FORMAT(F12.5)
6012  1600 FORMAT(A72)
6013
6014       RETURN
6015       END
6016
6017 C*********************************************************************
6018
6019       FUNCTION KLU(I,J)
6020
6021 C...Purpose: to provide various integer-valued event related data.
6022       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6023       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6024       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6025       SAVE
6026
6027 C...Default value. For I=0 number of entries, number of stable entries
6028 C...or 3 times total charge.
6029       KLU=0
6030       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6031       ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
6032         KLU=N
6033       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
6034         DO 100 I1=1,N
6035         IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+1
6036         IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+
6037      &  LUCHGE(K(I1,2))
6038   100   CONTINUE
6039       ELSEIF(I.EQ.0) THEN
6040
6041 C...For I > 0 direct readout of K matrix or charge.
6042       ELSEIF(J.LE.5) THEN
6043         KLU=K(I,J)
6044       ELSEIF(J.EQ.6) THEN
6045         KLU=LUCHGE(K(I,2))
6046
6047 C...Status (existing/fragmented/decayed), parton/hadron separation.
6048       ELSEIF(J.LE.8) THEN
6049         IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLU=1
6050         IF(J.EQ.8) KLU=KLU*K(I,2)
6051       ELSEIF(J.LE.12) THEN
6052         KFA=IABS(K(I,2))
6053         KC=LUCOMP(KFA)
6054         KQ=0
6055         IF(KC.NE.0) KQ=KCHG(KC,2)
6056         IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLU=K(I,2)
6057         IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLU=K(I,2)
6058         IF(J.EQ.11) KLU=KC
6059         IF(J.EQ.12) KLU=KQ*ISIGN(1,K(I,2))
6060
6061 C...Heaviest flavour in hadron/diquark.
6062       ELSEIF(J.EQ.13) THEN
6063         KFA=IABS(K(I,2))
6064         KLU=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
6065         IF(KFA.LT.10) KLU=KFA
6066         IF(MOD(KFA/1000,10).NE.0) KLU=MOD(KFA/1000,10)
6067         KLU=KLU*ISIGN(1,K(I,2))
6068
6069 C...Particle history: generation, ancestor, rank.
6070       ELSEIF(J.LE.16) THEN
6071         I2=I
6072         I1=I
6073   110   KLU=KLU+1
6074         I3=I2
6075         I2=I1
6076         I1=K(I1,3)
6077         IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
6078         IF(J.EQ.15) KLU=I2
6079         IF(J.EQ.16) THEN
6080           KLU=0
6081           DO 120 I1=I2+1,I3
6082   120     IF(K(I1,3).EQ.I2.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) KLU=KLU+1
6083         ENDIF
6084
6085 C...Particle coming from collapsing jet system or not.
6086       ELSEIF(J.EQ.17) THEN
6087         I1=I
6088   130   KLU=KLU+1
6089         I3=I1
6090         I1=K(I1,3)
6091         I0=MAX(1,I1)
6092         KC=LUCOMP(K(I0,2))
6093         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
6094           IF(KLU.EQ.1) KLU=-1
6095           IF(KLU.GT.1) KLU=0
6096           RETURN
6097         ENDIF
6098         IF(KCHG(KC,2).EQ.0) GOTO 130
6099         IF(K(I1,1).NE.12) KLU=0
6100         IF(K(I1,1).NE.12) RETURN
6101         I2=I1
6102   140   I2=I2+1
6103         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 140
6104         K3M=K(I3-1,3)
6105         IF(K3M.GE.I1.AND.K3M.LE.I2) KLU=0
6106         K3P=K(I3+1,3)
6107         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLU=0
6108
6109 C...Number of decay products. Colour flow.
6110       ELSEIF(J.EQ.18) THEN
6111         IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLU=MAX(0,K(I,5)-K(I,4)+1)
6112         IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLU=0
6113       ELSEIF(J.LE.22) THEN
6114         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
6115         IF(J.EQ.19) KLU=MOD(K(I,4)/MSTU(5),MSTU(5))
6116         IF(J.EQ.20) KLU=MOD(K(I,5)/MSTU(5),MSTU(5))
6117         IF(J.EQ.21) KLU=MOD(K(I,4),MSTU(5))
6118         IF(J.EQ.22) KLU=MOD(K(I,5),MSTU(5))
6119       ELSE
6120       ENDIF
6121
6122       RETURN
6123       END
6124
6125 C*********************************************************************
6126
6127       FUNCTION PLU(I,J)
6128
6129 C...Purpose: to provide various real-valued event related data.
6130       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6131       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6132       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6133       DIMENSION PSUM(4)
6134       SAVE
6135
6136 C...Set default value. For I = 0 sum of momenta or charges,
6137 C...or invariant mass of system.
6138       PLU=0.
6139       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6140       ELSEIF(I.EQ.0.AND.J.LE.4) THEN
6141         DO 100 I1=1,N
6142   100   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
6143       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
6144         DO 110 J1=1,4
6145         PSUM(J1)=0.
6146         DO 110 I1=1,N
6147   110   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
6148         PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
6149       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
6150         DO 120 I1=1,N
6151   120   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
6152       ELSEIF(I.EQ.0) THEN
6153
6154 C...Direct readout of P matrix.
6155       ELSEIF(J.LE.5) THEN
6156         PLU=P(I,J)
6157
6158 C...Charge, total momentum, transverse momentum, transverse mass.
6159       ELSEIF(J.LE.12) THEN
6160         IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
6161         IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
6162         IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
6163         IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
6164         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
6165
6166 C...Theta and phi angle in radians or degrees.
6167       ELSEIF(J.LE.16) THEN
6168         IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
6169         IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
6170         IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
6171
6172 C...True rapidity, rapidity with pion mass, pseudorapidity.
6173       ELSEIF(J.LE.19) THEN
6174         PMR=0.
6175         IF(J.EQ.17) PMR=P(I,5)
6176         IF(J.EQ.18) PMR=ULMASS(211)
6177         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
6178         PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
6179      &  1E20)),P(I,3))
6180
6181 C...Energy and momentum fractions (only to be used in CM frame).
6182       ELSEIF(J.LE.25) THEN
6183         IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
6184         IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
6185         IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
6186         IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
6187         IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
6188         IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
6189       ENDIF
6190
6191       RETURN
6192       END
6193
6194 C*********************************************************************
6195
6196       SUBROUTINE LUSPHE(SPH,APL)
6197
6198 C...Purpose: to perform sphericity tensor analysis to give sphericity,
6199 C...aplanarity and the related event axes.
6200       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6201       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6202       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6203       DIMENSION SM(3,3),SV(3,3)
6204       SAVE
6205
6206 C...Calculate matrix to be diagonalized.
6207       NP=0
6208       DO 100 J1=1,3
6209       DO 100 J2=J1,3
6210   100 SM(J1,J2)=0.
6211       PS=0.
6212       DO 120 I=1,N
6213       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
6214       IF(MSTU(41).GE.2) THEN
6215         KC=LUCOMP(K(I,2))
6216         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6217      &  KC.EQ.18) GOTO 120
6218         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6219      &  GOTO 120
6220       ENDIF
6221       NP=NP+1
6222       PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6223       PWT=1.
6224       IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
6225       DO 110 J1=1,3
6226       DO 110 J2=J1,3
6227   110 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
6228       PS=PS+PWT*PA**2
6229   120 CONTINUE
6230
6231 C...Very low multiplicities (0 or 1) not considered.
6232       IF(NP.LE.1) THEN
6233         CALL LUERRM(8,'(LUSPHE:) too few particles for analysis')
6234         SPH=-1.
6235         APL=-1.
6236         RETURN
6237       ENDIF
6238       DO 130 J1=1,3
6239       DO 130 J2=J1,3
6240   130 SM(J1,J2)=SM(J1,J2)/PS
6241
6242 C...Find eigenvalues to matrix (third degree equation).
6243       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
6244      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
6245       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
6246      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
6247       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
6248       P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
6249       P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)
6250       P(N+2,4)=1.-P(N+1,4)-P(N+3,4)
6251       IF(P(N+2,4).LT.1E-5) THEN
6252         CALL LUERRM(8,'(LUSPHE:) all particles back-to-back')
6253         SPH=-1.
6254         APL=-1.
6255         RETURN
6256       ENDIF
6257
6258 C...Find first and last eigenvector by solving equation system.
6259       DO 170 I=1,3,2
6260       DO 140 J1=1,3
6261       SV(J1,J1)=SM(J1,J1)-P(N+I,4)
6262       DO 140 J2=J1+1,3
6263       SV(J1,J2)=SM(J1,J2)
6264   140 SV(J2,J1)=SM(J1,J2)
6265       SMAX=0.
6266       DO 150 J1=1,3
6267       DO 150 J2=1,3
6268       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 150
6269       JA=J1
6270       JB=J2
6271       SMAX=ABS(SV(J1,J2))
6272   150 CONTINUE
6273       SMAX=0.
6274       DO 160 J3=JA+1,JA+2
6275       J1=J3-3*((J3-1)/3)
6276       RL=SV(J1,JB)/SV(JA,JB)
6277       DO 160 J2=1,3
6278       SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
6279       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 160
6280       JC=J1
6281       SMAX=ABS(SV(J1,J2))
6282   160 CONTINUE
6283       JB1=JB+1-3*(JB/3)
6284       JB2=JB+2-3*((JB+1)/3)
6285       P(N+I,JB1)=-SV(JC,JB2)
6286       P(N+I,JB2)=SV(JC,JB1)
6287       P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
6288      &SV(JA,JB)
6289       PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
6290       SGN=(-1.)**INT(RLU(0)+0.5)
6291       DO 170 J=1,3
6292   170 P(N+I,J)=SGN*P(N+I,J)/PA
6293
6294 C...Middle axis orthogonal to other two. Fill other codes.
6295       SGN=(-1.)**INT(RLU(0)+0.5)
6296       P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
6297       P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
6298       P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
6299       DO 180 I=1,3
6300       K(N+I,1)=31
6301       K(N+I,2)=95
6302       K(N+I,3)=I
6303       K(N+I,4)=0
6304       K(N+I,5)=0
6305       P(N+I,5)=0.
6306       DO 180 J=1,5
6307   180 V(I,J)=0.
6308
6309 C...Select storing option. Calculate sphericity and aplanarity.
6310       MSTU(61)=N+1
6311       MSTU(62)=NP
6312       IF(MSTU(43).LE.1) MSTU(3)=3
6313       IF(MSTU(43).GE.2) N=N+3
6314       SPH=1.5*(P(N+2,4)+P(N+3,4))
6315       APL=1.5*P(N+3,4)
6316
6317       RETURN
6318       END
6319
6320 C*********************************************************************
6321
6322       SUBROUTINE LUTHRU(THR,OBL)
6323
6324 C...Purpose: to perform thrust analysis to give thrust, oblateness
6325 C...and the related event axes.
6326       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6327       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6328       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6329       DIMENSION TDI(3),TPR(3)
6330       SAVE
6331
6332 C...Take copy of particles that are to be considered in thrust analysis.
6333       NP=0
6334       PS=0.
6335       DO 100 I=1,N
6336       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
6337       IF(MSTU(41).GE.2) THEN
6338         KC=LUCOMP(K(I,2))
6339         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6340      &  KC.EQ.18) GOTO 100
6341         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6342      &  GOTO 100
6343       ENDIF
6344       IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
6345         CALL LUERRM(11,'(LUTHRU:) no more memory left in LUJETS')
6346         THR=-2.
6347         OBL=-2.
6348         RETURN
6349       ENDIF
6350       NP=NP+1
6351       K(N+NP,1)=23
6352       P(N+NP,1)=P(I,1)
6353       P(N+NP,2)=P(I,2)
6354       P(N+NP,3)=P(I,3)
6355       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6356       P(N+NP,5)=1.
6357       IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)
6358       PS=PS+P(N+NP,4)*P(N+NP,5)
6359   100 CONTINUE
6360
6361 C...Very low multiplicities (0 or 1) not considered.
6362       IF(NP.LE.1) THEN
6363         CALL LUERRM(8,'(LUTHRU:) too few particles for analysis')
6364         THR=-1.
6365         OBL=-1.
6366         RETURN
6367       ENDIF
6368
6369 C...Loop over thrust and major. T axis along z direction in latter case.
6370       DO 280 ILD=1,2
6371       IF(ILD.EQ.2) THEN
6372         K(N+NP+1,1)=31
6373         PHI=ULANGL(P(N+NP+1,1),P(N+NP+1,2))
6374         CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0)
6375         THE=ULANGL(P(N+NP+1,3),P(N+NP+1,1))
6376         CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0)
6377       ENDIF
6378
6379 C...Find and order particles with highest p (pT for major).
6380       DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
6381   110 P(ILF,4)=0.
6382       DO 150 I=N+1,N+NP
6383       IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
6384       DO 120 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
6385       IF(P(I,4).LE.P(ILF,4)) GOTO 130
6386       DO 120 J=1,5
6387   120 P(ILF+1,J)=P(ILF,J)
6388       ILF=N+NP+3
6389   130 DO 140 J=1,5
6390   140 P(ILF+1,J)=P(I,J)
6391   150 CONTINUE
6392
6393 C...Find and order initial axes with highest thrust (major).
6394       DO 160 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
6395   160 P(ILG,4)=0.
6396       NC=2**(MIN(MSTU(44),NP)-1)
6397       DO 220 ILC=1,NC
6398       DO 170 J=1,3
6399   170 TDI(J)=0.
6400       DO 180 ILF=1,MIN(MSTU(44),NP)
6401       SGN=P(N+NP+ILF+3,5)
6402       IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
6403       DO 180 J=1,4-ILD
6404   180 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
6405       TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
6406       DO 190 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
6407       IF(TDS.LE.P(ILG,4)) GOTO 200
6408       DO 190 J=1,4
6409   190 P(ILG+1,J)=P(ILG,J)
6410       ILG=N+NP+MSTU(44)+4
6411   200 DO 210 J=1,3
6412   210 P(ILG+1,J)=TDI(J)
6413       P(ILG+1,4)=TDS
6414   220 CONTINUE
6415
6416 C...Iterate direction of axis until stable maximum.
6417       P(N+NP+ILD,4)=0.
6418       ILG=0
6419   230 ILG=ILG+1
6420       THP=0.
6421   240 THPS=THP
6422       DO 250 J=1,3
6423       IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
6424       IF(THP.GT.1E-10) TDI(J)=TPR(J)
6425   250 TPR(J)=0.
6426       DO 260 I=N+1,N+NP
6427       SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
6428       DO 260 J=1,4-ILD
6429   260 TPR(J)=TPR(J)+SGN*P(I,J)
6430       THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
6431       IF(THP.GE.THPS+PARU(48)) GOTO 240
6432
6433 C...Save good axis. Try new initial axis until a number of tries agree.
6434       IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 230
6435       IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
6436         IAGR=0
6437         SGN=(-1.)**INT(RLU(0)+0.5)
6438         DO 270 J=1,3
6439   270   P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
6440         P(N+NP+ILD,4)=THP
6441         P(N+NP+ILD,5)=0.
6442       ENDIF
6443       IAGR=IAGR+1
6444   280 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 230
6445
6446 C...Find minor axis and value by orthogonality.
6447       SGN=(-1.)**INT(RLU(0)+0.5)
6448       P(N+NP+3,1)=-SGN*P(N+NP+2,2)
6449       P(N+NP+3,2)=SGN*P(N+NP+2,1)
6450       P(N+NP+3,3)=0.
6451       THP=0.
6452       DO 290 I=N+1,N+NP
6453   290 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
6454       P(N+NP+3,4)=THP/PS
6455       P(N+NP+3,5)=0.
6456
6457 C...Fill axis information. Rotate back to original coordinate system.
6458       DO 300 ILD=1,3
6459       K(N+ILD,1)=31
6460       K(N+ILD,2)=96
6461       K(N+ILD,3)=ILD
6462       K(N+ILD,4)=0
6463       K(N+ILD,5)=0
6464       DO 300 J=1,5
6465       P(N+ILD,J)=P(N+NP+ILD,J)
6466   300 V(N+ILD,J)=0.
6467       CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
6468
6469 C...Select storing option. Calculate thurst and oblateness.
6470       MSTU(61)=N+1
6471       MSTU(62)=NP
6472       IF(MSTU(43).LE.1) MSTU(3)=3
6473       IF(MSTU(43).GE.2) N=N+3
6474       THR=P(N+1,4)
6475       OBL=P(N+2,4)-P(N+3,4)
6476
6477       RETURN
6478       END
6479
6480 C*********************************************************************
6481
6482       SUBROUTINE LUCLUS(NJET)
6483
6484 C...Purpose: to subdivide the particle content of an event into
6485 C...jets/clusters.
6486       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6487       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6488       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6489       DIMENSION PS(5)
6490 C      SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
6491       INTEGER NSAV,NP,NPRE,NREM
6492       SAVE
6493
6494 C...Functions: distance measure in pT or (pseudo)mass.
6495       R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
6496      &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2
6497       R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*
6498      &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
6499
6500 C...If first time, reset. If reentering, skip preliminaries.
6501       IF(MSTU(48).LE.0) THEN
6502         NP=0
6503         DO 100 J=1,5
6504   100   PS(J)=0.
6505         PSS=0.
6506       ELSE
6507         NJET=NSAV
6508         IF(MSTU(43).GE.2) N=N-NJET
6509         DO 110 I=N+1,N+NJET
6510   110   P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6511         IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
6512         IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
6513         NLOOP=0
6514         GOTO 290
6515       ENDIF
6516
6517 C...Find which particles are to be considered in cluster search.
6518       DO 140 I=1,N
6519       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
6520       IF(MSTU(41).GE.2) THEN
6521         KC=LUCOMP(K(I,2))
6522         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6523      &  KC.EQ.18) GOTO 140
6524         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6525      &  GOTO 140
6526       ENDIF
6527       IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
6528         CALL LUERRM(11,'(LUCLUS:) no more memory left in LUJETS')
6529         NJET=-1
6530         RETURN
6531       ENDIF
6532
6533 C...Take copy of these particles, with space left for jets later on.
6534       NP=NP+1
6535       K(N+NP,3)=I
6536       DO 120 J=1,5
6537   120 P(N+NP,J)=P(I,J)
6538       IF(MSTU(42).EQ.0) P(N+NP,5)=0.
6539       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
6540       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
6541       P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6542       DO 130 J=1,4
6543   130 PS(J)=PS(J)+P(N+NP,J)
6544       PSS=PSS+P(N+NP,5)
6545   140 CONTINUE
6546       DO 150 I=N+1,N+NP
6547       K(I+NP,3)=K(I,3)
6548       DO 150 J=1,5
6549   150 P(I+NP,J)=P(I,J)
6550       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
6551
6552 C...Very low multiplicities not considered.
6553       IF(NP.LT.MSTU(47)) THEN
6554         CALL LUERRM(8,'(LUCLUS:) too few particles for analysis')
6555         NJET=-1
6556         RETURN
6557       ENDIF
6558
6559 C...Find precluster configuration. If too few jets, make harder cuts.
6560       NLOOP=0
6561       IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
6562       IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
6563       RINIT=1.25*PARU(43)
6564       IF(NP.LE.MSTU(47)+2) RINIT=0.
6565   160 RINIT=0.8*RINIT
6566       NPRE=0
6567       NREM=NP
6568       DO 170 I=N+NP+1,N+2*NP
6569   170 K(I,4)=0
6570
6571 C...Sum up small momentum region. Jet if enough absolute momentum.
6572       IF(MSTU(46).LE.2) THEN
6573         DO 180 J=1,4
6574   180   P(N+1,J)=0.
6575         DO 200 I=N+NP+1,N+2*NP
6576         IF(P(I,5).GT.2.*RINIT) GOTO 200
6577         NREM=NREM-1
6578         K(I,4)=1
6579         DO 190 J=1,4
6580   190   P(N+1,J)=P(N+1,J)+P(I,J)
6581   200   CONTINUE
6582         P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
6583         IF(P(N+1,5).GT.2.*RINIT) NPRE=1
6584         IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
6585       ENDIF
6586
6587 C...Find fastest remaining particle.
6588   210 NPRE=NPRE+1
6589       PMAX=0.
6590       DO 220 I=N+NP+1,N+2*NP
6591       IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 220
6592       IMAX=I
6593       PMAX=P(I,5)
6594   220 CONTINUE
6595       DO 230 J=1,5
6596   230 P(N+NPRE,J)=P(IMAX,J)
6597       NREM=NREM-1
6598       K(IMAX,4)=NPRE
6599
6600 C...Sum up precluster around it according to pT separation.
6601       IF(MSTU(46).LE.2) THEN
6602         DO 250 I=N+NP+1,N+2*NP
6603         IF(K(I,4).NE.0) GOTO 250
6604         R2=R2T(I,IMAX)
6605         IF(R2.GT.RINIT**2) GOTO 250
6606         NREM=NREM-1
6607         K(I,4)=NPRE
6608         DO 240 J=1,4
6609   240   P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
6610   250   CONTINUE
6611         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
6612
6613 C...Sum up precluster around it according to mass separation.
6614       ELSE
6615   260   IMIN=0
6616         R2MIN=RINIT**2
6617         DO 270 I=N+NP+1,N+2*NP
6618         IF(K(I,4).NE.0) GOTO 270
6619         R2=R2M(I,N+NPRE)
6620         IF(R2.GE.R2MIN) GOTO 270
6621         IMIN=I
6622         R2MIN=R2
6623   270   CONTINUE
6624         IF(IMIN.NE.0) THEN
6625           DO 280 J=1,4
6626   280     P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
6627           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
6628           NREM=NREM-1
6629           K(IMIN,4)=NPRE
6630           GOTO 260
6631         ENDIF
6632       ENDIF
6633
6634 C...Check if more preclusters to be found. Start over if too few.
6635       IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
6636       IF(NREM.GT.0) GOTO 210
6637       NJET=NPRE
6638
6639 C...Reassign all particles to nearest jet. Sum up new jet momenta.
6640   290 TSAV=0.
6641       PSJT=0.
6642   300 IF(MSTU(46).LE.1) THEN
6643         DO 310 I=N+1,N+NJET
6644         DO 310 J=1,4
6645   310   V(I,J)=0.
6646         DO 340 I=N+NP+1,N+2*NP
6647         R2MIN=PSS**2
6648         DO 320 IJET=N+1,N+NJET
6649         IF(P(IJET,5).LT.RINIT) GOTO 320
6650         R2=R2T(I,IJET)
6651         IF(R2.GE.R2MIN) GOTO 320
6652         IMIN=IJET
6653         R2MIN=R2
6654   320   CONTINUE
6655         K(I,4)=IMIN-N
6656         DO 330 J=1,4
6657   330   V(IMIN,J)=V(IMIN,J)+P(I,J)
6658   340   CONTINUE
6659         PSJT=0.
6660         DO 360 I=N+1,N+NJET
6661         DO 350 J=1,4
6662   350   P(I,J)=V(I,J)
6663         P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6664   360   PSJT=PSJT+P(I,5)
6665       ENDIF
6666
6667 C...Find two closest jets.
6668       R2MIN=2.*R2ACC
6669       DO 370 ITRY1=N+1,N+NJET-1
6670       DO 370 ITRY2=ITRY1+1,N+NJET
6671       IF(MSTU(46).LE.2) R2=R2T(ITRY1,ITRY2)
6672       IF(MSTU(46).GE.3) R2=R2M(ITRY1,ITRY2)
6673       IF(R2.GE.R2MIN) GOTO 370
6674       IMIN1=ITRY1
6675       IMIN2=ITRY2
6676       R2MIN=R2
6677   370 CONTINUE
6678
6679 C...If allowed, join two closest jets and start over.
6680       IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
6681         IREC=MIN(IMIN1,IMIN2)
6682         IDEL=MAX(IMIN1,IMIN2)
6683         DO 380 J=1,4
6684   380   P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
6685         P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
6686         DO 390 I=IDEL+1,N+NJET
6687         DO 390 J=1,5
6688   390   P(I-1,J)=P(I,J)
6689         IF(MSTU(46).GE.2) THEN
6690           DO 400 I=N+NP+1,N+2*NP
6691           IORI=N+K(I,4)
6692           IF(IORI.EQ.IDEL) K(I,4)=IREC-N
6693   400     IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
6694         ENDIF
6695         NJET=NJET-1
6696         GOTO 290
6697
6698 C...Divide up broad jet if empty cluster in list of final ones.
6699       ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
6700         DO 410 I=N+1,N+NJET
6701   410   K(I,5)=0
6702         DO 420 I=N+NP+1,N+2*NP
6703   420   K(N+K(I,4),5)=K(N+K(I,4),5)+1
6704         IEMP=0
6705         DO 430 I=N+1,N+NJET
6706   430   IF(K(I,5).EQ.0) IEMP=I
6707         IF(IEMP.NE.0) THEN
6708           NLOOP=NLOOP+1
6709           ISPL=0
6710           R2MAX=0.
6711           DO 440 I=N+NP+1,N+2*NP
6712           IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 440
6713           IJET=N+K(I,4)
6714           R2=R2T(I,IJET)
6715           IF(R2.LE.R2MAX) GOTO 440
6716           ISPL=I
6717           R2MAX=R2
6718   440     CONTINUE
6719           IF(ISPL.NE.0) THEN
6720             IJET=N+K(ISPL,4)
6721             DO 450 J=1,4
6722             P(IEMP,J)=P(ISPL,J)
6723   450       P(IJET,J)=P(IJET,J)-P(ISPL,J)
6724             P(IEMP,5)=P(ISPL,5)
6725             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
6726             IF(NLOOP.LE.2) GOTO 290
6727           ENDIF
6728         ENDIF
6729       ENDIF
6730
6731 C...If generalized thrust has not yet converged, continue iteration.
6732       IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
6733      &THEN
6734         TSAV=PSJT/PSS
6735         GOTO 300
6736       ENDIF
6737
6738 C...Reorder jets according to energy.
6739       DO 460 I=N+1,N+NJET
6740       DO 460 J=1,5
6741   460 V(I,J)=P(I,J)
6742       DO 490 INEW=N+1,N+NJET
6743       PEMAX=0.
6744       DO 470 ITRY=N+1,N+NJET
6745       IF(V(ITRY,4).LE.PEMAX) GOTO 470
6746       IMAX=ITRY
6747       PEMAX=V(ITRY,4)
6748   470 CONTINUE
6749       K(INEW,1)=31
6750       K(INEW,2)=97
6751       K(INEW,3)=INEW-N
6752       K(INEW,4)=0
6753       DO 480 J=1,5
6754   480 P(INEW,J)=V(IMAX,J)
6755       V(IMAX,4)=-1.
6756   490 K(IMAX,5)=INEW
6757
6758 C...Clean up particle-jet assignments and jet information.
6759       DO 500 I=N+NP+1,N+2*NP
6760       IORI=K(N+K(I,4),5)
6761       K(I,4)=IORI-N
6762       IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
6763       K(IORI,4)=K(IORI,4)+1
6764   500 CONTINUE
6765       IEMP=0
6766       PSJT=0.
6767       DO 520 I=N+1,N+NJET
6768       K(I,5)=0
6769       PSJT=PSJT+P(I,5)
6770       P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
6771       DO 510 J=1,5
6772   510 V(I,J)=0.
6773   520 IF(K(I,4).EQ.0) IEMP=I
6774
6775 C...Select storing option. Output variables. Check for failure.
6776       MSTU(61)=N+1
6777       MSTU(62)=NP
6778       MSTU(63)=NPRE
6779       PARU(61)=PS(5)
6780       PARU(62)=PSJT/PSS
6781       PARU(63)=SQRT(R2MIN)
6782       IF(NJET.LE.1) PARU(63)=0.
6783       IF(IEMP.NE.0) THEN
6784         CALL LUERRM(8,'(LUCLUS:) failed to reconstruct as requested')
6785         NJET=-1
6786       ENDIF
6787       IF(MSTU(43).LE.1) MSTU(3)=NJET
6788       IF(MSTU(43).GE.2) N=N+NJET
6789       NSAV=NJET
6790
6791       RETURN
6792       END
6793
6794 C*********************************************************************
6795
6796       SUBROUTINE LUCELL(NJET)
6797
6798 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
6799 C...coordinate frame, as used for calorimeters at hadron colliders.
6800       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6801       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6802       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6803       SAVE
6804
6805 C...Loop over all particles. Find cell that was hit by given particle.
6806       NCE2=2*MSTU(51)*MSTU(52)
6807       PTLRAT=1./SINH(PARU(51))**2
6808       NP=0
6809       NC=N
6810       DO 110 I=1,N
6811       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
6812       IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
6813       IF(MSTU(41).GE.2) THEN
6814         KC=LUCOMP(K(I,2))
6815         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6816      &  KC.EQ.18) GOTO 110
6817         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6818      &  GOTO 110
6819       ENDIF
6820       NP=NP+1
6821       PT=SQRT(P(I,1)**2+P(I,2)**2)
6822       ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
6823       IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))
6824       PHI=ULANGL(P(I,1),P(I,2))
6825       IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))
6826       IETPH=MSTU(52)*IETA+IPHI
6827
6828 C...Add to cell already hit, or book new cell.
6829       DO 100 IC=N+1,NC
6830       IF(IETPH.EQ.K(IC,3)) THEN
6831         K(IC,4)=K(IC,4)+1
6832         P(IC,5)=P(IC,5)+PT
6833         GOTO 110
6834       ENDIF
6835   100 CONTINUE
6836       IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
6837         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
6838         NJET=-2
6839         RETURN
6840       ENDIF
6841       NC=NC+1
6842       K(NC,3)=IETPH
6843       K(NC,4)=1
6844       K(NC,5)=2
6845       P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
6846       P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
6847       P(NC,5)=PT
6848   110 CONTINUE
6849
6850 C...Smear true bin content by calorimeter resolution.
6851       IF(MSTU(53).GE.1) THEN
6852         DO 130 IC=N+1,NC
6853         PEI=P(IC,5)
6854         IF(MSTU(53).EQ.2) PEI=P(IC,5)/COSH(P(IC,1))
6855   120   PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLU(0)))*PEI)*
6856      &  COS(PARU(2)*RLU(0))
6857         IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120
6858         P(IC,5)=PEF
6859   130   IF(MSTU(53).EQ.2) P(IC,5)=PEF*COSH(P(IC,1))
6860       ENDIF
6861
6862 C...Find initiator cell: the one with highest pT of not yet used ones.
6863       NJ=NC
6864   140 ETMAX=0.
6865       DO 150 IC=N+1,NC
6866       IF(K(IC,5).NE.2) GOTO 150
6867       IF(P(IC,5).LE.ETMAX) GOTO 150
6868       ICMAX=IC
6869       ETA=P(IC,1)
6870       PHI=P(IC,2)
6871       ETMAX=P(IC,5)
6872   150 CONTINUE
6873       IF(ETMAX.LT.PARU(52)) GOTO 210
6874       IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
6875         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
6876         NJET=-2
6877         RETURN
6878       ENDIF
6879       K(ICMAX,5)=1
6880       NJ=NJ+1
6881       K(NJ,4)=0
6882       K(NJ,5)=1
6883       P(NJ,1)=ETA
6884       P(NJ,2)=PHI
6885       P(NJ,3)=0.
6886       P(NJ,4)=0.
6887       P(NJ,5)=0.
6888
6889 C...Sum up unused cells within required distance of initiator.
6890       DO 160 IC=N+1,NC
6891       IF(K(IC,5).EQ.0) GOTO 160
6892       IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 160
6893       DPHIA=ABS(P(IC,2)-PHI)
6894       IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 160
6895       PHIC=P(IC,2)
6896       IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
6897       IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 160
6898       K(IC,5)=-K(IC,5)
6899       K(NJ,4)=K(NJ,4)+K(IC,4)
6900       P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
6901       P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
6902       P(NJ,5)=P(NJ,5)+P(IC,5)
6903   160 CONTINUE
6904
6905 C...Reject cluster below minimum ET, else accept.
6906       IF(P(NJ,5).LT.PARU(53)) THEN
6907         NJ=NJ-1
6908         DO 170 IC=N+1,NC
6909   170   IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
6910       ELSEIF(MSTU(54).LE.2) THEN
6911         P(NJ,3)=P(NJ,3)/P(NJ,5)
6912         P(NJ,4)=P(NJ,4)/P(NJ,5)
6913         IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
6914      &  P(NJ,4))
6915         DO 180 IC=N+1,NC
6916   180   IF(K(IC,1).LT.0) K(IC,1)=0
6917       ELSE
6918         DO 190 J=1,4
6919   190   P(NJ,J)=0.
6920         DO 200 IC=N+1,NC
6921         IF(K(IC,5).GE.0) GOTO 200
6922         P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
6923         P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
6924         P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
6925         P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
6926         K(IC,5)=0
6927   200   CONTINUE
6928       ENDIF
6929       GOTO 140
6930
6931 C...Arrange clusters in falling ET sequence.
6932   210 DO 230 I=1,NJ-NC
6933       ETMAX=0.
6934       DO 220 IJ=NC+1,NJ
6935       IF(K(IJ,5).EQ.0) GOTO 220
6936       IF(P(IJ,5).LT.ETMAX) GOTO 220
6937       IJMAX=IJ
6938       ETMAX=P(IJ,5)
6939   220 CONTINUE
6940       K(IJMAX,5)=0
6941       K(N+I,1)=31
6942       K(N+I,2)=98
6943       K(N+I,3)=I
6944       K(N+I,4)=K(IJMAX,4)
6945       K(N+I,5)=0
6946       DO 230 J=1,5
6947       P(N+I,J)=P(IJMAX,J)
6948   230 V(N+I,J)=0.
6949       NJET=NJ-NC
6950
6951 C...Convert to massless or massive four-vectors.
6952       IF(MSTU(54).EQ.2) THEN
6953         DO 240 I=N+1,N+NJET
6954         ETA=P(I,3)
6955         P(I,1)=P(I,5)*COS(P(I,4))
6956         P(I,2)=P(I,5)*SIN(P(I,4))
6957         P(I,3)=P(I,5)*SINH(ETA)
6958         P(I,4)=P(I,5)*COSH(ETA)
6959   240   P(I,5)=0.
6960       ELSEIF(MSTU(54).GE.3) THEN
6961         DO 250 I=N+1,N+NJET
6962   250   P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
6963       ENDIF
6964
6965 C...Information about storage.
6966       MSTU(61)=N+1
6967       MSTU(62)=NP
6968       MSTU(63)=NC-N
6969       IF(MSTU(43).LE.1) MSTU(3)=NJET
6970       IF(MSTU(43).GE.2) N=N+NJET
6971
6972       RETURN
6973       END
6974
6975 C*********************************************************************
6976
6977       SUBROUTINE LUJMAS(PMH,PML)
6978
6979 C...Purpose: to determine, approximately, the two jet masses that
6980 C...minimize the sum m_H|2 + m_L|2, a la Clavelli and Wyler.
6981       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6982       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6983       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6984       DIMENSION SM(3,3),SAX(3),PS(3,5)
6985       SAVE
6986
6987 C...Reset.
6988       NP=0
6989       DO 110 J1=1,3
6990       DO 100 J2=J1,3
6991   100 SM(J1,J2)=0.
6992       DO 110 J2=1,4
6993   110 PS(J1,J2)=0.
6994       PSS=0.
6995
6996 C...Take copy of particles that are to be considered in mass analysis.
6997       DO 150 I=1,N
6998       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
6999       IF(MSTU(41).GE.2) THEN
7000         KC=LUCOMP(K(I,2))
7001         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7002      &  KC.EQ.18) GOTO 150
7003         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7004      &  GOTO 150
7005       ENDIF
7006       IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
7007         CALL LUERRM(11,'(LUJMAS:) no more memory left in LUJETS')
7008         PMH=-2.
7009         PML=-2.
7010         RETURN
7011       ENDIF
7012       NP=NP+1
7013       DO 120 J=1,5
7014   120 P(N+NP,J)=P(I,J)
7015       IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7016       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7017       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7018
7019 C...Fill information in sphericity tensor and total momentum vector.
7020       DO 130 J1=1,3
7021       DO 130 J2=J1,3
7022   130 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
7023       PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7024       DO 140 J=1,4
7025   140 PS(3,J)=PS(3,J)+P(N+NP,J)
7026   150 CONTINUE
7027
7028 C...Very low multiplicities (0 or 1) not considered.
7029       IF(NP.LE.1) THEN
7030         CALL LUERRM(8,'(LUJMAS:) too few particles for analysis')
7031         PMH=-1.
7032         PML=-1.
7033         RETURN
7034       ENDIF
7035       PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
7036
7037 C...Find largest eigenvalue to matrix (third degree equation).
7038       DO 160 J1=1,3
7039       DO 160 J2=J1,3
7040   160 SM(J1,J2)=SM(J1,J2)/PSS
7041       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
7042      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
7043       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
7044      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
7045       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
7046       SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
7047
7048 C...Find largest eigenvector by solving equation system.
7049       DO J1=1,3
7050       SM(J1,J1)=SM(J1,J1)-SMA
7051 C     CMSSW change: added if to stay in array bounds
7052       IF(J1<3) THEN
7053       DO J2=J1+1,3
7054       SM(J2,J1)=SM(J1,J2)
7055       ENDDO
7056       ENDIF
7057       ENDDO
7058       SMAX=0.
7059       DO 180 J1=1,3
7060       DO 180 J2=1,3
7061       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 180
7062       JA=J1
7063       JB=J2
7064       SMAX=ABS(SM(J1,J2))
7065   180 CONTINUE
7066       SMAX=0.
7067       DO 190 J3=JA+1,JA+2
7068       J1=J3-3*((J3-1)/3)
7069       RL=SM(J1,JB)/SM(JA,JB)
7070       DO 190 J2=1,3
7071       SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
7072       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 190
7073       JC=J1
7074       SMAX=ABS(SM(J1,J2))
7075   190 CONTINUE
7076       JB1=JB+1-3*(JB/3)
7077       JB2=JB+2-3*((JB+1)/3)
7078       SAX(JB1)=-SM(JC,JB2)
7079       SAX(JB2)=SM(JC,JB1)
7080       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
7081
7082 C...Divide particles into two initial clusters by hemisphere.
7083       DO 200 I=N+1,N+NP
7084       PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
7085       IS=1
7086       IF(PSAX.LT.0.) IS=2
7087       K(I,3)=IS
7088       DO 200 J=1,4
7089   200 PS(IS,J)=PS(IS,J)+P(I,J)
7090       PMS=(PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
7091      &(PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
7092
7093 C...Reassign one particle at a time; find maximum decrease of m|2 sum.
7094   210 PMD=0.
7095       IM=0
7096       DO 220 J=1,4
7097   220 PS(3,J)=PS(1,J)-PS(2,J)
7098       DO 230 I=N+1,N+NP
7099       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)
7100       IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)
7101       IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)
7102       IF(PMDI.LT.PMD) THEN
7103         PMD=PMDI
7104         IM=I
7105       ENDIF
7106   230 CONTINUE
7107
7108 C...Loop back if significant reduction in sum of m|2.
7109       IF(PMD.LT.-PARU(48)*PMS) THEN
7110         PMS=PMS+PMD
7111         IS=K(IM,3)
7112         DO 240 J=1,4
7113         PS(IS,J)=PS(IS,J)-P(IM,J)
7114   240   PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
7115         K(IM,3)=3-IS
7116         GOTO 210
7117       ENDIF
7118
7119 C...Final masses and output.
7120       MSTU(61)=N+1
7121       MSTU(62)=NP
7122       PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
7123       PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
7124       PMH=MAX(PS(1,5),PS(2,5))
7125       PML=MIN(PS(1,5),PS(2,5))
7126
7127       RETURN
7128       END
7129
7130 C*********************************************************************
7131
7132       SUBROUTINE LUFOWO(H10,H20,H30,H40)
7133
7134 C...Purpose: to calculate the first few Fox-Wolfram moments.
7135       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7136       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7137       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7138       SAVE
7139
7140 C...Copy momenta for particles and calculate H0.
7141       NP=0
7142       H0=0.
7143       HD=0.
7144       DO 110 I=1,N
7145       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7146       IF(MSTU(41).GE.2) THEN
7147         KC=LUCOMP(K(I,2))
7148         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7149      &  KC.EQ.18) GOTO 110
7150         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7151      &  GOTO 110
7152       ENDIF
7153       IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
7154         CALL LUERRM(11,'(LUFOWO:) no more memory left in LUJETS')
7155         H10=-1.
7156         H20=-1.
7157         H30=-1.
7158         H40=-1.
7159         RETURN
7160       ENDIF
7161       NP=NP+1
7162       DO 100 J=1,3
7163   100 P(N+NP,J)=P(I,J)
7164       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7165       H0=H0+P(N+NP,4)
7166       HD=HD+P(N+NP,4)**2
7167   110 CONTINUE
7168       H0=H0**2
7169
7170 C...Very low multiplicities (0 or 1) not considered.
7171       IF(NP.LE.1) THEN
7172         CALL LUERRM(8,'(LUFOWO:) too few particles for analysis')
7173         H10=-1.
7174         H20=-1.
7175         H30=-1.
7176         H40=-1.
7177         RETURN
7178       ENDIF
7179
7180 C...Calculate H1 - H4.
7181       H10=0.
7182       H20=0.
7183       H30=0.
7184       H40=0.
7185       DO 120 I1=N+1,N+NP
7186       DO 120 I2=I1+1,N+NP
7187       CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
7188      &(P(I1,4)*P(I2,4))
7189       H10=H10+P(I1,4)*P(I2,4)*CTHE
7190       H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5)
7191       H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)
7192       H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)
7193   120 CONTINUE
7194
7195 C...Calculate H1/H0 - H4/H0. Output.
7196       MSTU(61)=N+1
7197       MSTU(62)=NP
7198       H10=(HD+2.*H10)/H0
7199       H20=(HD+2.*H20)/H0
7200       H30=(HD+2.*H30)/H0
7201       H40=(HD+2.*H40)/H0
7202
7203       RETURN
7204       END
7205
7206 C*********************************************************************
7207
7208       SUBROUTINE LUTABU(MTABU)
7209
7210 C...Purpose: to evaluate various properties of an event, with
7211 C...statistics accumulated during the course of the run and
7212 C...printed at the end.
7213       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7214       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7215       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7216       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
7217       DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
7218      &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
7219      &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
7220      &KFDM(8),KFDC(200,0:8),NPDC(200)
7221 C      SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
7222 C     &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
7223 C     &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
7224       CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
7225       SAVE
7226       DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
7227      &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,
7228      &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./,
7229      &NEVDC/0/,NKFDC/0/,NREDC/0/
7230
7231 C...Reset statistics on initial parton state.
7232       IF(MTABU.EQ.10) THEN
7233         NEVIS=0
7234         NKFIS=0
7235
7236 C...Identify and order flavour content of initial state.
7237       ELSEIF(MTABU.EQ.11) THEN
7238         NEVIS=NEVIS+1
7239         KFM1=2*IABS(MSTU(161))
7240         IF(MSTU(161).GT.0) KFM1=KFM1-1
7241         KFM2=2*IABS(MSTU(162))
7242         IF(MSTU(162).GT.0) KFM2=KFM2-1
7243         KFMN=MIN(KFM1,KFM2)
7244         KFMX=MAX(KFM1,KFM2)
7245         DO 100 I=1,NKFIS
7246         IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
7247           IKFIS=-I
7248           GOTO 110
7249         ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
7250      &  KFMX.LT.KFIS(I,2))) THEN
7251           IKFIS=I
7252           GOTO 110
7253         ENDIF
7254   100   CONTINUE
7255         IKFIS=NKFIS+1
7256   110   IF(IKFIS.LT.0) THEN
7257           IKFIS=-IKFIS
7258         ELSE
7259           IF(NKFIS.GE.100) RETURN
7260           DO 120 I=NKFIS,IKFIS,-1
7261           KFIS(I+1,1)=KFIS(I,1)
7262           KFIS(I+1,2)=KFIS(I,2)
7263           DO 120 J=0,10
7264   120     NPIS(I+1,J)=NPIS(I,J)
7265           NKFIS=NKFIS+1
7266           KFIS(IKFIS,1)=KFMN
7267           KFIS(IKFIS,2)=KFMX
7268           DO 130 J=0,10
7269   130     NPIS(IKFIS,J)=0
7270         ENDIF
7271         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
7272
7273 C...Count number of partons in initial state.
7274         NP=0
7275         DO 150 I=1,N
7276         IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
7277         ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
7278         ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
7279      &  THEN
7280         ELSE
7281           IM=I
7282   140     IM=K(IM,3)
7283           IF(IM.LE.0.OR.IM.GT.N) THEN
7284             NP=NP+1
7285           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7286             NP=NP+1
7287           ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
7288           ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)
7289      &    THEN
7290           ELSE
7291             GOTO 140
7292           ENDIF
7293         ENDIF
7294   150   CONTINUE
7295         NPCO=MAX(NP,1)
7296         IF(NP.GE.6) NPCO=6
7297         IF(NP.GE.8) NPCO=7
7298         IF(NP.GE.11) NPCO=8
7299         IF(NP.GE.16) NPCO=9
7300         IF(NP.GE.26) NPCO=10
7301         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
7302         MSTU(62)=NP
7303
7304 C...Write statistics on initial parton state.
7305       ELSEIF(MTABU.EQ.12) THEN
7306         FAC=1./MAX(1,NEVIS)
7307         WRITE(MSTU(11),1000) NEVIS
7308         DO 160 I=1,NKFIS
7309         KFMN=KFIS(I,1)
7310         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7311         KFM1=(KFMN+1)/2
7312         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7313         CALL LUNAME(KFM1,CHAU)
7314         CHIS(1)=CHAU(1:12)
7315         IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
7316         KFMX=KFIS(I,2)
7317         IF(KFIS(I,1).EQ.0) KFMX=0
7318         KFM2=(KFMX+1)/2
7319         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7320         CALL LUNAME(KFM2,CHAU)
7321         CHIS(2)=CHAU(1:12)
7322         IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
7323   160   WRITE(MSTU(11),1100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
7324      &  (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10)
7325
7326 C...Copy statistics on initial parton state into /LUJETS/.
7327       ELSEIF(MTABU.EQ.13) THEN
7328         FAC=1./MAX(1,NEVIS)
7329         DO 170 I=1,NKFIS
7330         KFMN=KFIS(I,1)
7331         IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7332         KFM1=(KFMN+1)/2
7333         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7334         KFMX=KFIS(I,2)
7335         IF(KFIS(I,1).EQ.0) KFMX=0
7336         KFM2=(KFMX+1)/2
7337         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7338         K(I,1)=32
7339         K(I,2)=99
7340         K(I,3)=KFM1
7341         K(I,4)=KFM2
7342         K(I,5)=NPIS(I,0)
7343         DO 170 J=1,5
7344         P(I,J)=FAC*NPIS(I,J)
7345   170   V(I,J)=FAC*NPIS(I,J+5)
7346         N=NKFIS
7347         DO 180 J=1,5
7348         K(N+1,J)=0
7349         P(N+1,J)=0.
7350   180   V(N+1,J)=0.
7351         K(N+1,1)=32
7352         K(N+1,2)=99
7353         K(N+1,5)=NEVIS
7354         MSTU(3)=1
7355
7356 C...Reset statistics on number of particles/partons.
7357       ELSEIF(MTABU.EQ.20) THEN
7358         NEVFS=0
7359         NPRFS=0
7360         NFIFS=0
7361         NCHFS=0
7362         NKFFS=0
7363
7364 C...Identify whether particle/parton is primary or not.
7365       ELSEIF(MTABU.EQ.21) THEN
7366         NEVFS=NEVFS+1
7367         MSTU(62)=0
7368         DO 230 I=1,N
7369         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 230
7370         MSTU(62)=MSTU(62)+1
7371         KC=LUCOMP(K(I,2))
7372         MPRI=0
7373         IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
7374           MPRI=1
7375         ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
7376           MPRI=1
7377         ELSEIF(KC.EQ.0) THEN
7378         ELSEIF(K(K(I,3),1).EQ.13) THEN
7379           IM=K(K(I,3),3)
7380           IF(IM.LE.0.OR.IM.GT.N) THEN
7381             MPRI=1
7382           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7383             MPRI=1
7384           ENDIF
7385         ELSEIF(KCHG(KC,2).EQ.0) THEN
7386           KCM=LUCOMP(K(K(I,3),2))
7387           IF(KCM.NE.0) THEN
7388             IF(KCHG(KCM,2).NE.0) MPRI=1
7389           ENDIF
7390         ENDIF
7391         IF(KC.NE.0.AND.MPRI.EQ.1) THEN
7392           IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
7393         ENDIF
7394         IF(K(I,1).LE.10) THEN
7395           NFIFS=NFIFS+1
7396           IF(LUCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
7397         ENDIF
7398
7399 C...Fill statistics on number of particles/partons in event.
7400         KFA=IABS(K(I,2))
7401         KFS=3-ISIGN(1,K(I,2))-MPRI
7402         DO 190 IP=1,NKFFS
7403         IF(KFA.EQ.KFFS(IP)) THEN
7404           IKFFS=-IP
7405           GOTO 200
7406         ELSEIF(KFA.LT.KFFS(IP)) THEN
7407           IKFFS=IP
7408           GOTO 200
7409         ENDIF
7410   190   CONTINUE
7411         IKFFS=NKFFS+1
7412   200   IF(IKFFS.LT.0) THEN
7413           IKFFS=-IKFFS
7414         ELSE
7415           IF(NKFFS.GE.400) RETURN
7416           DO 210 IP=NKFFS,IKFFS,-1
7417           KFFS(IP+1)=KFFS(IP)
7418           DO 210 J=1,4
7419   210     NPFS(IP+1,J)=NPFS(IP,J)
7420           NKFFS=NKFFS+1
7421           KFFS(IKFFS)=KFA
7422           DO 220 J=1,4
7423   220     NPFS(IKFFS,J)=0
7424         ENDIF
7425         NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
7426   230   CONTINUE
7427
7428 C...Write statistics on particle/parton composition of events.
7429       ELSEIF(MTABU.EQ.22) THEN
7430         FAC=1./MAX(1,NEVFS)
7431         WRITE(MSTU(11),1200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
7432         DO 240 I=1,NKFFS
7433         CALL LUNAME(KFFS(I),CHAU)
7434         KC=LUCOMP(KFFS(I))
7435         MDCYF=0
7436         IF(KC.NE.0) MDCYF=MDCY(KC,1)
7437   240   WRITE(MSTU(11),1300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
7438      &  FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
7439
7440 C...Copy particle/parton composition information into /LUJETS/.
7441       ELSEIF(MTABU.EQ.23) THEN
7442         FAC=1./MAX(1,NEVFS)
7443         DO 260 I=1,NKFFS
7444         K(I,1)=32
7445         K(I,2)=99
7446         K(I,3)=KFFS(I)
7447         K(I,4)=0
7448         K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
7449         DO 250 J=1,4
7450         P(I,J)=FAC*NPFS(I,J)
7451   250   V(I,J)=0.
7452         P(I,5)=FAC*K(I,5)
7453   260   V(I,5)=0.
7454         N=NKFFS
7455         DO 270 J=1,5
7456         K(N+1,J)=0
7457         P(N+1,J)=0.
7458   270   V(N+1,J)=0.
7459         K(N+1,1)=32
7460         K(N+1,2)=99
7461         K(N+1,5)=NEVFS
7462         P(N+1,1)=FAC*NPRFS
7463         P(N+1,2)=FAC*NFIFS
7464         P(N+1,3)=FAC*NCHFS
7465         MSTU(3)=1
7466
7467 C...Reset factorial moments statistics.
7468       ELSEIF(MTABU.EQ.30) THEN
7469         NEVFM=0
7470         NMUFM=0
7471         DO 280 IM=1,3
7472         DO 280 IB=1,10
7473         DO 280 IP=1,4
7474         FM1FM(IM,IB,IP)=0.
7475   280   FM2FM(IM,IB,IP)=0.
7476
7477 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
7478       ELSEIF(MTABU.EQ.31) THEN
7479         NEVFM=NEVFM+1
7480         NLOW=N+MSTU(3)
7481         NUPP=NLOW
7482         DO 360 I=1,N
7483         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
7484         IF(MSTU(41).GE.2) THEN
7485           KC=LUCOMP(K(I,2))
7486           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7487      &    KC.EQ.18) GOTO 360
7488           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7489      &    GOTO 360
7490         ENDIF
7491         PMR=0.
7492         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
7493         IF(MSTU(42).GE.2) PMR=P(I,5)
7494         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
7495         YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
7496      &  1E20)),P(I,3))
7497         IF(ABS(YETA).GT.PARU(57)) GOTO 360
7498         PHI=ULANGL(P(I,1),P(I,2))
7499         IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))
7500         IYETA=MAX(0,MIN(511,IYETA))
7501         IPHI=512.*(PHI+PARU(1))/PARU(2)
7502         IPHI=MAX(0,MIN(511,IPHI))
7503         IYEP=0
7504         DO 290 IB=0,9
7505   290   IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
7506
7507 C...Order particles in (pseudo)rapidity and/or azimuth.
7508         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
7509           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
7510           RETURN
7511         ENDIF
7512         NUPP=NUPP+1
7513         IF(NUPP.EQ.NLOW+1) THEN
7514           K(NUPP,1)=IYETA
7515           K(NUPP,2)=IPHI
7516           K(NUPP,3)=IYEP
7517         ELSE
7518           DO 300 I1=NUPP-1,NLOW+1,-1
7519           IF(IYETA.GE.K(I1,1)) GOTO 310
7520   300     K(I1+1,1)=K(I1,1)
7521   310     K(I1+1,1)=IYETA
7522           DO 320 I1=NUPP-1,NLOW+1,-1
7523           IF(IPHI.GE.K(I1,2)) GOTO 330
7524   320     K(I1+1,2)=K(I1,2)
7525   330     K(I1+1,2)=IPHI
7526           DO 340 I1=NUPP-1,NLOW+1,-1
7527           IF(IYEP.GE.K(I1,3)) GOTO 350
7528   340     K(I1+1,3)=K(I1,3)
7529   350     K(I1+1,3)=IYEP
7530         ENDIF
7531   360   CONTINUE
7532         K(NUPP+1,1)=2**10
7533         K(NUPP+1,2)=2**10
7534         K(NUPP+1,3)=4**10
7535
7536 C...Calculate sum of factorial moments in event.
7537         DO 400 IM=1,3
7538         DO 370 IB=1,10
7539         DO 370 IP=1,4
7540   370   FEVFM(IB,IP)=0.
7541         DO 380 IB=1,10
7542         IF(IM.LE.2) IBIN=2**(10-IB)
7543         IF(IM.EQ.3) IBIN=4**(10-IB)
7544         IAGR=K(NLOW+1,IM)/IBIN
7545         NAGR=1
7546         DO 380 I=NLOW+2,NUPP+1
7547         ICUT=K(I,IM)/IBIN
7548         IF(ICUT.EQ.IAGR) THEN
7549           NAGR=NAGR+1
7550         ELSE
7551           IF(NAGR.EQ.1) THEN
7552           ELSEIF(NAGR.EQ.2) THEN
7553             FEVFM(IB,1)=FEVFM(IB,1)+2.
7554           ELSEIF(NAGR.EQ.3) THEN
7555             FEVFM(IB,1)=FEVFM(IB,1)+6.
7556             FEVFM(IB,2)=FEVFM(IB,2)+6.
7557           ELSEIF(NAGR.EQ.4) THEN
7558             FEVFM(IB,1)=FEVFM(IB,1)+12.
7559             FEVFM(IB,2)=FEVFM(IB,2)+24.
7560             FEVFM(IB,3)=FEVFM(IB,3)+24.
7561           ELSE
7562             FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)
7563             FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)
7564             FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)
7565             FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)*
7566      &      (NAGR-4.)
7567           ENDIF
7568           IAGR=ICUT
7569           NAGR=1
7570         ENDIF
7571   380   CONTINUE
7572
7573 C...Add results to total statistics.
7574         DO 390 IB=10,1,-1
7575         DO 390 IP=1,4
7576         IF(FEVFM(1,IP).LT.0.5) THEN
7577           FEVFM(IB,IP)=0.
7578         ELSEIF(IM.LE.2) THEN
7579           FEVFM(IB,IP)=2**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
7580         ELSE
7581           FEVFM(IB,IP)=4**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
7582         ENDIF
7583         FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
7584   390   FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
7585   400   CONTINUE
7586         NMUFM=NMUFM+(NUPP-NLOW)
7587         MSTU(62)=NUPP-NLOW
7588
7589 C...Write accumulated statistics on factorial moments.
7590       ELSEIF(MTABU.EQ.32) THEN
7591         FAC=1./MAX(1,NEVFM)
7592         IF(MSTU(42).LE.0) WRITE(MSTU(11),1400) NEVFM,'eta'
7593         IF(MSTU(42).EQ.1) WRITE(MSTU(11),1400) NEVFM,'ypi'
7594         IF(MSTU(42).GE.2) WRITE(MSTU(11),1400) NEVFM,'y  '
7595         DO 420 IM=1,3
7596         WRITE(MSTU(11),1500)
7597         DO 420 IB=1,10
7598         BYETA=2.*PARU(57)
7599         IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
7600         BPHI=PARU(2)
7601         IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
7602         IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))
7603         IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))
7604         DO 410 IP=1,4
7605         FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
7606   410   FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
7607   420   WRITE(MSTU(11),1600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
7608      &  IP=1,4)
7609
7610 C...Copy statistics on factorial moments into /LUJETS/.
7611       ELSEIF(MTABU.EQ.33) THEN
7612         FAC=1./MAX(1,NEVFM)
7613         DO 430 IM=1,3
7614         DO 430 IB=1,10
7615         I=10*(IM-1)+IB
7616         K(I,1)=32
7617         K(I,2)=99
7618         K(I,3)=1
7619         IF(IM.NE.2) K(I,3)=2**(IB-1)
7620         K(I,4)=1
7621         IF(IM.NE.1) K(I,4)=2**(IB-1)
7622         K(I,5)=0
7623         P(I,1)=2.*PARU(57)/K(I,3)
7624         V(I,1)=PARU(2)/K(I,4)
7625         DO 430 IP=1,4
7626         P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
7627   430   V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))
7628         N=30
7629         DO 440 J=1,5
7630         K(N+1,J)=0
7631         P(N+1,J)=0.
7632   440   V(N+1,J)=0.
7633         K(N+1,1)=32
7634         K(N+1,2)=99
7635         K(N+1,5)=NEVFM
7636         MSTU(3)=1
7637
7638 C...Reset statistics on Energy-Energy Correlation.
7639       ELSEIF(MTABU.EQ.40) THEN
7640         NEVEE=0
7641         DO 450 J=1,25
7642         FE1EC(J)=0.
7643         FE2EC(J)=0.
7644         FE1EC(51-J)=0.
7645         FE2EC(51-J)=0.
7646         FE1EA(J)=0.
7647   450   FE2EA(J)=0.
7648
7649 C...Find particles to include, with proper assumed mass.
7650       ELSEIF(MTABU.EQ.41) THEN
7651         NEVEE=NEVEE+1
7652         NLOW=N+MSTU(3)
7653         NUPP=NLOW
7654         ECM=0.
7655         DO 460 I=1,N
7656         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 460
7657         IF(MSTU(41).GE.2) THEN
7658           KC=LUCOMP(K(I,2))
7659           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7660      &    KC.EQ.18) GOTO 460
7661           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7662      &    GOTO 460
7663         ENDIF
7664         PMR=0.
7665         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
7666         IF(MSTU(42).GE.2) PMR=P(I,5)
7667         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
7668           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
7669           RETURN
7670         ENDIF
7671         NUPP=NUPP+1
7672         P(NUPP,1)=P(I,1)
7673         P(NUPP,2)=P(I,2)
7674         P(NUPP,3)=P(I,3)
7675         P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7676         P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
7677         ECM=ECM+P(NUPP,4)
7678   460   CONTINUE
7679         IF(NUPP.EQ.NLOW) RETURN
7680
7681 C...Analyze Energy-Energy Correlation in event.
7682         FAC=(2./ECM**2)*50./PARU(1)
7683         DO 470 J=1,50
7684   470   FEVEE(J)=0.
7685         DO 480 I1=NLOW+2,NUPP
7686         DO 480 I2=NLOW+1,I1-1
7687         CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
7688      &  (P(I1,5)*P(I2,5))
7689         THE=ACOS(MAX(-1.,MIN(1.,CTHE)))
7690         ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))
7691   480   FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
7692         DO 490 J=1,25
7693         FE1EC(J)=FE1EC(J)+FEVEE(J)
7694         FE2EC(J)=FE2EC(J)+FEVEE(J)**2
7695         FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
7696         FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
7697         FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
7698   490   FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
7699         MSTU(62)=NUPP-NLOW
7700
7701 C...Write statistics on Energy-Energy Correlation.
7702       ELSEIF(MTABU.EQ.42) THEN
7703         FAC=1./MAX(1,NEVEE)
7704         WRITE(MSTU(11),1700) NEVEE
7705         DO 500 J=1,25
7706         FEEC1=FAC*FE1EC(J)
7707         FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2)))
7708         FEEC2=FAC*FE1EC(51-J)
7709         FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
7710         FEECA=FAC*FE1EA(J)
7711         FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2)))
7712   500   WRITE(MSTU(11),1800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,
7713      &  FEECA,FEESA
7714
7715 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
7716       ELSEIF(MTABU.EQ.43) THEN
7717         FAC=1./MAX(1,NEVEE)
7718         DO 510 I=1,25
7719         K(I,1)=32
7720         K(I,2)=99
7721         K(I,3)=0
7722         K(I,4)=0
7723         K(I,5)=0
7724         P(I,1)=FAC*FE1EC(I)
7725         V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
7726         P(I,2)=FAC*FE1EC(51-I)
7727         V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
7728         P(I,3)=FAC*FE1EA(I)
7729         V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
7730         P(I,4)=PARU(1)*(I-1)/50.
7731         P(I,5)=PARU(1)*I/50.
7732         V(I,4)=3.6*(I-1)
7733   510   V(I,5)=3.6*I
7734         N=25
7735         DO 520 J=1,5
7736         K(N+1,J)=0
7737         P(N+1,J)=0.
7738   520   V(N+1,J)=0.
7739         K(N+1,1)=32
7740         K(N+1,2)=99
7741         K(N+1,5)=NEVEE
7742         MSTU(3)=1
7743
7744 C...Reset statistics on decay channels.
7745       ELSEIF(MTABU.EQ.50) THEN
7746         NEVDC=0
7747         NKFDC=0
7748         NREDC=0
7749
7750 C...Identify and order flavour content of final state.
7751       ELSEIF(MTABU.EQ.51) THEN
7752         NEVDC=NEVDC+1
7753         NDS=0
7754         DO 550 I=1,N
7755         IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 550
7756         NDS=NDS+1
7757         IF(NDS.GT.8) THEN
7758           NREDC=NREDC+1
7759           RETURN
7760         ENDIF
7761         KFM=2*IABS(K(I,2))
7762         IF(K(I,2).LT.0) KFM=KFM-1
7763         DO 530 IDS=NDS-1,1,-1
7764         IIN=IDS+1
7765         IF(KFM.LT.KFDM(IDS)) GOTO 540
7766   530   KFDM(IDS+1)=KFDM(IDS)
7767         IIN=1
7768   540   KFDM(IIN)=KFM
7769   550   CONTINUE
7770
7771 C...Find whether old or new final state.
7772         DO 570 IDC=1,NKFDC
7773         IF(NDS.LT.KFDC(IDC,0)) THEN
7774           IKFDC=IDC
7775           GOTO 580
7776         ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
7777           DO 560 I=1,NDS
7778           IF(KFDM(I).LT.KFDC(IDC,I)) THEN
7779             IKFDC=IDC
7780             GOTO 580
7781           ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
7782             GOTO 570
7783           ENDIF
7784   560     CONTINUE
7785           IKFDC=-IDC
7786           GOTO 580
7787         ENDIF
7788   570   CONTINUE
7789         IKFDC=NKFDC+1
7790   580   IF(IKFDC.LT.0) THEN
7791           IKFDC=-IKFDC
7792         ELSEIF(NKFDC.GE.200) THEN
7793           NREDC=NREDC+1
7794           RETURN
7795         ELSE
7796           DO 590 IDC=NKFDC,IKFDC,-1
7797           NPDC(IDC+1)=NPDC(IDC)
7798           DO 590 I=0,8
7799   590     KFDC(IDC+1,I)=KFDC(IDC,I)
7800           NKFDC=NKFDC+1
7801           KFDC(IKFDC,0)=NDS
7802           DO 600 I=1,NDS
7803   600     KFDC(IKFDC,I)=KFDM(I)
7804           NPDC(IKFDC)=0
7805         ENDIF
7806         NPDC(IKFDC)=NPDC(IKFDC)+1
7807
7808 C...Write statistics on decay channels.
7809       ELSEIF(MTABU.EQ.52) THEN
7810         FAC=1./MAX(1,NEVDC)
7811         WRITE(MSTU(11),1900) NEVDC
7812         DO 620 IDC=1,NKFDC
7813         DO 610 I=1,KFDC(IDC,0)
7814         KFM=KFDC(IDC,I)
7815         KF=(KFM+1)/2
7816         IF(2*KF.NE.KFM) KF=-KF
7817         CALL LUNAME(KF,CHAU)
7818         CHDC(I)=CHAU(1:12)
7819   610   IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
7820   620   WRITE(MSTU(11),2000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
7821         IF(NREDC.NE.0) WRITE(MSTU(11),2100) FAC*NREDC
7822
7823 C...Copy statistics on decay channels into /LUJETS/.
7824       ELSEIF(MTABU.EQ.53) THEN
7825         FAC=1./MAX(1,NEVDC)
7826         DO 650 IDC=1,NKFDC
7827         K(IDC,1)=32
7828         K(IDC,2)=99
7829         K(IDC,3)=0
7830         K(IDC,4)=0
7831         K(IDC,5)=KFDC(IDC,0)
7832         DO 630 J=1,5
7833         P(IDC,J)=0.
7834   630   V(IDC,J)=0.
7835         DO 640 I=1,KFDC(IDC,0)
7836         KFM=KFDC(IDC,I)
7837         KF=(KFM+1)/2
7838         IF(2*KF.NE.KFM) KF=-KF
7839         IF(I.LE.5) P(IDC,I)=KF
7840   640   IF(I.GE.6) V(IDC,I-5)=KF
7841   650   V(IDC,5)=FAC*NPDC(IDC)
7842         N=NKFDC
7843         DO 660 J=1,5
7844         K(N+1,J)=0
7845         P(N+1,J)=0.
7846   660   V(N+1,J)=0.
7847         K(N+1,1)=32
7848         K(N+1,2)=99
7849         K(N+1,5)=NEVDC
7850         V(N+1,5)=FAC*NREDC
7851         MSTU(3)=1
7852       ENDIF
7853
7854 C...Format statements for output on unit MSTU(11) (default 6).
7855  1000 FORMAT(///20X,'Event statistics - initial state'/
7856      &20X,'based on an analysis of ',I6,' events'//
7857      &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
7858      &'according to fragmenting system multiplicity'/
7859      &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
7860      &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
7861  1100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
7862  1200 FORMAT(///20X,'Event statistics - final state'/
7863      &20X,'based on an analysis of ',I6,' events'//
7864      &5X,'Mean primary multiplicity =',F8.3/
7865      &5X,'Mean final   multiplicity =',F8.3/
7866      &5X,'Mean charged multiplicity =',F8.3//
7867      &5X,'Number of particles produced per event (directly and via ',
7868      &'decays/branchings)'/
7869      &5X,'KF    Particle/jet  MDCY',8X,'Particles',9X,'Antiparticles',
7870      &5X,'Total'/34X,'prim      seco      prim      seco'/)
7871  1300 FORMAT(1X,I6,4X,A16,I2,5(1X,F9.4))
7872  1400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
7873      &20X,'based on an analysis of ',I6,' events'//
7874      &3X,'delta-',A3,' delta-phi     <n>/bin',10X,'<F2>',18X,'<F3>',
7875      &18X,'<F4>',18X,'<F5>'/35X,4('     value     error  '))
7876  1500 FORMAT(10X)
7877  1600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
7878  1700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
7879      &20X,'based on an analysis of ',I6,' events'//
7880      &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
7881      &'EECA(theta)'/2X,'in degrees ',3('      value    error')/)
7882  1800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
7883  1900 FORMAT(///20X,'Decay channel analysis - final state'/
7884      &20X,'based on an analysis of ',I6,' events'//
7885      &2X,'Probability',10X,'Complete final state'/)
7886  2000 FORMAT(2X,F9.5,5X,8(A12,1X))
7887  2100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
7888      &'or table overflow)')
7889
7890       RETURN
7891       END
7892
7893 C*********************************************************************
7894
7895       SUBROUTINE LUEEVT(KFL,ECM)
7896
7897 C...Purpose: to handle the generation of an e+e- annihilation jet event.
7898       IMPLICIT DOUBLE PRECISION(D)
7899       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7900       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7901       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7902       SAVE
7903
7904 C...Check input parameters.
7905       IF(MSTU(12).GE.1) CALL LULIST(0)
7906       IF(KFL.LT.0.OR.KFL.GT.8) THEN
7907         CALL LUERRM(16,'(LUEEVT:) called with unknown flavour code')
7908         IF(MSTU(21).GE.1) RETURN
7909       ENDIF
7910       IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))
7911       IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)
7912       IF(ECM.LT.ECMMIN) THEN
7913         CALL LUERRM(16,'(LUEEVT:) called with too small CM energy')
7914         IF(MSTU(21).GE.1) RETURN
7915       ENDIF
7916
7917 C...Check consistency of MSTJ options set.
7918       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
7919         CALL LUERRM(6,
7920      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
7921         MSTJ(110)=1
7922       ENDIF
7923       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
7924         CALL LUERRM(6,
7925      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
7926         MSTJ(111)=0
7927       ENDIF
7928
7929 C...Initialize alpha_strong and total cross-section.
7930       MSTU(111)=MSTJ(108)
7931       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
7932      &MSTU(111)=1
7933       PARU(112)=PARJ(121)
7934       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
7935       IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
7936      &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LUXTOT(KFL,ECM,
7937      &XTOT)
7938       IF(MSTJ(116).GE.3) MSTJ(116)=1
7939
7940 C...Add initial e+e- to event record (documentation only).
7941       NTRY=0
7942   100 NTRY=NTRY+1
7943       IF(NTRY.GT.100) THEN
7944         CALL LUERRM(14,'(LUEEVT:) caught in an infinite loop')
7945         RETURN
7946       ENDIF
7947       NC=0
7948       IF(MSTJ(115).GE.2) THEN
7949         NC=NC+2
7950         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
7951         K(NC-1,1)=21
7952         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
7953         K(NC,1)=21
7954       ENDIF
7955
7956 C...Radiative photon (in initial state).
7957       MK=0
7958       ECMC=ECM
7959       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LURADK(ECM,MK,PAK,
7960      &THEK,PHIK,ALPK)
7961       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
7962       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
7963         NC=NC+1
7964         CALL LU1ENT(NC,22,PAK,THEK,PHIK)
7965         K(NC,3)=MIN(MSTJ(115)/2,1)
7966       ENDIF
7967
7968 C...Virtual exchange boson (gamma or Z0).
7969       IF(MSTJ(115).GE.3) THEN
7970         NC=NC+1
7971         KF=22
7972         IF(MSTJ(102).EQ.2) KF=23
7973         MSTU10=MSTU(10)
7974         MSTU(10)=1
7975         P(NC,5)=ECMC
7976         CALL LU1ENT(NC,KF,ECMC,0.,0.)
7977         K(NC,1)=21
7978         K(NC,3)=1
7979         MSTU(10)=MSTU10
7980       ENDIF
7981
7982 C...Choice of flavour and jet configuration.
7983       CALL LUXKFL(KFL,ECM,ECMC,KFLC)
7984       IF(KFLC.EQ.0) GOTO 100
7985       CALL LUXJET(ECMC,NJET,CUT)
7986       KFLN=21
7987       IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
7988      &X12,X14)
7989       IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
7990       IF(NJET.EQ.2) MSTJ(120)=1
7991
7992 C...Fill jet configuration and origin.
7993       IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LU2ENT(NC+1,KFLC,-KFLC,ECMC)
7994       IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LU2ENT(-(NC+1),KFLC,-KFLC,
7995      &ECMC)
7996       IF(NJET.EQ.3) CALL LU3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
7997       IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LU4ENT(NC+1,KFLC,KFLN,KFLN,
7998      &-KFLC,ECMC,X1,X2,X4,X12,X14)
7999       IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LU4ENT(NC+1,KFLC,-KFLN,KFLN,
8000      &-KFLC,ECMC,X1,X2,X4,X12,X14)
8001       DO 110 IP=NC+1,N
8002   110 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
8003
8004 C...Angular orientation according to matrix element.
8005       IF(MSTJ(106).EQ.1) THEN
8006         CALL LUXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
8007         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
8008         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
8009       ENDIF
8010
8011 C...Rotation and boost from radiative photon.
8012       IF(MK.EQ.1) THEN
8013         DBEK=-PAK/(ECM-PAK)
8014         NMIN=NC+1-MSTJ(115)/3
8015         CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)
8016         CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
8017         CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0)
8018       ENDIF
8019
8020 C...Generate parton shower. Rearrange along strings and check.
8021       IF(MSTJ(101).EQ.5) THEN
8022         CALL LUSHOW(N-1,N,ECMC)
8023         MSTJ14=MSTJ(14)
8024         IF(MSTJ(105).EQ.-1) MSTJ(14)=0
8025         IF(MSTJ(105).GE.0) MSTU(28)=0
8026         CALL LUPREP(0)
8027         MSTJ(14)=MSTJ14
8028         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
8029       ENDIF
8030
8031 C...Fragmentation/decay generation. Information for LUTABU.
8032       IF(MSTJ(105).EQ.1) CALL LUEXEC
8033       MSTU(161)=KFLC
8034       MSTU(162)=-KFLC
8035
8036       RETURN
8037       END
8038
8039 C*********************************************************************
8040
8041       SUBROUTINE LUXTOT(KFL,ECM,XTOT)
8042
8043 C...Purpose: to calculate total cross-section, including initial
8044 C...state radiation effects.
8045       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8046       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8047       SAVE
8048
8049 C...Status, (optimized) Q^2 scale, alpha_strong.
8050       PARJ(151)=ECM
8051       MSTJ(119)=10*MSTJ(102)+KFL
8052       IF(MSTJ(111).EQ.0) THEN
8053         Q2R=ECM**2
8054       ELSEIF(MSTU(111).EQ.0) THEN
8055         PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8056      &  ((33.-2.*MSTU(112))*PARU(111)))))
8057         Q2R=PARJ(168)*ECM**2
8058       ELSE
8059         PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8060      &  (2.*PARU(112)/ECM)**2))
8061         Q2R=PARJ(168)*ECM**2
8062       ENDIF
8063       ALSPI=ULALPS(Q2R)/PARU(1)
8064
8065 C...QCD corrections factor in R.
8066       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
8067         RQCD=1.
8068       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
8069         RQCD=1.+ALSPI
8070       ELSEIF(MSTJ(109).EQ.0) THEN
8071         RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8072         IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8073      &  LOG(PARJ(168))*ALSPI**2)
8074       ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
8075         RQCD=1.+(3./4.)*ALSPI
8076       ELSE
8077         RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
8078       ENDIF
8079
8080 C...Calculate Z0 width if default value not acceptable.
8081       IF(MSTJ(102).GE.3) THEN
8082         RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/
8083      &  3.)**2+(4.*PARU(102)/3.-1.)**2)
8084         DO 100 KFLC=5,6
8085         VQ=1.
8086         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*ULMASS(KFLC)/
8087      &  ECM)**2))
8088         IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1.
8089         IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3.
8090   100   RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3)
8091         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
8092       ENDIF
8093
8094 C...Calculate propagator and related constants for QFD case.
8095       POLL=1.-PARJ(131)*PARJ(132)
8096       IF(MSTJ(102).GE.2) THEN
8097         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8098         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8099         SFI=SFW*(1.-(PARJ(123)/ECM)**2)
8100         VE=4.*PARU(102)-1.
8101         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
8102         SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8103         HF1I=SFI*SF1I
8104         HF1W=SFW*SF1W
8105       ENDIF
8106
8107 C...Loop over different flavours: charge, velocity.
8108       RTOT=0.
8109       RQQ=0.
8110       RQV=0.
8111       RVA=0.
8112       DO 110 KFLC=1,MAX(MSTJ(104),KFL)
8113       IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
8114       MSTJ(93)=1
8115       PMQ=ULMASS(KFLC)
8116       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
8117       QF=KCHG(KFLC,1)/3.
8118       VQ=1.
8119       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
8120
8121 C...Calculate R and sum of charges for QED or QFD case.
8122       RQQ=RQQ+3.*QF**2*POLL
8123       IF(MSTJ(102).LE.1) THEN
8124         RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL
8125       ELSE
8126         VF=SIGN(1.,QF)-4.*QF*PARU(102)
8127         RQV=RQV-6.*QF*VF*SF1I
8128         RVA=RVA+3.*(VF**2+1.)*SF1W
8129         RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+
8130      &  VF**2*HF1W)+VQ**3*HF1W)
8131       ENDIF
8132   110 CONTINUE
8133       RSUM=RQQ
8134       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
8135
8136 C...Calculate cross-section, including QCD corrections.
8137       PARJ(141)=RQQ
8138       PARJ(142)=RTOT
8139       PARJ(143)=RTOT*RQCD
8140       PARJ(144)=PARJ(143)
8141       PARJ(145)=PARJ(141)*86.8/ECM**2
8142       PARJ(146)=PARJ(142)*86.8/ECM**2
8143       PARJ(147)=PARJ(143)*86.8/ECM**2
8144       PARJ(148)=PARJ(147)
8145       PARJ(157)=RSUM*RQCD
8146       PARJ(158)=0.
8147       PARJ(159)=0.
8148       XTOT=PARJ(147)
8149       IF(MSTJ(107).LE.0) RETURN
8150
8151 C...Virtual cross-section.
8152       XKL=PARJ(135)
8153       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8154       ALE=2.*LOG(ECM/ULMASS(11))-1.
8155       SIGV=ALE/3.+2.*LOG(ECM**2/(ULMASS(13)*ULMASS(15)))/3.-4./3.+
8156      &1.526*LOG(ECM**2/0.932)
8157
8158 C...Soft and hard radiative cross-section in QED case.
8159       IF(MSTJ(102).LE.1) THEN
8160         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV
8161         SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)
8162         SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL))
8163
8164 C...Soft and hard radiative cross-section in QFD case.
8165       ELSE
8166         SZM=1.-(PARJ(123)/ECM)**2
8167         SZW=PARJ(123)*PARJ(124)/ECM**2
8168         PARJ(161)=-RQQ/RSUM
8169         PARJ(162)=-(RQQ+RQV+RVA)/RSUM
8170         PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM
8171         PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM-
8172      &  SZM**2))/(SZW*RSUM)
8173         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+
8174      &  (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.
8175         SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+
8176      &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
8177      &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
8178         SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+
8179      &  PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/
8180      &  ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-
8181      &  ATAN((XKL-SZM)/SZW)))
8182       ENDIF
8183
8184 C...Total cross-section and fraction of hard photon events.
8185       PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
8186       PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
8187       PARJ(144)=PARJ(157)
8188       PARJ(148)=PARJ(144)*86.8/ECM**2
8189       XTOT=PARJ(148)
8190
8191       RETURN
8192       END
8193
8194 C*********************************************************************
8195
8196       SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK)
8197
8198 C...Purpose: to generate initial state photon radiation.
8199       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8200       SAVE
8201
8202 C...Function: cumulative hard photon spectrum in QFD case.
8203       FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+
8204      &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
8205
8206 C...Determine whether radiative photon or not.
8207       MK=0
8208       PAK=0.
8209       IF(PARJ(160).LT.RLU(0)) RETURN
8210       MK=1
8211
8212 C...Photon energy range. Find photon momentum in QED case.
8213       XKL=PARJ(135)
8214       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8215       IF(MSTJ(102).LE.1) THEN
8216   100   XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLU(0))
8217         IF(1.+(1.-XK)**2.LT.2.*RLU(0)) GOTO 100
8218
8219 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
8220       ELSE
8221         SZM=1.-(PARJ(123)/ECM)**2
8222         SZW=PARJ(123)*PARJ(124)/ECM**2
8223         FXKL=FXK(XKL)
8224         FXKU=FXK(XKU)
8225         FXKD=1E-4*(FXKU-FXKL)
8226         FXKR=FXKL+RLU(0)*(FXKU-FXKL)
8227         NXK=0
8228   110   NXK=NXK+1
8229         XK=0.5*(XKL+XKU)
8230         FXKV=FXK(XK)
8231         IF(FXKV.GT.FXKR) THEN
8232           XKU=XK
8233           FXKU=FXKV
8234         ELSE
8235           XKL=XK
8236           FXKL=FXKV
8237         ENDIF
8238         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
8239         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
8240       ENDIF
8241       PAK=0.5*ECM*XK
8242
8243 C...Photon polar and azimuthal angle.
8244       PME=2.*(ULMASS(11)/ECM)**2
8245   120 CTHM=PME*(2./PME)**RLU(0)
8246       IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,
8247      &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLU(0)) GOTO 120
8248       CTHE=1.-CTHM
8249       IF(RLU(0).GT.0.5) CTHE=-CTHE
8250       STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
8251       THEK=ULANGL(CTHE,STHE)
8252       PHIK=PARU(2)*RLU(0)
8253
8254 C...Rotation angle for hadronic system.
8255       SGN=1.
8256       IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
8257      &RLU(0)) SGN=-1.
8258       ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
8259      &(2.-XK*(1.-SGN*CTHE)))
8260
8261       RETURN
8262       END
8263
8264 C*********************************************************************
8265
8266       SUBROUTINE LUXKFL(KFL,ECM,ECMC,KFLC)
8267
8268 C...Purpose: to select flavour for produced qqbar pair.
8269       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8270       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8271       SAVE
8272
8273 C...Calculate maximum weight in QED or QFD case.
8274       IF(MSTJ(102).LE.1) THEN
8275         RFMAX=4./9.
8276       ELSE
8277         POLL=1.-PARJ(131)*PARJ(132)
8278         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8279         SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8280         SFI=SFW*(1.-(PARJ(123)/ECMC)**2)
8281         VE=4.*PARU(102)-1.
8282         HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
8283         HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8284         RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+
8285      &  ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.*
8286      &  (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)
8287       ENDIF
8288
8289 C...Choose flavour. Gives charge and velocity.
8290       NTRY=0
8291   100 NTRY=NTRY+1
8292       IF(NTRY.GT.100) THEN
8293         CALL LUERRM(14,'(LUXKFL:) caught in an infinite loop')
8294         KFLC=0
8295         RETURN
8296       ENDIF
8297       KFLC=KFL
8298       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLU(0))
8299       MSTJ(93)=1
8300       PMQ=ULMASS(KFLC)
8301       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
8302       QF=KCHG(KFLC,1)/3.
8303       VQ=1.
8304       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
8305
8306 C...Calculate weight in QED or QFD case.
8307       IF(MSTJ(102).LE.1) THEN
8308         RF=QF**2
8309         RFV=0.5*VQ*(3.-VQ**2)*QF**2
8310       ELSE
8311         VF=SIGN(1.,QF)-4.*QF*PARU(102)
8312         RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W
8313         RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+
8314      &  VQ**3*HF1W
8315       ENDIF
8316
8317 C...Weighting or new event (radiative photon). Cross-section update.
8318       IF(KFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100
8319       PARJ(158)=PARJ(158)+1.
8320       IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLU(0)*RF) KFLC=0
8321       IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
8322       IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.
8323       PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
8324       PARJ(148)=PARJ(144)*86.8/ECM**2
8325
8326       RETURN
8327       END
8328
8329 C*********************************************************************
8330
8331       SUBROUTINE LUXJET(ECM,NJET,CUT)
8332
8333 C...Purpose: to select number of jets in matrix element approach.
8334       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8335       DIMENSION ZHUT(5)
8336       SAVE
8337
8338 C...Relative three-jet rate in Zhu second order parametrization.
8339       DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
8340
8341 C...Trivial result for two-jets only, including parton shower.
8342       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
8343         CUT=0.
8344
8345 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
8346       ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
8347         CF=4./3.
8348         IF(MSTJ(109).EQ.2) CF=1.
8349         IF(MSTJ(111).EQ.0) THEN
8350           Q2=ECM**2
8351           Q2R=ECM**2
8352         ELSEIF(MSTU(111).EQ.0) THEN
8353           PARJ(169)=MIN(1.,PARJ(129))
8354           Q2=PARJ(169)*ECM**2
8355           PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8356      &    ((33.-2.*MSTU(112))*PARU(111)))))
8357           Q2R=PARJ(168)*ECM**2
8358         ELSE
8359           PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))
8360           Q2=PARJ(169)*ECM**2
8361           PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8362      &    (2.*PARU(112)/ECM)**2))
8363           Q2R=PARJ(168)*ECM**2
8364         ENDIF
8365
8366 C...alpha_strong for R and R itself.
8367         ALSPI=(3./4.)*CF*ULALPS(Q2R)/PARU(1)
8368         IF(IABS(MSTJ(101)).EQ.1) THEN
8369           RQCD=1.+ALSPI
8370         ELSEIF(MSTJ(109).EQ.0) THEN
8371           RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8372           IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8373      &    LOG(PARJ(168))*ALSPI**2)
8374         ELSE
8375           RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
8376         ENDIF
8377
8378 C...alpha_strong for jet rate. Initial value for y cut.
8379         ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8380         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2)
8381         IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
8382      &  CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)
8383         IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8384
8385 C...Parametrization of first order three-jet cross-section.
8386   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
8387           PARJ(152)=0.
8388         ELSE
8389           PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))*
8390      &    LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+
8391      &    5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+
8392      &    1.342*(1.-3.*CUT)**4)/RQCD
8393           IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
8394      &    PARJ(152)=0.
8395         ENDIF
8396
8397 C...Parametrization of second order three-jet cross-section.
8398         IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
8399      &  CUT.GE.0.25) THEN
8400           PARJ(153)=0.
8401         ELSEIF(MSTJ(110).LE.1) THEN
8402           CT=LOG(1./CUT-2.)
8403           PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-
8404      &    0.2661*CT**3+0.01159*CT**4)/RQCD
8405
8406 C...Interpolation in second/first order ratio for Zhu parametrization.
8407         ELSEIF(MSTJ(110).EQ.2) THEN
8408           IZA=0
8409           DO 110 IY=1,5
8410   110     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
8411           IF(IZA.NE.0) THEN
8412             ZHURAT=ZHUT(IZA)
8413           ELSE
8414             IZ=100.*CUT
8415             ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
8416           ENDIF
8417           PARJ(153)=ALSPI*PARJ(152)*ZHURAT
8418         ENDIF
8419
8420 C...Shift in second order three-jet cross-section with optimized Q^2.
8421         IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.
8422      &  AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*
8423      &  LOG(PARJ(169))*ALSPI*PARJ(152)
8424
8425 C...Parametrization of second order four-jet cross-section.
8426         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
8427           PARJ(154)=0.
8428         ELSE
8429           CT=LOG(1./CUT-5.)
8430           IF(CUT.LE.0.018) THEN
8431             XQQGG=6.349-4.330*CT+0.8304*CT**2
8432             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+
8433      &      0.4059*CT**2)
8434             XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
8435             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8436           ELSE
8437             XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3
8438             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-
8439      &      0.1326*CT**2+0.04365*CT**3)
8440             XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*
8441      &      CT**3)
8442             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8443           ENDIF
8444           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
8445           PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
8446         ENDIF
8447
8448 C...If negative three-jet rate, change y' optimization parameter.
8449         IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.
8450      &  PARJ(169).LT.0.99) THEN
8451           PARJ(169)=MIN(1.,1.2*PARJ(169))
8452           Q2=PARJ(169)*ECM**2
8453           ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8454           GOTO 100
8455         ENDIF
8456
8457 C...If too high cross-section, use harder cuts, or fail.
8458         IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
8459           IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.
8460      &    PARJ(169).LT.0.99) THEN
8461             PARJ(169)=MIN(1.,1.2*PARJ(169))
8462             Q2=PARJ(169)*ECM**2
8463             ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8464             GOTO 100
8465           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
8466             CALL LUERRM(26,
8467      &      '(LUXJET:) no allowed y cut value for Zhu parametrization')
8468           ENDIF
8469           CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)
8470           IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8471           GOTO 100
8472         ENDIF
8473
8474 C...Scalar gluon (first order only).
8475       ELSE
8476         ALSPI=ULALPS(ECM**2)/PARU(1)
8477         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
8478         PARJ(152)=0.
8479         IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*
8480      &  LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))
8481         PARJ(153)=0.
8482         PARJ(154)=0.
8483       ENDIF
8484
8485 C...Select number of jets.
8486       PARJ(150)=CUT
8487       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
8488         NJET=2
8489       ELSEIF(MSTJ(101).LE.0) THEN
8490         NJET=MIN(4,2-MSTJ(101))
8491       ELSE
8492         RNJ=RLU(0)
8493         NJET=2
8494         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
8495         IF(PARJ(154).GT.RNJ) NJET=4
8496       ENDIF
8497
8498       RETURN
8499       END
8500
8501 C*********************************************************************
8502
8503       SUBROUTINE LUX3JT(NJET,CUT,KFL,ECM,X1,X2)
8504
8505 C...Purpose: to select the kinematical variables of three-jet events.
8506       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8507       DIMENSION ZHUP(5,12)
8508       SAVE
8509
8510 C...Coefficients of Zhu second order parametrization.
8511       DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
8512      &    18.29,    89.56,    4.541,   -52.09,   -109.8,    24.90,
8513      &    11.63,    3.683,    17.50, 0.002440,   -1.362,  -0.3537,
8514      &    11.42,    6.299,   -22.55,   -8.915,    59.25,   -5.855,
8515      &   -32.85,   -1.054,   -16.90, 0.006489,  -0.8156,  0.01095,
8516      &    7.847,   -3.964,   -35.83,    1.178,    29.39,   0.2806,
8517      &    47.82,   -12.36,   -56.72,  0.04054,  -0.4365,   0.6062,
8518      &    5.441,   -56.89,   -50.27,    15.13,    114.3,   -18.19,
8519      &    97.05,   -1.890,   -139.9,  0.08153,  -0.4984,   0.9439,
8520      &   -17.65,    51.44,   -58.32,    70.95,   -255.7,   -78.99,
8521      &    476.9,    29.65,   -239.3,   0.4745,   -1.174,    6.081/
8522
8523 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
8524       DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.
8525
8526 C...Event type. Mass effect factors and other common constants.
8527       MSTJ(120)=2
8528       MSTJ(121)=0
8529       PMQ=ULMASS(KFL)
8530       QME=(2.*PMQ/ECM)**2
8531       IF(MSTJ(109).NE.1) THEN
8532         CUTL=LOG(CUT)
8533         CUTD=LOG(1./CUT-2.)
8534         IF(MSTJ(109).EQ.0) THEN
8535           CF=4./3.
8536           CN=3.
8537           TR=2.
8538           WTMX=MIN(20.,37.-6.*CUTD)
8539           IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
8540         ELSE
8541           CF=1.
8542           CN=0.
8543           TR=12.
8544           WTMX=0.
8545         ENDIF
8546
8547 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
8548         ALS2PI=PARU(118)/PARU(2)
8549         WTOPT=0.
8550         IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
8551      &  ALS2PI
8552         WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
8553
8554 C...Choose three-jet events in allowed region.
8555   100   NJET=3
8556   110   Y13L=CUTL+CUTD*RLU(0)
8557         Y23L=CUTL+CUTD*RLU(0)
8558         Y13=EXP(Y13L)
8559         Y23=EXP(Y23L)
8560         Y12=1.-Y13-Y23
8561         IF(Y12.LE.CUT) GOTO 110
8562         IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLU(0)) GOTO 110
8563
8564 C...Second order corrections.
8565         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
8566           Y12L=LOG(Y12)
8567           Y13M=LOG(1.-Y13)
8568           Y23M=LOG(1.-Y23)
8569           Y12M=LOG(1.-Y12)
8570           IF(Y13.LE.0.5) Y13I=DILOG(Y13)
8571           IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)
8572           IF(Y23.LE.0.5) Y23I=DILOG(Y23)
8573           IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)
8574           IF(Y12.LE.0.5) Y12I=DILOG(Y12)
8575           IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)
8576           WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)
8577           WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+
8578      &    2.*(2.*CUTL-Y12L)*CUT/Y12)+
8579      &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+
8580      &    67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*
8581      &    CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+
8582      &    TR*(2.*CUTL/3.-10./9.)+
8583      &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
8584      &    Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+
8585      &    Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/
8586      &    WT1+
8587      &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+
8588      &    (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
8589      &    Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
8590      &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/
8591      &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
8592      &    2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-
8593      &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I)
8594           IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1
8595           IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
8596           PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)
8597
8598         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
8599 C...Second order corrections; Zhu parametrization of ERT.
8600           ZX=(Y23-Y13)**2
8601           ZY=1.-Y12
8602           IZA=0
8603           DO 120 IY=1,5
8604   120     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
8605           IF(IZA.NE.0) THEN
8606             IZ=IZA
8607             WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
8608      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
8609      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
8610      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
8611           ELSE
8612             IZ=100.*CUT
8613             WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
8614      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
8615      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
8616      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
8617             IZ=IZ+1
8618             WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
8619      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
8620      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
8621      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
8622             WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)
8623           ENDIF
8624           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1
8625           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
8626           PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)
8627         ENDIF
8628
8629 C...Impose mass cuts (gives two jets). For fixed jet number new try.
8630         X1=1.-Y23
8631         X2=1.-Y13
8632         X3=1.-Y12
8633         IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
8634         IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
8635      &  0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+
8636      &  (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLU(0)) NJET=2
8637         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
8638
8639 C...Scalar gluon model (first order only, no mass effects).
8640       ELSE
8641   130   NJET=3
8642   140   Y12=SQRT(4.*CUT**2+RLU(0)*((1.-CUT)**2-4.*CUT**2))
8643         IF(LOG((Y12-CUT)/CUT).LE.RLU(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140
8644         YD=SIGN(2.*CUT*((Y12-CUT)/CUT)**RLU(0)-Y12,RLU(0)-0.5)
8645         X1=1.-0.5*(Y12+YD)
8646         X2=1.-0.5*(Y12-YD)
8647         IF(4.*(1.-X1)*(1.-X2)*Y12/(1.-Y12)**2.LE.QME) NJET=2
8648         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
8649       ENDIF
8650
8651       RETURN
8652       END
8653
8654 C*********************************************************************
8655
8656       SUBROUTINE LUX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
8657
8658 C...Purpose: to select the kinematical variables of four-jet events.
8659       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8660       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
8661       SAVE
8662
8663 C...Common constants. Colour factors for QCD and Abelian gluon theory.
8664       PMQ=ULMASS(KFL)
8665       QME=(2.*PMQ/ECM)**2
8666       CT=LOG(1./CUT-5.)
8667       IF(MSTJ(109).EQ.0) THEN
8668         CF=4./3.
8669         CN=3.
8670         TR=2.
8671       ELSE
8672         CF=1.
8673         CN=0.
8674         TR=12.
8675       ENDIF
8676
8677 C...Choice of process (qqbargg or qqbarqqbar).
8678   100 NJET=4
8679       IT=1
8680       IF(PARJ(155).GT.RLU(0)) IT=2
8681       IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
8682       IF(IT.EQ.1) WTMX=0.7/CUT**2
8683       IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2
8684       IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2
8685       ID=1
8686
8687 C...Sample the five kinematical variables (for qqgg preweighted in y34).
8688   110 Y134=3.*CUT+(1.-6.*CUT)*RLU(0)
8689       Y234=3.*CUT+(1.-6.*CUT)*RLU(0)
8690       IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLU(0))
8691       IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLU(0)
8692       IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110
8693       VT=RLU(0)
8694       CP=COS(PARU(1)*RLU(0))
8695       Y14=(Y134-Y34)*VT
8696       Y13=Y134-Y14-Y34
8697       VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
8698       Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*
8699      &CP-(1.-2.*VT)*(1.-2.*VB))
8700       Y23=Y234-Y34-Y24
8701       Y12=1.-Y134-Y23-Y24
8702       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
8703       Y123=Y12+Y13+Y23
8704       Y124=Y12+Y14+Y24
8705
8706 C...Calculate matrix elements for qqgg or qqqq process.
8707       IC=0
8708       WTTOT=0.
8709   120 IC=IC+1
8710       IF(IT.EQ.1) THEN
8711         WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+
8712      &  3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-
8713      &  Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12*
8714      &  Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+
8715      &  2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*
8716      &  Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*
8717      &  Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)
8718         WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12*
8719      &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*
8720      &  Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+
8721      &  Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)
8722         WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*
8723      &  Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+
8724      &  Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-
8725      &  Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/
8726      &  (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24*
8727      &  Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*
8728      &  Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*
8729      &  Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+
8730      &  2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-
8731      &  2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)
8732         WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+
8733      &  4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34-
8734      &  Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+
8735      &  4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+
8736      &  2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*
8737      &  Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)-
8738      &  (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*
8739      &  Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-
8740      &  4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/
8741      &  (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34-
8742      &  2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-
8743      &  2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-
8744      &  Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)
8745         WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/
8746      &  8.
8747       ELSE
8748         WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12*
8749      &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
8750      &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
8751      &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
8752      &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
8753      &  Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
8754      &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
8755      &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
8756      &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
8757         WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
8758      &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
8759      &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
8760      &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
8761      &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
8762      &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
8763      &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
8764      &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
8765         WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16.
8766       ENDIF
8767
8768 C...Permutations of momenta in matrix element. Weighting.
8769   130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
8770         YSAV=Y13
8771         Y13=Y14
8772         Y14=YSAV
8773         YSAV=Y23
8774         Y23=Y24
8775         Y24=YSAV
8776         YSAV=Y123
8777         Y123=Y124
8778         Y124=YSAV
8779       ENDIF
8780       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
8781         YSAV=Y13
8782         Y13=Y23
8783         Y23=YSAV
8784         YSAV=Y14
8785         Y14=Y24
8786         Y24=YSAV
8787         YSAV=Y134
8788         Y134=Y234
8789         Y234=YSAV
8790       ENDIF
8791       IF(IC.LE.3) GOTO 120
8792       IF(ID.EQ.1.AND.WTTOT.LT.RLU(0)*WTMX) GOTO 110
8793       IC=5
8794
8795 C...qqgg events: string configuration and event type.
8796       IF(IT.EQ.1) THEN
8797         IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
8798           PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+
8799      &    WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT)
8800           IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLU(0)*(WTA(1)+WTA(2)+
8801      &    WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
8802           IF(ID.EQ.2) GOTO 130
8803         ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
8804           PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)
8805           IF(WTA(2)+WTA(4).GT.RLU(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
8806           IF(ID.EQ.2) GOTO 130
8807         ENDIF
8808         MSTJ(120)=3
8809         IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.
8810      &  RLU(0)*WTTOT) MSTJ(120)=4
8811         KFLN=21
8812
8813 C...Mass cuts. Kinematical variables out.
8814         IF(Y12.LE.CUT+QME) NJET=2
8815         IF(NJET.EQ.2) GOTO 150
8816         Q12=0.5*(1.-SQRT(1.-QME/Y12))
8817         X1=1.-(1.-Q12)*Y234-Q12*Y134
8818         X4=1.-(1.-Q12)*Y134-Q12*Y234
8819         X2=1.-Y124
8820         X12=(1.-Q12)*Y13+Q12*Y23
8821         X14=Y12-0.5*QME
8822         IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
8823
8824 C...qqbarqqbar events: string configuration, choose new flavour.
8825       ELSE
8826         IF(ID.EQ.1) THEN
8827           WTR=RLU(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
8828           IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
8829           IF(WTR.LT.WTD(3)+WTD(4)) ID=3
8830           IF(WTR.LT.WTD(4)) ID=4
8831           IF(ID.GE.2) GOTO 130
8832         ENDIF
8833         MSTJ(120)=5
8834         PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)
8835   140   KFLN=1+INT(5.*RLU(0))
8836         IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLU(0)) GOTO 140
8837         IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLU(0)) GOTO 140
8838         IF(KFLN.GT.MSTJ(104)) NJET=2
8839         PMQN=ULMASS(KFLN)
8840         QMEN=(2.*PMQN/ECM)**2
8841
8842 C...Mass cuts. Kinematical variables out.
8843         IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2
8844         IF(NJET.EQ.2) GOTO 150
8845         Q24=0.5*(1.-SQRT(1.-QME/Y24))
8846         Q13=0.5*(1.-SQRT(1.-QMEN/Y13))
8847         X1=1.-(1.-Q24)*Y123-Q24*Y134
8848         X4=1.-(1.-Q24)*Y134-Q24*Y123
8849         X2=1.-(1.-Q13)*Y234-Q13*Y124
8850         X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)
8851         X14=Y24-0.5*QME
8852         X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)
8853         IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
8854      &  (PARJ(127)+PMQ+PMQN)**2) NJET=2
8855         IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
8856       ENDIF
8857   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
8858
8859       RETURN
8860       END
8861
8862 C*********************************************************************
8863
8864       SUBROUTINE LUXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
8865
8866 C...Purpose: to give the angular orientation of events.
8867       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
8868       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8869       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8870       SAVE
8871
8872 C...Charge. Factors depending on polarization for QED case.
8873       QF=KCHG(KFL,1)/3.
8874       POLL=1.-PARJ(131)*PARJ(132)
8875       POLD=PARJ(132)-PARJ(131)
8876       IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
8877         HF1=POLL
8878         HF2=0.
8879         HF3=PARJ(133)**2
8880         HF4=0.
8881
8882 C...Factors depending on flavour, energy and polarization for QFD case.
8883       ELSE
8884         SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8885         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8886         SFI=SFW*(1.-(PARJ(123)/ECM)**2)
8887         AE=-1.
8888         VE=4.*PARU(102)-1.
8889         AF=SIGN(1.,QF)
8890         VF=AF-4.*QF*PARU(102)
8891         HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
8892      &  (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD)
8893         HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*
8894      &  (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)
8895         HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
8896      &  SFW*SFF**2*(VE**2-AE**2))
8897         HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
8898      &  SFF*AE
8899       ENDIF
8900
8901 C...Mass factor. Differential cross-sections for two-jet events.
8902       SQ2=SQRT(2.)
8903       QME=0.
8904       IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
8905      &MSTJ(109).NE.1) QME=(2.*ULMASS(KFL)/ECM)**2
8906       IF(NJET.EQ.2) THEN
8907         SIGU=4.*SQRT(1.-QME)
8908         SIGL=2.*QME*SQRT(1.-QME)
8909         SIGT=0.
8910         SIGI=0.
8911         SIGA=0.
8912         SIGP=4.
8913
8914 C...Kinematical variables. Reduce four-jet event to three-jet one.
8915       ELSE
8916         IF(NJET.EQ.3) THEN
8917           X1=2.*P(NC+1,4)/ECM
8918           X2=2.*P(NC+3,4)/ECM
8919         ELSE
8920           ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
8921      &    (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
8922           X1=2.*P(NC+1,4)/ECMR
8923           X2=2.*P(NC+4,4)/ECMR
8924         ENDIF
8925
8926 C...Differential cross-sections for three-jet (or reduced four-jet).
8927         XQ=(1.-X1)/(1.-X2)
8928         CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))
8929         ST12=SQRT(1.-CT12**2)
8930         IF(MSTJ(109).NE.1) THEN
8931           SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-
8932      &    QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ
8933           SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+
8934      &    0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ
8935           SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2
8936           SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+
8937      &    0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2
8938           SIGA=X2**2*ST12/SQ2
8939           SIGP=2.*(X1**2-X2**2*CT12)
8940
8941 C...Differential cross-sect for scalar gluons (no mass or QFD effects).
8942         ELSE
8943           SIGU=2.*(2.-X1-X2)**2-(X2*ST12)**2
8944           SIGL=(X2*ST12)**2
8945           SIGT=0.5*SIGL
8946           SIGI=-(2.-X1-X2)*X2*ST12/SQ2
8947           SIGA=0.
8948           SIGP=0.
8949         ENDIF
8950       ENDIF
8951
8952 C...Upper bounds for differential cross-section.
8953       HF1A=ABS(HF1)
8954       HF2A=ABS(HF2)
8955       HF3A=ABS(HF3)
8956       HF4A=ABS(HF4)
8957       SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)*
8958      &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2*
8959      &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+
8960      &2.*HF2A*ABS(SIGP)
8961
8962 C...Generate angular orientation according to differential cross-sect.
8963   100 CHI=PARU(2)*RLU(0)
8964       CTHE=2.*RLU(0)-1.
8965       PHI=PARU(2)*RLU(0)
8966       CCHI=COS(CHI)
8967       SCHI=SIN(CHI)
8968       C2CHI=COS(2.*CHI)
8969       S2CHI=SIN(2.*CHI)
8970       THE=ACOS(CTHE)
8971       STHE=SIN(THE)
8972       C2PHI=COS(2.*(PHI-PARJ(134)))
8973       S2PHI=SIN(2.*(PHI-PARJ(134)))
8974       SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
8975      &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
8976      &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*
8977      &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*
8978      &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-
8979      &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
8980      &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP
8981       IF(SIG.LT.SIGMAX*RLU(0)) GOTO 100
8982
8983       RETURN
8984       END
8985
8986 C*********************************************************************
8987
8988       SUBROUTINE LUONIA(KFL,ECM)
8989
8990 C...Purpose: to generate Upsilon and toponium decays into three
8991 C...gluons or two gluons and a photon.
8992       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
8993       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8994       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8995       SAVE
8996
8997 C...Printout. Check input parameters.
8998       IF(MSTU(12).GE.1) CALL LULIST(0)
8999       IF(KFL.LT.0.OR.KFL.GT.8) THEN
9000         CALL LUERRM(16,'(LUONIA:) called with unknown flavour code')
9001         IF(MSTU(21).GE.1) RETURN
9002       ENDIF
9003       IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN
9004         CALL LUERRM(16,'(LUONIA:) called with too small CM energy')
9005         IF(MSTU(21).GE.1) RETURN
9006       ENDIF
9007
9008 C...Initial e+e- and onium state (optional).
9009       NC=0
9010       IF(MSTJ(115).GE.2) THEN
9011         NC=NC+2
9012         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
9013         K(NC-1,1)=21
9014         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9015         K(NC,1)=21
9016       ENDIF
9017       KFLC=IABS(KFL)
9018       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
9019         NC=NC+1
9020         KF=110*KFLC+3
9021         MSTU10=MSTU(10)
9022         MSTU(10)=1
9023         P(NC,5)=ECM
9024         CALL LU1ENT(NC,KF,ECM,0.,0.)
9025         K(NC,1)=21
9026         K(NC,3)=1
9027         MSTU(10)=MSTU10
9028       ENDIF
9029
9030 C...Choose x1 and x2 according to matrix element.
9031       NTRY=0
9032   100 X1=RLU(0)
9033       X2=RLU(0)
9034       X3=2.-X1-X2
9035       IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+
9036      &((1.-X3)/(X1*X2))**2.LE.2.*RLU(0)) GOTO 100
9037       NTRY=NTRY+1
9038       NJET=3
9039       IF(MSTJ(101).LE.4) CALL LU3ENT(NC+1,21,21,21,ECM,X1,X3)
9040       IF(MSTJ(101).GE.5) CALL LU3ENT(-(NC+1),21,21,21,ECM,X1,X3)
9041
9042 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
9043       MSTU(111)=MSTJ(108)
9044       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9045      &MSTU(111)=1
9046       PARU(112)=PARJ(121)
9047       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9048       QF=0.
9049       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
9050       RGAM=7.2*QF**2*PARU(101)/ULALPS(ECM**2)
9051       MK=0
9052       ECMC=ECM
9053       IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN
9054         IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
9055      &  NJET=2
9056         IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LU2ENT(NC+1,21,21,ECM)
9057         IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LU2ENT(-(NC+1),21,21,ECM)
9058       ELSE
9059         MK=1
9060         ECMC=SQRT(1.-X1)*ECM
9061         IF(ECMC.LT.2.*PARJ(127)) GOTO 100
9062         K(NC+1,1)=1
9063         K(NC+1,2)=22
9064         K(NC+1,4)=0
9065         K(NC+1,5)=0
9066         IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
9067         IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
9068         IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
9069         IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
9070         NJET=2
9071         IF(ECMC.LT.4.*PARJ(127)) THEN
9072           MSTU10=MSTU(10)
9073           MSTU(10)=1
9074           P(NC+2,5)=ECMC
9075           CALL LU1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
9076           MSTU(10)=MSTU10
9077           NJET=0
9078         ENDIF
9079       ENDIF
9080       DO 110 IP=NC+1,N
9081   110 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
9082
9083 C...Differential cross-sections. Upper limit for cross-section.
9084       IF(MSTJ(106).EQ.1) THEN
9085         SQ2=SQRT(2.)
9086         HF1=1.-PARJ(131)*PARJ(132)
9087         HF3=PARJ(133)**2
9088         CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3)
9089         ST13=SQRT(1.-CT13**2)
9090         SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2
9091         SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL
9092         SIGT=0.5*SIGL
9093         SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2
9094         SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+
9095      &  2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI)
9096
9097 C...Angular orientation of event.
9098   120   CHI=PARU(2)*RLU(0)
9099         CTHE=2.*RLU(0)-1.
9100         PHI=PARU(2)*RLU(0)
9101         CCHI=COS(CHI)
9102         SCHI=SIN(CHI)
9103         C2CHI=COS(2.*CHI)
9104         S2CHI=SIN(2.*CHI)
9105         THE=ACOS(CTHE)
9106         STHE=SIN(THE)
9107         C2PHI=COS(2.*(PHI-PARJ(134)))
9108         S2PHI=SIN(2.*(PHI-PARJ(134)))
9109         SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-
9110      &  STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*
9111      &  C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*
9112      &  CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
9113         IF(SIG.LT.SIGMAX*RLU(0)) GOTO 120
9114         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
9115         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
9116       ENDIF
9117
9118 C...Generate parton shower. Rearrange along strings and check.
9119       IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
9120         CALL LUSHOW(NC+MK+1,-NJET,ECMC)
9121         MSTJ14=MSTJ(14)
9122         IF(MSTJ(105).EQ.-1) MSTJ(14)=0
9123         IF(MSTJ(105).GE.0) MSTU(28)=0
9124         CALL LUPREP(0)
9125         MSTJ(14)=MSTJ14
9126         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9127       ENDIF
9128
9129 C...Generate fragmentation. Information for LUTABU:
9130       IF(MSTJ(105).EQ.1) CALL LUEXEC
9131       MSTU(161)=110*KFLC+3
9132       MSTU(162)=0
9133
9134       RETURN
9135       END
9136
9137 C*********************************************************************
9138
9139       SUBROUTINE LUHEPC(MCONV)
9140
9141 C...Purpose: to convert JETSET event record contents to or from
9142 C...the standard event record commonblock.
9143       PARAMETER (NMXHEP=9000)
9144       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
9145      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
9146       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9147       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9148       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9149       SAVE
9150
9151 C...Conversion from JETSET to standard, the easy part.
9152       IF(MCONV.EQ.1) THEN
9153         NEVHEP=0
9154         IF(N.GT.NMXHEP) CALL LUERRM(8,
9155      &  '(LUHEPC:) no more space in /HEPEVT/')
9156         NHEP=MIN(N,NMXHEP)
9157         DO 140 I=1,NHEP
9158         ISTHEP(I)=0
9159         IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
9160         IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
9161         IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
9162         IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
9163         IDHEP(I)=K(I,2)
9164         JMOHEP(1,I)=K(I,3)
9165         JMOHEP(2,I)=0
9166         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
9167           JDAHEP(1,I)=K(I,4)
9168           JDAHEP(2,I)=K(I,5)
9169         ELSE
9170           JDAHEP(1,I)=0
9171           JDAHEP(2,I)=0
9172         ENDIF
9173         DO 100 J=1,5
9174   100   PHEP(J,I)=P(I,J)
9175         DO 110 J=1,4
9176   110   VHEP(J,I)=V(I,J)
9177
9178 C...Fill in missing mother information.
9179         IF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
9180           I1=K(I,3)-1
9181   120     I1=I1+1
9182           IF(I1.GE.I) CALL LUERRM(8,
9183      &    '(LUHEPC:) translation of inconsistent event history')
9184           IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
9185           KC=LUCOMP(K(I1,2))
9186           IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
9187           IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
9188           JMOHEP(2,I)=I1
9189         ELSEIF(K(I,2).EQ.94) THEN
9190           NJET=2
9191           IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
9192           IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
9193           JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
9194           IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
9195      &    MOD(K(I+1,4)/MSTU(5),MSTU(5))
9196         ENDIF
9197
9198 C...Fill in missing daughter information.
9199         IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
9200           DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
9201           I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
9202   130     JDAHEP(1,I2)=I
9203         ENDIF
9204         IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
9205         I1=JMOHEP(1,I)
9206         IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
9207         IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
9208         IF(JDAHEP(1,I1).EQ.0) THEN
9209           JDAHEP(1,I1)=I
9210         ELSE
9211           JDAHEP(2,I1)=I
9212         ENDIF
9213   140   CONTINUE
9214         DO 150 I=1,NHEP
9215         IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
9216         IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
9217   150   CONTINUE
9218
9219 C...Conversion from standard to JETSET, the easy part.
9220       ELSE
9221         IF(NHEP.GT.MSTU(4)) CALL LUERRM(8,
9222      &  '(LUHEPC:) no more space in /LUJETS/')
9223         N=MIN(NHEP,MSTU(4))
9224         NKQ=0
9225         KQSUM=0
9226         DO 180 I=1,N
9227         K(I,1)=0
9228         IF(ISTHEP(I).EQ.1) K(I,1)=1
9229         IF(ISTHEP(I).EQ.2) K(I,1)=11
9230         IF(ISTHEP(I).EQ.3) K(I,1)=21
9231         K(I,2)=IDHEP(I)
9232         K(I,3)=JMOHEP(1,I)
9233         K(I,4)=JDAHEP(1,I)
9234         K(I,5)=JDAHEP(2,I)
9235         DO 160 J=1,5
9236   160   P(I,J)=PHEP(J,I)
9237         DO 170 J=1,4
9238   170   V(I,J)=VHEP(J,I)
9239         V(I,5)=0.
9240         IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
9241           I1=JDAHEP(1,I)
9242           IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
9243      &    PHEP(5,I)/PHEP(4,I)
9244         ENDIF
9245
9246 C...Fill in missing information on colour connection in jet systems.
9247         IF(ISTHEP(I).EQ.1) THEN
9248           KC=LUCOMP(K(I,2))
9249           KQ=0
9250           IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
9251           IF(KQ.NE.0) NKQ=NKQ+1
9252           IF(KQ.NE.2) KQSUM=KQSUM+KQ
9253           IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
9254             K(I,1)=2
9255           ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
9256             IF(K(I+1,2).EQ.21) K(I,1)=2
9257           ENDIF
9258         ENDIF
9259   180   CONTINUE
9260         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LUERRM(8,
9261      &  '(LUHEPC:) input parton configuration not colour singlet')
9262       ENDIF
9263
9264       END
9265
9266 C*********************************************************************
9267
9268       SUBROUTINE LUTEST(MTEST)
9269
9270 C...Purpose: to provide a simple program (disguised as subroutine) to
9271 C...run at installation as a check that the program works as intended.
9272       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9273       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9274       DIMENSION PSUM(5),PINI(6),PFIN(6)
9275       SAVE
9276
9277 C...Loop over events to be generated.
9278       IF(MTEST.GE.1) CALL LUTABU(20)
9279       NERR=0
9280       DO 170 IEV=1,600
9281
9282 C...Reset parameter values. Switch on some nonstandard features.
9283       MSTJ(1)=1
9284       MSTJ(3)=0
9285       MSTJ(11)=1
9286       MSTJ(42)=2
9287       MSTJ(43)=4
9288       MSTJ(44)=2
9289       PARJ(17)=0.1
9290       PARJ(22)=1.5
9291       PARJ(43)=1.
9292       PARJ(54)=-0.05
9293       MSTJ(101)=5
9294       MSTJ(104)=5
9295       MSTJ(105)=0
9296       MSTJ(107)=1
9297       IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
9298
9299 C...Ten events each for some single jets configurations.
9300       IF(IEV.LE.50) THEN
9301         ITY=(IEV+9)/10
9302         MSTJ(3)=-1
9303         IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
9304         IF(ITY.EQ.1) CALL LU1ENT(1,1,15.,0.,0.)
9305         IF(ITY.EQ.2) CALL LU1ENT(1,3101,15.,0.,0.)
9306         IF(ITY.EQ.3) CALL LU1ENT(1,-2203,15.,0.,0.)
9307         IF(ITY.EQ.4) CALL LU1ENT(1,-4,30.,0.,0.)
9308         IF(ITY.EQ.5) CALL LU1ENT(1,21,15.,0.,0.)
9309
9310 C...Ten events each for some simple jet systems; string fragmentation.
9311       ELSEIF(IEV.LE.130) THEN
9312         ITY=(IEV-41)/10
9313         IF(ITY.EQ.1) CALL LU2ENT(1,1,-1,40.)
9314         IF(ITY.EQ.2) CALL LU2ENT(1,4,-4,30.)
9315         IF(ITY.EQ.3) CALL LU2ENT(1,2,2103,100.)
9316         IF(ITY.EQ.4) CALL LU2ENT(1,21,21,40.)
9317         IF(ITY.EQ.5) CALL LU3ENT(1,2101,21,-3203,30.,0.6,0.8)
9318         IF(ITY.EQ.6) CALL LU3ENT(1,5,21,-5,40.,0.9,0.8)
9319         IF(ITY.EQ.7) CALL LU3ENT(1,21,21,21,60.,0.7,0.5)
9320         IF(ITY.EQ.8) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9321
9322 C...Seventy events with independent fragmentation and momentum cons.
9323       ELSEIF(IEV.LE.200) THEN
9324         ITY=1+(IEV-131)/16
9325         MSTJ(2)=1+MOD(IEV-131,4)
9326         MSTJ(3)=1+MOD((IEV-131)/4,4)
9327         IF(ITY.EQ.1) CALL LU2ENT(1,4,-5,40.)
9328         IF(ITY.EQ.2) CALL LU3ENT(1,3,21,-3,40.,0.9,0.4)
9329         IF(ITY.EQ.3) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9330         IF(ITY.GE.4) CALL LU4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
9331
9332 C...A hundred events with random jets (check invariant mass).
9333       ELSEIF(IEV.LE.300) THEN
9334   100   DO 110 J=1,5
9335   110   PSUM(J)=0.
9336         NJET=2.+6.*RLU(0)
9337         DO 120 I=1,NJET
9338         KFL=21
9339         IF(I.EQ.1) KFL=INT(1.+4.*RLU(0))
9340         IF(I.EQ.NJET) KFL=-INT(1.+4.*RLU(0))
9341         EJET=5.+20.*RLU(0)
9342         THETA=ACOS(2.*RLU(0)-1.)
9343         PHI=6.2832*RLU(0)
9344         IF(I.LT.NJET) CALL LU1ENT(-I,KFL,EJET,THETA,PHI)
9345         IF(I.EQ.NJET) CALL LU1ENT(I,KFL,EJET,THETA,PHI)
9346         IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+ULMASS(KFL)
9347         DO 120 J=1,4
9348   120   PSUM(J)=PSUM(J)+P(I,J)
9349         IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
9350      &  (PSUM(5)+PARJ(32))**2) GOTO 100
9351
9352 C...Fifty e+e- continuum events with matrix elements.
9353       ELSEIF(IEV.LE.350) THEN
9354         MSTJ(101)=2
9355         CALL LUEEVT(0,40.)
9356
9357 C...Fifty e+e- continuum event with varying shower options.
9358       ELSEIF(IEV.LE.400) THEN
9359         MSTJ(42)=1+MOD(IEV,2)
9360         MSTJ(43)=1+MOD(IEV/2,4)
9361         MSTJ(44)=MOD(IEV/8,3)
9362         CALL LUEEVT(0,90.)
9363
9364 C...Fifty e+e- continuum events with coherent shower, including top.
9365       ELSEIF(IEV.LE.450) THEN
9366         MSTJ(104)=6
9367         CALL LUEEVT(0,500.)
9368
9369 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
9370       ELSEIF(IEV.LE.500) THEN
9371         CALL LUONIA(5,9.46)
9372
9373 C...One decay each for some heavy mesons.
9374       ELSEIF(IEV.LE.560) THEN
9375         ITY=IEV-501
9376         KFLS=2*(ITY/20)+1
9377         KFLB=8-MOD(ITY/5,4)
9378         KFLC=KFLB-MOD(ITY,5)
9379         CALL LU1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9380
9381 C...One decay each for some heavy baryons.
9382       ELSEIF(IEV.LE.600) THEN
9383         ITY=IEV-561
9384         KFLS=2*(ITY/20)+2
9385         KFLA=8-MOD(ITY/5,4)
9386         KFLB=KFLA-MOD(ITY,5)
9387         KFLC=MAX(1,KFLB-1)
9388         CALL LU1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9389       ENDIF
9390
9391 C...Generate event. Find total momentum, energy and charge.
9392       DO 130 J=1,4
9393   130 PINI(J)=PLU(0,J)
9394       PINI(6)=PLU(0,6)
9395       CALL LUEXEC
9396       DO 140 J=1,4
9397   140 PFIN(J)=PLU(0,J)
9398       PFIN(6)=PLU(0,6)
9399
9400 C...Check conservation of energy, momentum and charge;
9401 C...usually exact, but only approximate for single jets.
9402       MERR=0
9403       IF(IEV.LE.50) THEN
9404         IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1
9405         EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
9406         IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1
9407         IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1
9408       ELSE
9409         DO 150 J=1,4
9410   150   IF(ABS(PFIN(J)-PINI(J)).GT.0001*PINI(4)) MERR=MERR+1
9411         IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
9412       ENDIF
9413       IF(MERR.NE.0) WRITE(MSTU(11),1000) (PINI(J),J=1,4),PINI(6),
9414      &(PFIN(J),J=1,4),PFIN(6)
9415
9416 C...Check that all KF codes are known ones, and that partons/particles
9417 C...satisfy energy-momentum-mass relation. Store particle statistics.
9418       DO 160 I=1,N
9419       IF(K(I,1).GT.20) GOTO 160
9420       IF(LUCOMP(K(I,2)).EQ.0) THEN
9421         WRITE(MSTU(11),1100) I
9422         MERR=MERR+1
9423       ENDIF
9424       PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
9425       IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN
9426         WRITE(MSTU(11),1200) I
9427         MERR=MERR+1
9428       ENDIF
9429   160 CONTINUE
9430       IF(MTEST.GE.1) CALL LUTABU(21)
9431
9432 C...List all erroneous events and some normal ones.
9433       IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
9434         CALL LULIST(2)
9435       ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
9436         CALL LULIST(1)
9437       ENDIF
9438
9439 C...Stop execution if too many errors. Endresult of run.
9440       IF(MERR.NE.0) NERR=NERR+1
9441       IF(NERR.GE.10) THEN
9442         WRITE(MSTU(11),1300) IEV
9443         STOP
9444       ENDIF
9445   170 CONTINUE
9446       IF(MTEST.GE.1) CALL LUTABU(22)
9447       WRITE(MSTU(11),1400) NERR
9448
9449 C...Reset commonblock variables changed during run.
9450       MSTJ(2)=3
9451       PARJ(17)=0.
9452       PARJ(22)=1.
9453       PARJ(43)=0.5
9454       PARJ(54)=0.
9455       MSTJ(105)=1
9456       MSTJ(107)=0
9457
9458 C...Format statements for output.
9459  1000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
9460      &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
9461      &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
9462      &4(1X,F12.5),1X,F8.2)
9463  1100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
9464  1200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
9465      &'kinematics')
9466  1300 FORMAT(/5X,'Ten errors experienced by event ',I3/
9467      &5X,'Something is seriously wrong! Execution stopped now!')
9468  1400 FORMAT(/5X,'Number of erroneous or suspect events in run:',I3/
9469      &5X,'(0 fine, 1 acceptable if a single jet, ',
9470      &'>=2 something is wrong)')
9471
9472       RETURN
9473       END
9474
9475 C*********************************************************************
9476
9477       BLOCK DATA LUDATA
9478
9479 C...Purpose: to give default values to parameters and particle and
9480 C...decay data.
9481       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9482       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9483       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
9484       COMMON/LUDAT4/CHAF(500)
9485       CHARACTER CHAF*8
9486       COMMON/LUDATR/MRLU(6),RRLU(100)
9487       SAVE
9488
9489 C...LUDAT1, containing status codes and most parameters.
9490       DATA MSTU/
9491      &    0,    0,    0, 9000,10000,  500, 2000,    0,    0,    2,
9492      1    6,    1,    1,    0,    1,    1,    0,    0,    0,    0,
9493      2    2,   10,    0,    0,    1,   10,    0,    0,    0,    0,
9494      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
9495      4    2,    2,    1,    4,    2,    1,    1,    0,    0,    0,
9496      5   25,   24,    0,    1,    0,    0,    0,    0,    0,    0,
9497      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
9498      7  40*0,
9499      1    1,    5,    3,    5,    0,    0,    0,    0,    0,    0,
9500      2  60*0,
9501      8    7,    2, 1989,   11,   25,    0,    0,    0,    0,    0,
9502      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
9503       DATA PARU/
9504      & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568,   4*0.,
9505      1 0.001, 0.09, 0.01,  0.,   0.,   0.,   0.,   0.,   0.,   0.,
9506      2   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9507      3   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9508      4  2.0,  1.0, 0.25,  2.5, 0.05,   0.,   0., 0.0001, 0.,   0.,
9509      5  2.5,  1.5,  7.0,  1.0,  0.5,  2.0,  3.2,   0.,   0.,   0.,
9510      6  40*0.,
9511      & 0.0072974, 0.230, 0., 0., 0.,   0.,   0.,   0.,   0.,   0.,
9512      1 0.20, 0.25,  1.0,  4.0,   0.,   0.,   0.,   0.,   0.,   0.,
9513      2  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9514      3  70*0./
9515       DATA MSTJ/
9516      &    1,    3,    0,    0,    0,    0,    0,    0,    0,    0,
9517      1    1,    2,    0,    1,    0,    0,    0,    0,    0,    0,
9518      2    2,    2,    1,    2,    1,    0,    0,    0,    0,    0,
9519      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
9520      4    1,    2,    4,    2,    5,    0,    1,    0,    0,    0,
9521      5    0,    3,    0,    0,    0,    0,    0,    0,    0,    0,
9522      6  40*0,
9523      &    5,    2,    7,    5,    1,    1,    0,    2,    0,    1,
9524      1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
9525      2  80*0/
9526       DATA PARJ/
9527      & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50,   0.,   0.,   0.,
9528      1 0.50, 0.60, 0.75,   0.,   0.,   0.,   0.,  1.0,  1.0,   0.,
9529      2 0.35,  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9530      3 0.10,  1.0,  0.8,  1.5,  0.8,  2.0,  0.2,  2.5,  0.6,  2.5,
9531      4  0.5,  0.9,  0.5,  0.9,  0.5,   0.,   0.,   0.,   0.,   0.,
9532      5 0.77, 0.77, 0.77,   0.,   0.,   0.,   0.,   0.,  1.0,   0.,
9533      6  4.5,  0.7,  0., 0.003,  0.5,  0.5,   0.,   0.,   0.,   0.,
9534      7  10., 1000., 100., 1000., 0.,   0.,   0.,   0.,   0.,   0.,
9535      8  0.4,  1.0,  1.0,   0.,  10.,  10.,   0.,   0.,   0.,   0.,
9536      9 0.02,  1.0,  0.2,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9537      &   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9538      1   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9539      2  1.5,  0.5, 91.2, 2.40, 0.02,  2.0,  1.0, 0.25,0.002,   0.,
9540      3   0.,   0.,   0.,   0., 0.01, 0.99,   0.,   0.,  0.2,   0.,
9541      4  60*0./
9542
9543 C...LUDAT2, with particle data and flavour treatment parameters.
9544       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
9545      &-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,
9546      &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,
9547      &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,
9548      &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,
9549      &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/
9550       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,68*0,-1,410*0/
9551       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,
9552      &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,
9553      &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,
9554      &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
9555       DATA (PMAS(I,1),I=   1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,
9556      &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15.,
9557      &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,
9558      &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,
9559      &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921,
9560      &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,
9561      &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,
9562      &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,
9563      &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,
9564      &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,
9565      &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,
9566      &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,
9567      &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,
9568      &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,
9569      &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,
9570      &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,
9571      &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,
9572      &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./
9573       DATA (PMAS(I,2),I=   1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,
9574      &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06,
9575      &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,
9576      &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,
9577      &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,
9578      &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./
9579       DATA (PMAS(I,3),I=   1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4,
9580      &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2,
9581      &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,
9582      &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,
9583      &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./
9584       DATA (PMAS(I,4),I=   1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,
9585      &15*0.,7803.,.00003,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,
9586      &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,
9587      &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./
9588       DATA PARF/
9589      &  0.5, 0.25,  0.5, 0.25,   1.,  0.5,   0.,   0.,   0.,   0.,
9590      1  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9591      2  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9592      3  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9593      4  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9594      5  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,
9595      6 0.75,  0.5,   0., 0.1667, 0.0833, 0.1667, 0., 0., 0.,   0.,
9596      7   0.,   0.,   1., 0.3333, 0.6667, 0.3333, 0., 0., 0.,   0.,
9597      8   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9598      9   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9599      & 0.325, 0.325, 0.5, 1.6,  5.0,   0.,   0.,   0.,   0.,   0.,
9600      1   0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60,  0.,   0.,
9601      2  0.2,  0.1,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
9602      3  1870*0./
9603       DATA ((VCKM(I,J),J=1,4),I=1,4)/
9604      1  0.95150,  0.04847,  0.00003,  0.00000,
9605      2  0.04847,  0.94936,  0.00217,  0.00000,
9606      3  0.00003,  0.00217,  0.99780,  0.00000,
9607      4  0.00000,  0.00000,  0.00000,  1.00000/
9608
9609 C...LUDAT3, with particle decay parameters and data.
9610       DATA (MDCY(I,1),I=   1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,
9611      &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,
9612      &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,
9613      &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/
9614       DATA (MDCY(I,2),I=   1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
9615      &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,
9616      &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,
9617      &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,
9618      &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,
9619      &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,
9620      &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,
9621      &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,
9622      &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,
9623      &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,
9624      &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,
9625      &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023,
9626      &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,
9627      &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,
9628      &1065,114*0/
9629       DATA (MDCY(I,3),I=   1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,
9630      &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,
9631      &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,
9632      &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,
9633      &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,
9634      &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,
9635      &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/
9636       DATA (MDME(I,1),I=   1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
9637      &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,
9638      &-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,
9639      &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/
9640       DATA (MDME(I,2),I=   1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
9641      &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
9642      &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,
9643      &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,
9644      &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,
9645      &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,
9646      &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,
9647      &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,
9648      &974*0/
9649       DATA (BRAT(I)  ,I=   1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003,
9650      &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,
9651      &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,
9652      &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01,
9653      &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,
9654      &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,
9655      &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,
9656      &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,
9657      &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032,
9658      &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,
9659      &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001,
9660      &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037,
9661      &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,
9662      &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004,
9663      &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004,
9664      &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021,
9665      &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,
9666      &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,
9667      &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007,
9668      &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/
9669       DATA (BRAT(I)  ,I= 526, 893)/.019,2*.003,.002,.005,.004,.008,
9670      &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001,
9671      &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04,
9672      &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012,
9673      &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,
9674      &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,
9675      &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,
9676      &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,
9677      &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,
9678      &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,
9679      &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033,
9680      &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,
9681      &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333,
9682      &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35,
9683      &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,
9684      &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084,
9685      &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,
9686      &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,
9687      &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,
9688      &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/
9689       DATA (BRAT(I)  ,I= 894,2000)/.003,.573,.287,.063,.028,2*.021,
9690      &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,
9691      &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003,
9692      &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006,
9693      &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,
9694      &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001,
9695      &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,
9696      &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,
9697      &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676,
9698      &.234,.085,.005,3*1.,4*.5,7*1.,935*0./
9699       DATA (KFDP(I,1),I=   1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,
9700      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
9701      &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
9702      &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
9703      &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,
9704      &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5,
9705      &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,
9706      &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,
9707      &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,
9708      &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
9709      &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,
9710      &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,
9711      &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,
9712      &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,
9713      &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311,
9714      &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311,
9715      &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,
9716      &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,
9717      &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,
9718      &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/
9719       DATA (KFDP(I,1),I= 500, 873)/-323,2*-321,-311,2*333,211,213,
9720      &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,
9721      &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313,
9722      &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15,
9723      &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,
9724      &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111,
9725      &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,
9726      &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,
9727      &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,
9728      &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,
9729      &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,
9730      &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413,
9731      &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,
9732      &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,
9733      &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,
9734      &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213,
9735      &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,
9736      &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,
9737      &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,
9738      &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/
9739       DATA (KFDP(I,1),I= 874,2000)/2*511,521,513,523,513,523,511,2*521,
9740      &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130,
9741      &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,
9742      &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
9743      &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212,
9744      &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
9745      &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,
9746      &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,
9747      &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,
9748      &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,
9749      &935*0/
9750       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,
9751      &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,
9752      &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
9753      &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
9754      &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
9755      &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
9756      &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,
9757      &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
9758      &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,
9759      &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
9760      &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
9761      &-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,
9762      &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,
9763      &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,
9764      &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223,
9765      &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113,
9766      &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1,
9767      &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,
9768      &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,
9769      &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/
9770       DATA (KFDP(I,2),I= 497, 863)/323,321,2*311,313,2*311,111,211,
9771      &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,
9772      &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,
9773      &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,
9774      &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,
9775      &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,
9776      &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,
9777      &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,
9778      &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4,
9779      &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,
9780      &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,
9781      &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,
9782      &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,
9783      &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321,
9784      &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211,
9785      &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111,
9786      &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22,
9787      &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
9788      &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
9789      &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/
9790       DATA (KFDP(I,2),I= 864,2000)/2*111,211,-211,111,-211,111,-211,
9791      &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,
9792      &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22,
9793      &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111,
9794      &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,
9795      &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,
9796      &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,
9797      &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
9798      &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211,
9799      &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,
9800      &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,
9801      &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/
9802       DATA (KFDP(I,3),I=   1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,
9803      &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
9804      &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,
9805      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
9806      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
9807      &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
9808      &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
9809      &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
9810      &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
9811      &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
9812      &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
9813      &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
9814      &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
9815      &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
9816      &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
9817      &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,
9818      &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
9819      &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
9820      &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
9821      &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
9822       DATA (KFDP(I,3),I= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,
9823      &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
9824      &2112,43*0,3322,949*0/
9825       DATA (KFDP(I,4),I=   1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
9826      &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111,
9827      &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
9828      &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
9829      &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
9830      &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
9831      &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
9832      &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
9833      &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
9834      &1006*0/
9835       DATA (KFDP(I,5),I=   1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
9836      &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
9837      &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/
9838
9839 C...LUDAT4, with character strings.
9840       DATA (CHAF(I)  ,I=   1, 331)/'d','u','s','c','b','t','l','h',
9841      &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
9842      &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',
9843      &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron',
9844      &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',
9845      &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis',
9846      &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B',
9847      &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l',
9848      &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho',
9849      &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',
9850      &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',
9851      &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',
9852      &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
9853      &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
9854      &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
9855      &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
9856      &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
9857      &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
9858      &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',
9859      &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/
9860       DATA (CHAF(I)  ,I= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',
9861      &3*'Sigma_c',2*'Xi''_c','Omega_c',
9862      &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
9863      &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
9864      &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
9865
9866 C...LUDATR, with initial values for the random number generator.
9867       DATA MRLU/19780503,0,0,97,33,0/
9868
9869       END
9870       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
9871
9872 C...Initializes the generation procedure; finds maxima of the
9873 C...differential cross-sections to be used for weighting.
9874       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9875       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9876       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
9877       COMMON/LUDAT4/CHAF(500)
9878       CHARACTER CHAF*8
9879       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
9880       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9881       COMMON/PYINT1/MINT(400),VINT(400)
9882       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
9883       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
9884       CHARACTER*(*) FRAME,BEAM,TARGET
9885       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHMO(12)*3,CHLH(2)*6
9886       SAVE
9887       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
9888      &'Oct','Nov','Dec'/, CHLH/'lepton','hadron'/
9889
9890       CHMO(1)=CHMO(1)
9891 C...Write headers.
9892 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),
9893 C     &MSTP(185),CHMO(MSTP(184)),MSTP(183)
9894       CALL LULIST(0)
9895 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)
9896
9897 C...Identify beam and target particles and initialize kinematics.
9898       CHFRAM=FRAME//' '
9899       CHBEAM=BEAM//' '
9900       CHTARG=TARGET//' '
9901       CALL PYINKI(CHFRAM,CHBEAM,CHTARG,WIN)
9902
9903 C...Select partonic subprocesses to be included in the simulation.
9904       IF(MSEL.NE.0) THEN
9905         DO 100 I=1,200
9906   100   MSUB(I)=0
9907       ENDIF
9908       IF(MINT(43).EQ.1.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
9909 C...Lepton+lepton -> gamma/Z0 or W.
9910         IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
9911         IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
9912       ELSEIF(MSEL.EQ.1) THEN
9913 C...High-pT QCD processes:
9914         MSUB(11)=1
9915         MSUB(12)=1
9916         MSUB(13)=1
9917         MSUB(28)=1
9918         MSUB(53)=1
9919         MSUB(68)=1
9920         IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
9921         IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
9922       ELSEIF(MSEL.EQ.2) THEN
9923 C...All QCD processes:
9924         MSUB(11)=1
9925         MSUB(12)=1
9926         MSUB(13)=1
9927         MSUB(28)=1
9928         MSUB(53)=1
9929         MSUB(68)=1
9930         MSUB(91)=1
9931         MSUB(92)=1
9932         MSUB(93)=1
9933         MSUB(95)=1
9934       ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
9935 C...Heavy quark production.
9936         MSUB(81)=1
9937         MSUB(82)=1
9938         DO 110 J=1,MIN(8,MDCY(21,3))
9939   110   MDME(MDCY(21,2)+J-1,1)=0
9940         MDME(MDCY(21,2)+MSEL-1,1)=1
9941       ELSEIF(MSEL.EQ.10) THEN
9942 C...Prompt photon production:
9943         MSUB(14)=1
9944         MSUB(18)=1
9945         MSUB(29)=1
9946       ELSEIF(MSEL.EQ.11) THEN
9947 C...Z0/gamma* production:
9948         MSUB(1)=1
9949       ELSEIF(MSEL.EQ.12) THEN
9950 C...W+/- production:
9951         MSUB(2)=1
9952       ELSEIF(MSEL.EQ.13) THEN
9953 C...Z0 + jet:
9954         MSUB(15)=1
9955         MSUB(30)=1
9956       ELSEIF(MSEL.EQ.14) THEN
9957 C...W+/- + jet:
9958         MSUB(16)=1
9959         MSUB(31)=1
9960       ELSEIF(MSEL.EQ.15) THEN
9961 C...Z0 & W+/- pair production:
9962         MSUB(19)=1
9963         MSUB(20)=1
9964         MSUB(22)=1
9965         MSUB(23)=1
9966         MSUB(25)=1
9967       ELSEIF(MSEL.EQ.16) THEN
9968 C...H0 production:
9969         MSUB(3)=1
9970         MSUB(5)=1
9971         MSUB(8)=1
9972         MSUB(102)=1
9973       ELSEIF(MSEL.EQ.17) THEN
9974 C...H0 & Z0 or W+/- pair production:
9975         MSUB(24)=1
9976         MSUB(26)=1
9977       ELSEIF(MSEL.EQ.21) THEN
9978 C...Z'0 production:
9979         MSUB(141)=1
9980       ELSEIF(MSEL.EQ.22) THEN
9981 C...H+/- production:
9982         MSUB(142)=1
9983       ELSEIF(MSEL.EQ.23) THEN
9984 C...R production:
9985         MSUB(143)=1
9986       ENDIF
9987
9988 C...Count number of subprocesses on.
9989       MINT(44)=0
9990       DO 120 ISUB=1,200
9991       IF(MINT(43).LT.4.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
9992      &MSUB(ISUB).EQ.1) THEN
9993         WRITE(MSTU(11),1200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
9994         STOP
9995       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
9996         WRITE(MSTU(11),1300) ISUB
9997         STOP
9998       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
9999         WRITE(MSTU(11),1400) ISUB
10000         STOP
10001       ELSEIF(MSUB(ISUB).EQ.1) THEN
10002         MINT(44)=MINT(44)+1
10003       ENDIF
10004   120 CONTINUE
10005       IF(MINT(44).EQ.0) THEN
10006         WRITE(MSTU(11),1500)
10007         STOP
10008       ENDIF
10009       MINT(45)=MINT(44)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
10010
10011 C...Maximum 4 generations; set maximum number of allowed flavours.
10012       MSTP(1)=MIN(4,MSTP(1))
10013       MSTU(114)=MIN(MSTU(114),2*MSTP(1))
10014       MSTP(54)=MIN(MSTP(54),2*MSTP(1))
10015
10016 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
10017       DO 140 I=-20,20
10018       VINT(180+I)=0.
10019       IA=IABS(I)
10020       IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
10021         DO 130 J=1,MSTP(1)
10022         IB=2*J-1+MOD(IA,2)
10023         IPM=(5-ISIGN(1,I))/2
10024         IDC=J+MDCY(IA,2)+2
10025   130   IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
10026      &  VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
10027       ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
10028         VINT(180+I)=1.
10029       ENDIF
10030   140 CONTINUE
10031
10032 C...Choose Lambda value to use in alpha-strong.
10033       MSTU(111)=MSTP(2)
10034       IF(MSTP(3).GE.1) THEN
10035         ALAM=PARP(1)
10036         IF(MSTP(51).EQ.1) ALAM=0.2
10037         IF(MSTP(51).EQ.2) ALAM=0.29
10038         IF(MSTP(51).EQ.3) ALAM=0.2
10039         IF(MSTP(51).EQ.4) ALAM=0.4
10040         IF(MSTP(51).EQ.11) ALAM=0.16
10041         IF(MSTP(51).EQ.12) ALAM=0.26
10042         IF(MSTP(51).EQ.13) ALAM=0.36
10043         PARP(1)=ALAM
10044         PARP(61)=ALAM
10045         PARU(112)=ALAM
10046         PARJ(81)=ALAM
10047       ENDIF
10048
10049 C...Initialize widths and partial widths for resonances.
10050       CALL PYINRE
10051
10052 C...Reset variables for cross-section calculation.
10053       DO 150 I=0,200
10054       DO 150 J=1,3
10055       NGEN(I,J)=0
10056   150 XSEC(I,J)=0.
10057       VINT(108)=0.
10058
10059 C...Find parametrized total cross-sections.
10060       IF(MINT(43).EQ.4) CALL PYXTOT
10061
10062 C...Maxima of differential cross-sections.
10063       IF(MSTP(121).LE.0) CALL PYMAXI
10064
10065 C...Initialize possibility of overlayed events.
10066       IF(MSTP(131).NE.0) CALL PYOVLY(1)
10067
10068 C...Initialize multiple interactions with variable impact parameter.
10069       IF(MINT(43).EQ.4.AND.(MINT(45).NE.0.OR.MSTP(131).NE.0).AND.
10070      &MSTP(82).GE.2) CALL PYMULT(1)
10071 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)
10072
10073 C...Formats for initialization information.
10074 C      FORMAT(///20X,'The Lund Monte Carlo - PYTHIA version ',I1,'.',I1/
10075 C     &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)
10076 C      FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
10077 C     &'routines',1X,17('*'))
10078  1200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
10079      &'-',A6,' interactions.'/1X,'Execution stopped!')
10080  1300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
10081      &1X,'Execution stopped!')
10082  1400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
10083      &1X,'Execution stopped!')
10084  1500 FORMAT(1X,'Error: no subprocess switched on.'/
10085      &1X,'Execution stopped.')
10086 C...      FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
10087 C     &22('*'))
10088
10089       RETURN
10090       END
10091
10092 C*********************************************************************
10093
10094       SUBROUTINE PYTHIA
10095
10096 C...Administers the generation of a high-pt event via calls to a number
10097 C...of subroutines; also computes cross-sections.
10098       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10099       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10100       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10101       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10102       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10103       COMMON/PYINT1/MINT(400),VINT(400)
10104       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
10105       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
10106       SAVE
10107
10108 C...Loop over desired number of overlayed events (normally 1).
10109       MINT(7)=0
10110       MINT(8)=0
10111       NOVL=1
10112       IF(MSTP(131).NE.0) CALL PYOVLY(2)
10113       IF(MSTP(131).NE.0) NOVL=MINT(81)
10114       MINT(83)=0
10115       MINT(84)=MSTP(126)
10116       MSTU(70)=0
10117       DO 190 IOVL=1,NOVL
10118       IF(MINT(84)+100.GE.MSTU(4)) THEN
10119         CALL LUERRM(11,
10120      &  '(PYTHIA:) no more space in LUJETS for overlayed events')
10121         IF(MSTU(21).GE.1) GOTO 200
10122       ENDIF
10123       MINT(82)=IOVL
10124
10125 C...Generate variables of hard scattering.
10126   100 CONTINUE
10127       IF(IOVL.EQ.1) NGEN(0,2)=NGEN(0,2)+1
10128       MINT(31)=0
10129       MINT(51)=0
10130       CALL PYRAND
10131       ISUB=MINT(1)
10132       IF(IOVL.EQ.1) THEN
10133         NGEN(ISUB,2)=NGEN(ISUB,2)+1
10134
10135 C...Store information on hard interaction.
10136         DO 110 J=1,200
10137         MSTI(J)=0
10138   110   PARI(J)=0.
10139         MSTI(1)=MINT(1)
10140         MSTI(2)=MINT(2)
10141         MSTI(11)=MINT(11)
10142         MSTI(12)=MINT(12)
10143         MSTI(15)=MINT(15)
10144         MSTI(16)=MINT(16)
10145         MSTI(17)=MINT(17)
10146         MSTI(18)=MINT(18)
10147         PARI(11)=VINT(1)
10148         PARI(12)=VINT(2)
10149         IF(ISUB.NE.95) THEN
10150           DO 120 J=13,22
10151   120     PARI(J)=VINT(30+J)
10152           PARI(33)=VINT(41)
10153           PARI(34)=VINT(42)
10154           PARI(35)=PARI(33)-PARI(34)
10155           PARI(36)=VINT(21)
10156           PARI(37)=VINT(22)
10157           PARI(38)=VINT(26)
10158           PARI(41)=VINT(23)
10159         ENDIF
10160       ENDIF
10161
10162       IF(MSTP(111).EQ.-1) GOTO 160
10163       IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
10164 C...Hard scattering (including low-pT):
10165 C...reconstruct kinematics and colour flow of hard scattering.
10166         CALL PYSCAT
10167         IF(MINT(51).EQ.1) GOTO 100
10168
10169 C...Showering of initial state partons (optional).
10170         IPU1=MINT(84)+1
10171         IPU2=MINT(84)+2
10172         IF(MSTP(61).GE.1.AND.MINT(43).NE.1.AND.ISUB.NE.95)
10173      &  CALL PYSSPA(IPU1,IPU2)
10174         NSAV1=N
10175
10176 C...Multiple interactions.
10177         IF(MSTP(81).GE.1.AND.MINT(43).EQ.4.AND.ISUB.NE.95)
10178      &  CALL PYMULT(6)
10179         MINT(1)=ISUB
10180         NSAV2=N
10181
10182 C...Hadron remnants and primordial kT.
10183         CALL PYREMN(IPU1,IPU2)
10184         IF(MINT(51).EQ.1) GOTO 100
10185         NSAV3=N
10186
10187 C...Showering of final state partons (optional).
10188         IPU3=MINT(84)+3
10189         IPU4=MINT(84)+4
10190         IF(MSTP(71).GE.1.AND.ISUB.NE.95.AND.K(IPU3,1).GT.0.AND.
10191      &  K(IPU3,1).LE.10.AND.K(IPU4,1).GT.0.AND.K(IPU4,1).LE.10) THEN
10192           QMAX=SQRT(PARP(71)*VINT(52))
10193           IF(ISUB.EQ.5) QMAX=SQRT(PMAS(23,1)**2)
10194           IF(ISUB.EQ.8) QMAX=SQRT(PMAS(24,1)**2)
10195           CALL LUSHOW(IPU3,IPU4,QMAX)
10196         ENDIF
10197
10198 C...Sum up transverse and longitudinal momenta.
10199         IF(IOVL.EQ.1) THEN
10200           PARI(65)=2.*PARI(17)
10201           DO 130 I=MSTP(126)+1,N
10202           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
10203           PT=SQRT(P(I,1)**2+P(I,2)**2)
10204           PARI(69)=PARI(69)+PT
10205           IF(I.LE.NSAV1.OR.I.GT.NSAV3) PARI(66)=PARI(66)+PT
10206           IF(I.GT.NSAV1.AND.I.LE.NSAV2) PARI(68)=PARI(68)+PT
10207   130     CONTINUE
10208           PARI(67)=PARI(68)
10209           PARI(71)=VINT(151)
10210           PARI(72)=VINT(152)
10211           PARI(73)=VINT(151)
10212           PARI(74)=VINT(152)
10213         ENDIF
10214
10215 C...Decay of final state resonances.
10216         IF(MSTP(41).GE.1.AND.ISUB.NE.95) CALL PYRESD
10217
10218       ELSE
10219 C...Diffractive and elastic scattering.
10220         CALL PYDIFF
10221         IF(IOVL.EQ.1) THEN
10222           PARI(65)=2.*PARI(17)
10223           PARI(66)=PARI(65)
10224           PARI(69)=PARI(65)
10225         ENDIF
10226       ENDIF
10227
10228 C...Recalculate energies from momenta and masses (if desired).
10229       IF(MSTP(113).GE.1) THEN
10230         DO 140 I=MINT(83)+1,N
10231   140   IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
10232      &  P(I,2)**2+P(I,3)**2+P(I,5)**2)
10233       ENDIF
10234
10235 C...Rearrange partons along strings, check invariant mass cuts.
10236       MSTU(28)=0
10237       CALL LUPREP(MINT(84)+1)
10238       IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
10239       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
10240         DO 150 I=MINT(84)+1,N
10241         IF(K(I,2).NE.94) GOTO 150
10242         K(I+1,3)=MOD(K(I+1,4)/MSTU(5),MSTU(5))
10243         K(I+2,3)=MOD(K(I+2,4)/MSTU(5),MSTU(5))
10244   150   CONTINUE
10245         CALL LUEDIT(12)
10246         CALL LUEDIT(14)
10247         IF(MSTP(125).EQ.0) CALL LUEDIT(15)
10248         IF(MSTP(125).EQ.0) MINT(4)=0
10249       ENDIF
10250
10251 C...Introduce separators between sections in LULIST event listing.
10252       IF(IOVL.EQ.1.AND.MSTP(125).LE.0) THEN
10253         MSTU(70)=1
10254         MSTU(71)=N
10255       ELSEIF(IOVL.EQ.1) THEN
10256         MSTU(70)=3
10257         MSTU(71)=2
10258         MSTU(72)=MINT(4)
10259         MSTU(73)=N
10260       ENDIF
10261
10262 C...Perform hadronization (if desired).
10263       IF(MSTP(111).GE.1) CALL LUEXEC
10264       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL LUEDIT(14)
10265
10266 C...Calculate Monte Carlo estimates of cross-sections.
10267   160 IF(IOVL.EQ.1) THEN
10268         IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
10269         NGEN(0,3)=NGEN(0,3)+1
10270         XSEC(0,3)=0.
10271         DO 170 I=1,200
10272         IF(I.EQ.96) THEN
10273           XSEC(I,3)=0.
10274         ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
10275      &  I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
10276           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1.,FLOAT(NGEN(96,1))*
10277      &    FLOAT(NGEN(96,2)))
10278         ELSEIF(NGEN(I,1).EQ.0) THEN
10279           XSEC(I,3)=0.
10280         ELSEIF(NGEN(I,2).EQ.0) THEN
10281           XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(FLOAT(NGEN(I,1))*
10282      &    FLOAT(NGEN(0,2)))
10283         ELSE
10284           XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(FLOAT(NGEN(I,1))*
10285      &    FLOAT(NGEN(I,2)))
10286         ENDIF
10287   170   XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
10288         IF(MSUB(95).EQ.1) THEN
10289           NGENS=NGEN(91,3)+NGEN(92,3)+NGEN(93,3)+NGEN(94,3)+NGEN(95,3)
10290           XSECS=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+XSEC(95,3)
10291           XMAXS=XSEC(95,1)
10292           IF(MSUB(91).EQ.1) XMAXS=XMAXS+XSEC(91,1)
10293           IF(MSUB(92).EQ.1) XMAXS=XMAXS+XSEC(92,1)
10294           IF(MSUB(93).EQ.1) XMAXS=XMAXS+XSEC(93,1)
10295           IF(MSUB(94).EQ.1) XMAXS=XMAXS+XSEC(94,1)
10296           FAC=1.
10297           IF(NGENS.LT.NGEN(0,3)) FAC=(XMAXS-XSECS)/(XSEC(0,3)-XSECS)
10298           XSEC(11,3)=FAC*XSEC(11,3)
10299           XSEC(12,3)=FAC*XSEC(12,3)
10300           XSEC(13,3)=FAC*XSEC(13,3)
10301           XSEC(28,3)=FAC*XSEC(28,3)
10302           XSEC(53,3)=FAC*XSEC(53,3)
10303           XSEC(68,3)=FAC*XSEC(68,3)
10304           XSEC(0,3)=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+
10305      &    XSEC(95,1)
10306         ENDIF
10307
10308 C...Store final information.
10309         MINT(5)=MINT(5)+1
10310         MSTI(3)=MINT(3)
10311         MSTI(4)=MINT(4)
10312         MSTI(5)=MINT(5)
10313         MSTI(6)=MINT(6)
10314         MSTI(7)=MINT(7)
10315         MSTI(8)=MINT(8)
10316         MSTI(13)=MINT(13)
10317         MSTI(14)=MINT(14)
10318         MSTI(21)=MINT(21)
10319         MSTI(22)=MINT(22)
10320         MSTI(23)=MINT(23)
10321         MSTI(24)=MINT(24)
10322         MSTI(25)=MINT(25)
10323         MSTI(26)=MINT(26)
10324         MSTI(31)=MINT(31)
10325         PARI(1)=XSEC(0,3)
10326         PARI(2)=XSEC(0,3)/MINT(5)
10327         PARI(31)=VINT(141)
10328         PARI(32)=VINT(142)
10329         IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
10330           PARI(42)=2.*VINT(47)/VINT(1)
10331           DO 180 IS=7,8
10332           PARI(36+IS)=P(MINT(IS),3)/VINT(1)
10333           PARI(38+IS)=P(MINT(IS),4)/VINT(1)
10334           I=MINT(IS)
10335           PR=MAX(1E-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
10336           PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
10337      &    SQRT(PR),1E20)),P(I,3))
10338           PR=MAX(1E-20,P(I,1)**2+P(I,2)**2)
10339           PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
10340      &    SQRT(PR),1E20)),P(I,3))
10341           PARI(44+IS)=P(I,3)/SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
10342           PARI(46+IS)=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
10343           PARI(48+IS)=ULANGL(P(I,1),P(I,2))
10344   180     CONTINUE
10345         ENDIF
10346         PARI(61)=VINT(148)
10347         IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
10348           MSTU(161)=MINT(21)
10349           MSTU(162)=0
10350         ELSE
10351           MSTU(161)=MINT(21)
10352           MSTU(162)=MINT(22)
10353         ENDIF
10354       ENDIF
10355
10356 C...Prepare to go to next overlayed event.
10357       MSTI(41)=IOVL
10358       IF(IOVL.GE.2.AND.IOVL.LE.10) MSTI(40+IOVL)=ISUB
10359       IF(MSTU(70).LT.10) THEN
10360         MSTU(70)=MSTU(70)+1
10361         MSTU(70+MSTU(70))=N
10362       ENDIF
10363       MINT(83)=N
10364       MINT(84)=N+MSTP(126)
10365   190 CONTINUE
10366
10367 C...Information on overlayed events.
10368       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
10369         PARI(91)=VINT(132)
10370         PARI(92)=VINT(133)
10371         PARI(93)=VINT(134)
10372         IF(MSTP(133).EQ.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
10373       ENDIF
10374
10375 C...Transform to the desired coordinate frame.
10376   200 CALL PYFRAM(MSTP(124))
10377
10378       RETURN
10379       END
10380
10381 C***********************************************************************
10382
10383       SUBROUTINE PYSTAT(MSTAT)
10384
10385 C...Prints out information about cross-sections, decay widths, branching
10386 C...ratios, kinematical limits, status codes and parameter values.
10387       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10388       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10389       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10390       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10391       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10392       COMMON/PYINT1/MINT(400),VINT(400)
10393       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
10394       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
10395       COMMON/PYINT6/PROC(0:200)
10396       CHARACTER PROC*28
10397       CHARACTER CHAU*16,CHPA(-40:40)*12,CHIN(2)*12,
10398      &STATE(-1:5)*4,CHKIN(21)*18
10399       SAVE
10400       DATA STATE/'----','off ','on  ','on/+','on/-','on/1','on/2'/,
10401      &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
10402      &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',
10403      &'     y*_small     ','    eta*_large    ','    eta*_small    ',
10404      &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',
10405      &'       x_2        ','       x_F        ',' cos(theta_hard)  ',
10406      &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',
10407      &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',
10408      &'       tau''       '/
10409
10410 C...Cross-sections.
10411       IF(MSTAT.LE.1) THEN
10412         WRITE(MSTU(11),1000)
10413         WRITE(MSTU(11),1100)
10414         WRITE(MSTU(11),1200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
10415         DO 100 I=1,200
10416         IF(MSUB(I).NE.1) GOTO 100
10417         WRITE(MSTU(11),1200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
10418   100   CONTINUE
10419         WRITE(MSTU(11),1300) 1.-FLOAT(NGEN(0,3))/
10420      &  MAX(1.,FLOAT(NGEN(0,2)))
10421
10422 C...Decay widths and branching ratios.
10423       ELSEIF(MSTAT.EQ.2) THEN
10424         DO 110 KF=-40,40
10425         CALL LUNAME(KF,CHAU)
10426   110   CHPA(KF)=CHAU(1:12)
10427         WRITE(MSTU(11),1400)
10428         WRITE(MSTU(11),1500)
10429 C...Off-shell branchings.
10430         DO 130 I=1,17
10431         KC=I
10432         IF(I.GE.9) KC=I+2
10433         IF(I.EQ.17) KC=21
10434         WRITE(MSTU(11),1600) CHPA(KC),0.,0.,STATE(MDCY(KC,1)),0.
10435         DO 120 J=1,MDCY(KC,3)
10436         IDC=J+MDCY(KC,2)-1
10437   120   IF(MDME(IDC,2).EQ.102) WRITE(MSTU(11),1700) CHPA(KFDP(IDC,1)),
10438      &  CHPA(KFDP(IDC,2)),0.,0.,STATE(MDME(IDC,1)),0.
10439   130   CONTINUE
10440 C...On-shell decays.
10441         DO 150 I=1,6
10442         KC=I+22
10443         IF(I.EQ.4) KC=32
10444         IF(I.EQ.5) KC=37
10445         IF(I.EQ.6) KC=40
10446         IF(WIDE(KC,0).GT.0.) THEN
10447           WRITE(MSTU(11),1600) CHPA(KC),WIDP(KC,0),1.,
10448      &    STATE(MDCY(KC,1)),1.
10449           DO 140 J=1,MDCY(KC,3)
10450           IDC=J+MDCY(KC,2)-1
10451   140     WRITE(MSTU(11),1700) CHPA(KFDP(IDC,1)),CHPA(KFDP(IDC,2)),
10452      &    WIDP(KC,J),WIDP(KC,J)/WIDP(KC,0),STATE(MDME(IDC,1)),
10453      &    WIDE(KC,J)/WIDE(KC,0)
10454         ELSE
10455           WRITE(MSTU(11),1600) CHPA(KC),WIDP(KC,0),1.,
10456      &    STATE(MDCY(KC,1)),0.
10457         ENDIF
10458   150   CONTINUE
10459         WRITE(MSTU(11),1800)
10460
10461 C...Allowed incoming partons/particles at hard interaction.
10462       ELSEIF(MSTAT.EQ.3) THEN
10463         WRITE(MSTU(11),1900)
10464         CALL LUNAME(MINT(11),CHAU)
10465         CHIN(1)=CHAU(1:12)
10466         CALL LUNAME(MINT(12),CHAU)
10467         CHIN(2)=CHAU(1:12)
10468         WRITE(MSTU(11),2000) CHIN(1),CHIN(2)
10469         DO 160 KF=-40,40
10470         CALL LUNAME(KF,CHAU)
10471   160   CHPA(KF)=CHAU(1:12)
10472         IF(MINT(43).EQ.1) THEN
10473           WRITE(MSTU(11),2100) CHPA(MINT(11)),STATE(KFIN(1,MINT(11))),
10474      &    CHPA(MINT(12)),STATE(KFIN(2,MINT(12)))
10475         ELSEIF(MINT(43).EQ.2) THEN
10476           WRITE(MSTU(11),2100) CHPA(MINT(11)),STATE(KFIN(1,MINT(11))),
10477      &    CHPA(-MSTP(54)),STATE(KFIN(2,-MSTP(54)))
10478           DO 170 I=-MSTP(54)+1,-1
10479   170     WRITE(MSTU(11),2200) CHPA(I),STATE(KFIN(2,I))
10480           DO 180 I=1,MSTP(54)
10481   180     WRITE(MSTU(11),2200) CHPA(I),STATE(KFIN(2,I))
10482           WRITE(MSTU(11),2200) CHPA(21),STATE(KFIN(2,21))
10483         ELSEIF(MINT(43).EQ.3) THEN
10484           WRITE(MSTU(11),2100) CHPA(-MSTP(54)),STATE(KFIN(1,-MSTP(54))),
10485      &    CHPA(MINT(12)),STATE(KFIN(2,MINT(12)))
10486           DO 190 I=-MSTP(54)+1,-1
10487   190     WRITE(MSTU(11),2300) CHPA(I),STATE(KFIN(1,I))
10488           DO 200 I=1,MSTP(54)
10489   200     WRITE(MSTU(11),2300) CHPA(I),STATE(KFIN(1,I))
10490           WRITE(MSTU(11),2300) CHPA(21),STATE(KFIN(1,21))
10491         ELSEIF(MINT(43).EQ.4) THEN
10492           DO 210 I=-MSTP(54),-1
10493   210     WRITE(MSTU(11),2100) CHPA(I),STATE(KFIN(1,I)),CHPA(I),
10494      &    STATE(KFIN(2,I))
10495           DO 220 I=1,MSTP(54)
10496   220     WRITE(MSTU(11),2100) CHPA(I),STATE(KFIN(1,I)),CHPA(I),
10497      &    STATE(KFIN(2,I))
10498           WRITE(MSTU(11),2100) CHPA(21),STATE(KFIN(1,21)),CHPA(21),
10499      &    STATE(KFIN(2,21))
10500         ENDIF
10501         WRITE(MSTU(11),2400)
10502
10503 C...User-defined and derived limits on kinematical variables.
10504       ELSEIF(MSTAT.EQ.4) THEN
10505         WRITE(MSTU(11),2500)
10506         WRITE(MSTU(11),2600)
10507         SHRMAX=CKIN(2)
10508         IF(SHRMAX.LT.0.) SHRMAX=VINT(1)
10509         WRITE(MSTU(11),2700) CKIN(1),CHKIN(1),SHRMAX
10510         PTHMIN=MAX(CKIN(3),CKIN(5))
10511         PTHMAX=CKIN(4)
10512         IF(PTHMAX.LT.0.) PTHMAX=0.5*SHRMAX
10513         WRITE(MSTU(11),2800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
10514         WRITE(MSTU(11),2900) CHKIN(3),CKIN(6)
10515         DO 230 I=4,14
10516   230   WRITE(MSTU(11),2700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
10517         SPRMAX=CKIN(32)
10518         IF(SPRMAX.LT.0.) SPRMAX=VINT(1)
10519         WRITE(MSTU(11),2700) CKIN(31),CHKIN(13),SPRMAX
10520         WRITE(MSTU(11),3000)
10521         WRITE(MSTU(11),3100)
10522         WRITE(MSTU(11),2600)
10523         DO 240 I=16,21
10524   240   WRITE(MSTU(11),2700) VINT(I-5),CHKIN(I),VINT(I+15)
10525         WRITE(MSTU(11),3000)
10526
10527 C...Status codes and parameter values.
10528       ELSEIF(MSTAT.EQ.5) THEN
10529         WRITE(MSTU(11),3200)
10530         WRITE(MSTU(11),3300)
10531         DO 250 I=1,100
10532   250   WRITE(MSTU(11),3400) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
10533      &  PARP(100+I)
10534       ENDIF
10535
10536 C...Formats for printouts.
10537  1000 FORMAT('1',9('*'),1X,'PYSTAT:  Statistics on Number of ',
10538      &'Events and Cross-sections',1X,9('*'))
10539  1100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
10540      &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
10541      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
10542      &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
10543      &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
10544      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
10545      &'I',12X,'I')
10546  1200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
10547      &E10.3,1X,'I')
10548  1300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
10549      &1X,'********* Fraction of events that fail fragmentation ',
10550      &'cuts =',1X,F8.5,' *********'/)
10551  1400 FORMAT('1',17('*'),1X,'PYSTAT:  Decay Widths and Branching ',
10552      &'Ratios',1X,17('*'))
10553  1500 FORMAT(/1X,78('=')/1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
10554      &1X,'I',1X,'Branching/Decay Channel',5X,'I',1X,'Width (GeV)',1X,
10555      &'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,'Eff. B.R.',1X,'I'/1X,
10556      &'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,78('='))
10557  1600 FORMAT(1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
10558      &A12,1X,'->',13X,'I',2X,1P,E10.3,0P,1X,'I',1X,1P,E10.3,0P,1X,'I',
10559      &1X,A4,1X,'I',1X,1P,E10.3,0P,1X,'I')
10560  1700 FORMAT(1X,'I',1X,A12,1X,'+',1X,A12,1X,'I',2X,1P,E10.3,0P,1X,'I',
10561      &1X,1P,E10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,E10.3,0P,1X,'I')
10562  1800 FORMAT(1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,78('='))
10563  1900 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
10564      &'Particles at Hard Interaction',1X,7('*'))
10565  2000 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
10566      &'Beam particle:',1X,A,10X,'I',1X,'Target particle:',1X,A,7X,
10567      &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',9X,'State',16X,
10568      &'I',1X,'Content',9X,'State',15X,'I'/1X,'I',38X,'I',37X,'I'/1X,
10569      &78('=')/1X,'I',38X,'I',37X,'I')
10570  2100 FORMAT(1X,'I',1X,A,5X,A,16X,'I',1X,A,5X,A,15X,'I')
10571  2200 FORMAT(1X,'I',38X,'I',1X,A,5X,A,15X,'I')
10572  2300 FORMAT(1X,'I',1X,A,5X,A,16X,'I',37X,'I')
10573  2400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
10574  2500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
10575      &'Kinematical Variables',1X,12('*'))
10576  2600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
10577  2700 FORMAT(1X,'I',16X,1P,E10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,E10.3,0P,
10578      &16X,'I')
10579  2800 FORMAT(1X,'I',3X,1P,E10.3,0P,1X,'(',1P,E10.3,0P,')',1X,'<',1X,A,
10580      &1X,'<',1X,1P,E10.3,0P,16X,'I')
10581  2900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,E10.3,0P,16X,'I')
10582  3000 FORMAT(1X,'I',76X,'I'/1X,78('='))
10583  3100 FORMAT(////1X,5('*'),1X,'PYSTAT: Derived Limits on Kinematical ',
10584      &'Variables Used in Generation',1X,5('*'))
10585  3200 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
10586      &'Parameter Values',1X,12('*'))
10587  3300 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
10588      &'PARP(I)'/)
10589  3400 FORMAT(1X,I3,5X,I6,6X,1P,E10.3,0P,18X,I3,5X,I6,6X,1P,E10.3)
10590
10591       RETURN
10592       END
10593
10594 C*********************************************************************
10595
10596       SUBROUTINE PYINKI(CHFRAM,CHBEAM,CHTARG,WIN)
10597
10598 C...Identifies the two incoming particles and sets up kinematics,
10599 C...including rotations and boosts to/from CM frame.
10600       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10601       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10602       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10603       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10604       COMMON/PYINT1/MINT(400),VINT(400)
10605       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
10606      &CHIDNT(3)*8,CHTEMP*8,CHCDE(18)*8,CHINIT*76
10607       DIMENSION LEN(3),KCDE(18)
10608       SAVE
10609       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
10610      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
10611       DATA CHCDE/'e-      ','e+      ','nue     ','nue~    ',
10612      &'mu-     ','mu+     ','numu    ','numu~   ','tau-    ',
10613      &'tau+    ','nutau   ','nutau~  ','pi+     ','pi-     ',
10614      &'n       ','n~      ','p       ','p~      '/
10615       DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
10616      &211,-211,2112,-2112,2212,-2212/
10617
10618 C...Convert character variables to lowercase and find their length.
10619       CHCOM(1)=CHFRAM
10620       CHCOM(2)=CHBEAM
10621       CHCOM(3)=CHTARG
10622       DO 120 I=1,3
10623       LEN(I)=8
10624       DO 100 LL=8,1,-1
10625       IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
10626       DO 100 LA=1,26
10627   100 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
10628      &CHALP(1)(LA:LA)
10629       CHIDNT(I)=CHCOM(I)
10630       DO 110 LL=1,6
10631       IF(CHIDNT(I)(LL:LL+2).EQ.'bar') THEN
10632         CHTEMP=CHIDNT(I)
10633         CHIDNT(I)=CHTEMP(1:LL-1)//'~'//CHTEMP(LL+3:8)//'  '
10634       ENDIF
10635   110 CONTINUE
10636       DO 120 LL=1,8
10637       IF(CHIDNT(I)(LL:LL).EQ.'_') THEN
10638         CHTEMP=CHIDNT(I)
10639         CHIDNT(I)=CHTEMP(1:LL-1)//CHTEMP(LL+1:8)//' '
10640       ENDIF
10641   120 CONTINUE
10642
10643 C...Set initial state. Error for unknown codes. Reset variables.
10644       N=2
10645       DO 140 I=1,2
10646       K(I,2)=0
10647       DO 130 J=1,18
10648   130 IF(CHIDNT(I+1).EQ.CHCDE(J)) K(I,2)=KCDE(J)
10649       P(I,5)=ULMASS(K(I,2))
10650       MINT(40+I)=1
10651       IF(IABS(K(I,2)).GT.100) MINT(40+I)=2
10652       DO 140 J=1,5
10653   140 V(I,J)=0.
10654       IF(K(1,2).EQ.0) WRITE(MSTU(11),1000) CHBEAM(1:LEN(2))
10655       IF(K(2,2).EQ.0) WRITE(MSTU(11),1100) CHTARG(1:LEN(3))
10656       IF(K(1,2).EQ.0.OR.K(2,2).EQ.0) STOP
10657       DO 150 J=6,10
10658   150 VINT(J)=0.
10659       CHINIT=' '
10660
10661 C...Set up kinematics for events defined in CM frame.
10662       IF(CHCOM(1)(1:2).EQ.'cm') THEN
10663         IF(CHCOM(2)(1:1).NE.'e') THEN
10664           LOFFS=(34-(LEN(2)+LEN(3)))/2
10665           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
10666      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
10667         ELSE
10668           LOFFS=(33-(LEN(2)+LEN(3)))/2
10669           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
10670      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
10671         ENDIF
10672 C        WRITE(MSTU(11),1200) CHINIT
10673 C        WRITE(MSTU(11),1300) WIN
10674         S=WIN**2
10675         P(1,1)=0.
10676         P(1,2)=0.
10677         P(2,1)=0.
10678         P(2,2)=0.
10679         P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2.*P(1,5)*P(2,5))**2)/
10680      &  (4.*S))
10681         P(2,3)=-P(1,3)
10682         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
10683         P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
10684
10685 C...Set up kinematics for fixed target events.
10686       ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
10687         LOFFS=(29-(LEN(2)+LEN(3)))/2
10688         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
10689      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
10690      &  ' fixed target'//' '
10691 C        WRITE(MSTU(11),1200) CHINIT
10692 C        WRITE(MSTU(11),1400) WIN
10693         P(1,1)=0.
10694         P(1,2)=0.
10695         P(2,1)=0.
10696         P(2,2)=0.
10697         P(1,3)=WIN
10698         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
10699         P(2,3)=0.
10700         P(2,4)=P(2,5)
10701         S=P(1,5)**2+P(2,5)**2+2.*P(2,4)*P(1,4)
10702         VINT(10)=P(1,3)/(P(1,4)+P(2,4))
10703         CALL LUROBO(0.,0.,0.,0.,-VINT(10))
10704 C        WRITE(MSTU(11),1500) SQRT(S)
10705
10706 C...Set up kinematics for events in user-defined frame.
10707       ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
10708         LOFFS=(13-(LEN(1)+LEN(2)))/2
10709         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
10710      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
10711      &  'user-specified configuration'//' '
10712 C        WRITE(MSTU(11),1200) CHINIT
10713 C        WRITE(MSTU(11),1600)
10714 C        WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)
10715 C        WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)
10716         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
10717         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
10718         DO 160 J=1,3
10719   160   VINT(7+J)=(DBLE(P(1,J))+DBLE(P(2,J)))/DBLE(P(1,4)+P(2,4))
10720         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
10721         VINT(7)=ULANGL(P(1,1),P(1,2))
10722         CALL LUROBO(0.,-VINT(7),0.,0.,0.)
10723         VINT(6)=ULANGL(P(1,3),P(1,1))
10724         CALL LUROBO(-VINT(6),0.,0.,0.,0.)
10725         S=P(1,5)**2+P(2,5)**2+2.*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
10726 C        WRITE(MSTU(11),1500) SQRT(S)
10727
10728 C...Unknown frame. Error for too low CM energy.
10729       ELSE
10730         WRITE(MSTU(11),1800) CHFRAM(1:LEN(1))
10731         STOP
10732       ENDIF
10733       IF(S.LT.PARP(2)**2) THEN
10734         WRITE(MSTU(11),1900) SQRT(S)
10735         STOP
10736       ENDIF
10737
10738 C...Save information on incoming particles.
10739       MINT(11)=K(1,2)
10740       MINT(12)=K(2,2)
10741       MINT(43)=2*MINT(41)+MINT(42)-2
10742       VINT(1)=SQRT(S)
10743       VINT(2)=S
10744       VINT(3)=P(1,5)
10745       VINT(4)=P(2,5)
10746       VINT(5)=P(1,3)
10747
10748 C...Store constants to be used in generation.
10749       IF(MSTP(82).LE.1) VINT(149)=4.*PARP(81)**2/S
10750       IF(MSTP(82).GE.2) VINT(149)=4.*PARP(82)**2/S
10751
10752 C...Formats for initialization and error information.
10753  1000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''.'/
10754      &1X,'Execution stopped!')
10755  1100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''.'/
10756      &1X,'Execution stopped!')
10757 C 1200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
10758 C 1300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
10759 C     &19X,'I'/1X,'I',76X,'I'/1X,78('='))
10760 C 1400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
10761 C 1500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
10762 C     &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
10763 C 1600 FORMAT(1X,'I',76X,'I'/1X,'I',24X,'px (GeV/c)',3X,'py (GeV/c)',3X,
10764 C     &'pz (GeV/c)',16X,'I')
10765 C 1700 FORMAT(1X,'I',15X,A8,3(2X,F10.3,1X),15X,'I')
10766  1800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''.'/
10767      &1X,'Execution stopped!')
10768  1900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
10769      &'generation.'/1X,'Execution stopped!')
10770
10771       RETURN
10772       END
10773
10774 C*********************************************************************
10775
10776       SUBROUTINE PYINRE
10777
10778 C...Calculates full and effective widths of guage bosons, stores masses
10779 C...and widths, rescales coefficients to be used for resonance
10780 C...production generation.
10781       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10782       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10783       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10784       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10785       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10786       COMMON/PYINT1/MINT(400),VINT(400)
10787       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
10788       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
10789       COMMON/PYINT6/PROC(0:200)
10790       CHARACTER PROC*28
10791       DIMENSION WDTP(0:40),WDTE(0:40,0:5)
10792       SAVE
10793
10794 C...Calculate full and effective widths of gauge bosons.
10795       AEM=PARU(101)
10796       XW=PARU(102)
10797       DO 100 I=21,40
10798       DO 100 J=0,40
10799       WIDP(I,J)=0.
10800   100 WIDE(I,J)=0.
10801
10802 C...W+/-:
10803       WMAS=PMAS(24,1)
10804       WFAC=AEM/(24.*XW)*WMAS
10805       CALL PYWIDT(24,WMAS,WDTP,WDTE)
10806       WIDS(24,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
10807      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
10808      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
10809       WIDS(24,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
10810       WIDS(24,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
10811       DO 110 I=0,40
10812       WIDP(24,I)=WFAC*WDTP(I)
10813   110 WIDE(24,I)=WFAC*WDTE(I,0)
10814
10815 C...H+/-:
10816       HCMAS=PMAS(37,1)
10817       HCFAC=AEM/(8.*XW)*(HCMAS/WMAS)**2*HCMAS
10818       CALL PYWIDT(37,HCMAS,WDTP,WDTE)
10819       WIDS(37,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
10820      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
10821      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
10822       WIDS(37,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
10823       WIDS(37,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
10824       DO 120 I=0,40
10825       WIDP(37,I)=HCFAC*WDTP(I)
10826   120 WIDE(37,I)=HCFAC*WDTE(I,0)
10827
10828 C...Z0:
10829       ZMAS=PMAS(23,1)
10830       ZFAC=AEM/(48.*XW*(1.-XW))*ZMAS
10831       CALL PYWIDT(23,ZMAS,WDTP,WDTE)
10832       WIDS(23,1)=((WDTE(0,1)+WDTE(0,2))**2+
10833      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
10834      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
10835       WIDS(23,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
10836       WIDS(23,3)=0.
10837       DO 130 I=0,40
10838       WIDP(23,I)=ZFAC*WDTP(I)
10839   130 WIDE(23,I)=ZFAC*WDTE(I,0)
10840
10841 C...H0:
10842       HMAS=PMAS(25,1)
10843       HFAC=AEM/(8.*XW)*(HMAS/WMAS)**2*HMAS
10844       CALL PYWIDT(25,HMAS,WDTP,WDTE)
10845       WIDS(25,1)=((WDTE(0,1)+WDTE(0,2))**2+
10846      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
10847      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
10848       WIDS(25,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
10849       WIDS(25,3)=0.
10850       DO 140 I=0,40
10851       WIDP(25,I)=HFAC*WDTP(I)
10852   140 WIDE(25,I)=HFAC*WDTE(I,0)
10853
10854 C...Z'0:
10855       ZPMAS=PMAS(32,1)
10856       ZPFAC=AEM/(48.*XW*(1.-XW))*ZPMAS
10857       CALL PYWIDT(32,ZPMAS,WDTP,WDTE)
10858       WIDS(32,1)=((WDTE(0,1)+WDTE(0,2)+WDTE(0,3))**2+
10859      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
10860      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
10861       WIDS(32,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
10862       WIDS(32,3)=0.
10863       DO 150 I=0,40
10864       WIDP(32,I)=ZPFAC*WDTP(I)
10865   150 WIDE(32,I)=ZPFAC*WDTE(I,0)
10866
10867 C...R:
10868       RMAS=PMAS(40,1)
10869       RFAC=0.08*RMAS/((MSTP(1)-1)*(1.+6.*(1.+ULALPS(RMAS**2)/PARU(1))))
10870       CALL PYWIDT(40,RMAS,WDTP,WDTE)
10871       WIDS(40,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
10872      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
10873      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
10874       WIDS(40,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
10875       WIDS(40,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
10876       DO 160 I=0,40
10877       WIDP(40,I)=WFAC*WDTP(I)
10878   160 WIDE(40,I)=WFAC*WDTE(I,0)
10879
10880 C...Q:
10881       KFLQM=1
10882       DO 170 I=1,MIN(8,MDCY(21,3))
10883       IDC=I+MDCY(21,2)-1
10884       IF(MDME(IDC,1).LE.0) GOTO 170
10885       KFLQM=I
10886   170 CONTINUE
10887       MINT(46)=KFLQM
10888       KFPR(81,1)=KFLQM
10889       KFPR(81,2)=KFLQM
10890       KFPR(82,1)=KFLQM
10891       KFPR(82,2)=KFLQM
10892
10893 C...Set resonance widths and branching ratios in JETSET.
10894       DO 180 I=1,6
10895       IF(I.LE.3) KC=I+22
10896       IF(I.EQ.4) KC=32
10897       IF(I.EQ.5) KC=37
10898       IF(I.EQ.6) KC=40
10899       PMAS(KC,2)=WIDP(KC,0)
10900       PMAS(KC,3)=MIN(0.9*PMAS(KC,1),10.*PMAS(KC,2))
10901       DO 180 J=1,MDCY(KC,3)
10902       IDC=J+MDCY(KC,2)-1
10903       BRAT(IDC)=WIDE(KC,J)/WIDE(KC,0)
10904   180 CONTINUE
10905
10906 C...Special cases in treatment of gamma*/Z0: redefine process name.
10907       IF(MSTP(43).EQ.1) THEN
10908         PROC(1)='f + fb -> gamma*'
10909       ELSEIF(MSTP(43).EQ.2) THEN
10910         PROC(1)='f + fb -> Z0'
10911       ELSEIF(MSTP(43).EQ.3) THEN
10912         PROC(1)='f + fb -> gamma*/Z0'
10913       ENDIF
10914
10915 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
10916       IF(MSTP(44).EQ.1) THEN
10917         PROC(141)='f + fb -> gamma*'
10918       ELSEIF(MSTP(44).EQ.2) THEN
10919         PROC(141)='f + fb -> Z0'
10920       ELSEIF(MSTP(44).EQ.3) THEN
10921         PROC(141)='f + fb -> Z''0'
10922       ELSEIF(MSTP(44).EQ.4) THEN
10923         PROC(141)='f + fb -> gamma*/Z0'
10924       ELSEIF(MSTP(44).EQ.5) THEN
10925         PROC(141)='f + fb -> gamma*/Z''0'
10926       ELSEIF(MSTP(44).EQ.6) THEN
10927         PROC(141)='f + fb -> Z0/Z''0'
10928       ELSEIF(MSTP(44).EQ.7) THEN
10929         PROC(141)='f + fb -> gamma*/Z0/Z''0'
10930       ENDIF
10931
10932       RETURN
10933       END
10934
10935 C*********************************************************************
10936
10937       SUBROUTINE PYXTOT
10938
10939 C...Parametrizes total, double diffractive, single diffractive and
10940 C...elastic cross-sections for different energies and beams.
10941       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10942       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10943       COMMON/PYINT1/MINT(400),VINT(400)
10944       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
10945       DIMENSION BCS(5,8),BCB(2,5),BCC(3)
10946       SAVE
10947
10948 C...The following data lines are coefficients needed in the
10949 C...Block, Cahn parametrization of total cross-section and nuclear
10950 C...slope parameter; see below.
10951       DATA ((BCS(I,J),J=1,8),I=1,5)/
10952      1 41.74, 0.66, 0.0000, 337.,  0.0, 0.0, -39.3, 0.48,
10953      2 41.66, 0.60, 0.0000, 306.,  0.0, 0.0, -34.6, 0.51,
10954      3 41.36, 0.63, 0.0000, 299.,  7.3, 0.5, -40.4, 0.47,
10955      4 41.68, 0.63, 0.0083, 330.,  0.0, 0.0, -39.0, 0.48,
10956      5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/
10957       DATA ((BCB(I,J),J=1,5),I=1,2)/
10958      1 10.79, -0.049, 0.040, 21.5, 1.23,
10959      2  9.92, -0.027, 0.013, 18.9, 1.07/
10960       DATA BCC/2.0164346,-0.5590311,0.0376279/
10961
10962 C...Total cross-section and nuclear slope parameter for pp and p-pbar
10963       NFIT=MIN(5,MAX(1,MSTP(31)))
10964       SIGP=BCS(NFIT,1)+BCS(NFIT,2)*(-0.25*PARU(1)**2*
10965      &(1.-0.25*BCS(NFIT,3)*PARU(1)**2)+(1.+0.5*BCS(NFIT,3)*PARU(1)**2)*
10966      &(LOG(VINT(2)/BCS(NFIT,4)))**2+BCS(NFIT,3)*
10967      &(LOG(VINT(2)/BCS(NFIT,4)))**4)/
10968      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
10969      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)*(LOG(VINT(2)/BCS(NFIT,4)))**2+
10970      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)+BCS(NFIT,5)*
10971      &VINT(2)**(BCS(NFIT,6)-1.)*SIN(0.5*PARU(1)*BCS(NFIT,6))
10972       SIGM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
10973      &COS(0.5*PARU(1)*BCS(NFIT,8))
10974       REFP=BCS(NFIT,2)*PARU(1)*LOG(VINT(2)/BCS(NFIT,4))/
10975      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
10976      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)+(LOG(VINT(2)/BCS(NFIT,4)))**2+
10977      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)-BCS(NFIT,5)*
10978      &VINT(2)**(BCS(NFIT,6)-1.)*COS(0.5*PARU(1)*BCS(NFIT,6))
10979       REFM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
10980      &SIN(0.5*PARU(1)*BCS(NFIT,8))
10981       SIGMA=SIGP-ISIGN(1,MINT(11)*MINT(12))*SIGM
10982       RHO=(REFP-ISIGN(1,MINT(11)*MINT(12))*REFM)/SIGMA
10983
10984 C...Nuclear slope parameter B, curvature C:
10985       NFIT=1
10986       IF(MSTP(31).GE.4) NFIT=2
10987       BP=BCB(NFIT,1)+BCB(NFIT,2)*LOG(VINT(2))+
10988      &BCB(NFIT,3)*(LOG(VINT(2)))**2
10989       BM=BCB(NFIT,4)+BCB(NFIT,5)*LOG(VINT(2))
10990       B=BP-ISIGN(1,MINT(11)*MINT(12))*SIGM/SIGP*(BM-BP)
10991       VINT(121)=B
10992       C=-0.5*BCC(2)/BCC(3)*(1.-SQRT(MAX(0.,1.+4.*BCC(3)/BCC(2)**2*
10993      &(1.E-03*VINT(1)-BCC(1)))))
10994       VINT(122)=C
10995
10996 C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).
10997       SIGEL=SIGMA**2*(1.+RHO**2)/(16.*PARU(1)*PARU(5)*B)
10998
10999 C...Single diffractive scattering cross-section from Goulianos:
11000       SIGSD=2.*0.68*(1.+36./VINT(2))*LOG(0.6+0.1*VINT(2))
11001
11002 C...Double diffractive scattering cross-section (essentially fixed by
11003 C...sigma-sd and sigma-el).
11004       SIGDD=SIGSD**2/(3.*SIGEL)
11005
11006 C...Total non-elastic, non-diffractive cross-section.
11007       SIGND=SIGMA-SIGDD-SIGSD-SIGEL
11008
11009 C...Rescale for pions.
11010       IF(IABS(MINT(11)).EQ.211.AND.IABS(MINT(12)).EQ.211) THEN
11011         SIGMA=4./9.*SIGMA
11012         SIGDD=4./9.*SIGDD
11013         SIGSD=4./9.*SIGSD
11014         SIGEL=4./9.*SIGEL
11015         SIGND=4./9.*SIGND
11016       ELSEIF(IABS(MINT(11)).EQ.211.OR.IABS(MINT(12)).EQ.211) THEN
11017         SIGMA=2./3.*SIGMA
11018         SIGDD=2./3.*SIGDD
11019         SIGSD=2./3.*SIGSD
11020         SIGEL=2./3.*SIGEL
11021         SIGND=2./3.*SIGND
11022       ENDIF
11023
11024 C...Save cross-sections in common block PYPARA.
11025       VINT(101)=SIGMA
11026       VINT(102)=SIGEL
11027       VINT(103)=SIGSD
11028       VINT(104)=SIGDD
11029       VINT(106)=SIGND
11030       XSEC(95,1)=SIGND
11031
11032       RETURN
11033       END
11034
11035 C*********************************************************************
11036
11037       SUBROUTINE PYMAXI
11038
11039 C...Finds optimal set of coefficients for kinematical variable selection
11040 C...and the maximum of the part of the differential cross-section used
11041 C...in the event weighting.
11042       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11043       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11044       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11045       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11046       COMMON/PYINT1/MINT(400),VINT(400)
11047       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11048       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11049       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11050       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
11051       COMMON/PYINT6/PROC(0:200)
11052       CHARACTER PROC*28
11053       CHARACTER CVAR(4)*4
11054       DIMENSION NPTS(4),MVARPT(200,4),VINTPT(200,30),SIGSPT(200),
11055      &NAREL(6),WTREL(6),WTMAT(6,6),COEFU(6),IACCMX(4),SIGSMX(4),
11056      &SIGSSM(3)
11057       SAVE
11058       DATA CVAR/'tau ','tau''','y*  ','cth '/
11059
11060 C...Select subprocess to study: skip cases not applicable.
11061       VINT(143)=1.
11062       VINT(144)=1.
11063       XSEC(0,1)=0.
11064       DO 350 ISUB=1,200
11065       IF(ISUB.GE.91.AND.ISUB.LE.95) THEN
11066         XSEC(ISUB,1)=VINT(ISUB+11)
11067         IF(MSUB(ISUB).NE.1) GOTO 350
11068         GOTO 340
11069       ELSEIF(ISUB.EQ.96) THEN
11070         IF(MINT(43).NE.4) GOTO 350
11071         IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0) GOTO 350
11072       ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
11073      &ISUB.EQ.53.OR.ISUB.EQ.68) THEN
11074         IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 350
11075       ELSE
11076         IF(MSUB(ISUB).NE.1) GOTO 350
11077       ENDIF
11078       MINT(1)=ISUB
11079       ISTSB=ISET(ISUB)
11080       IF(ISUB.EQ.96) ISTSB=2
11081       IF(MSTP(122).GE.2) WRITE(MSTU(11),1000) ISUB
11082
11083 C...Find resonances (explicit or implicit in cross-section).
11084       MINT(72)=0
11085       KFR1=0
11086       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3) THEN
11087         KFR1=KFPR(ISUB,1)
11088       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
11089         KFR1=25
11090       ENDIF
11091       IF(KFR1.NE.0) THEN
11092         TAUR1=PMAS(KFR1,1)**2/VINT(2)
11093         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
11094         MINT(72)=1
11095         MINT(73)=KFR1
11096         VINT(73)=TAUR1
11097         VINT(74)=GAMR1
11098       ENDIF
11099       IF(ISUB.EQ.141) THEN
11100         KFR2=23
11101         TAUR2=PMAS(KFR2,1)**2/VINT(2)
11102         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
11103         MINT(72)=2
11104         MINT(74)=KFR2
11105         VINT(75)=TAUR2
11106         VINT(76)=GAMR2
11107       ENDIF
11108
11109 C...Find product masses and minimum pT of process.
11110       SQM3=0.
11111       SQM4=0.
11112       MINT(71)=0
11113       VINT(71)=CKIN(3)
11114       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
11115         IF(KFPR(ISUB,1).NE.0) SQM3=PMAS(KFPR(ISUB,1),1)**2
11116         IF(KFPR(ISUB,2).NE.0) SQM4=PMAS(KFPR(ISUB,2),1)**2
11117         IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
11118         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
11119         IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
11120         IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08*PARP(82)
11121       ENDIF
11122       VINT(63)=SQM3
11123       VINT(64)=SQM4
11124
11125 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
11126       NPTS(1)=2+2*MINT(72)
11127       IF(MINT(43).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) NPTS(1)=1
11128       NPTS(2)=1
11129       IF(MINT(43).GE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) NPTS(2)=2
11130       NPTS(3)=1
11131       IF(MINT(43).EQ.4) NPTS(3)=3
11132       NPTS(4)=1
11133       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
11134       NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
11135
11136 C...Reset coefficients of cross-section weighting.
11137       DO 100 J=1,20
11138   100 COEF(ISUB,J)=0.
11139       COEF(ISUB,1)=1.
11140       COEF(ISUB,7)=0.5
11141       COEF(ISUB,8)=0.5
11142       COEF(ISUB,10)=1.
11143       COEF(ISUB,15)=1.
11144       MCTH=0
11145       MTAUP=0
11146       CTH=0.
11147       TAUP=0.
11148       SIGSAM=0.
11149
11150 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
11151 C...in grid of phase space points.
11152       CALL PYKLIM(1)
11153       NACC=0
11154       DO 120 ITRY=1,NTRY
11155       IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
11156         MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
11157         CALL PYKMAP(1,MTAU,0.5)
11158         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4)
11159       ENDIF
11160       IF((ISTSB.EQ.3.OR.ISTSB.EQ.4).AND.MOD(ITRY-1,NPTS(3)*NPTS(4)).
11161      &EQ.0) THEN
11162         MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
11163         CALL PYKMAP(4,MTAUP,0.5)
11164       ENDIF
11165       IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) CALL PYKLIM(2)
11166       IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
11167         MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
11168         CALL PYKMAP(2,MYST,0.5)
11169         CALL PYKLIM(3)
11170       ENDIF
11171       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
11172         MCTH=1+MOD(ITRY-1,NPTS(4))
11173         CALL PYKMAP(3,MCTH,0.5)
11174       ENDIF
11175       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
11176
11177 C...Calculate and store cross-section.
11178       MINT(51)=0
11179       CALL PYKLIM(0)
11180       IF(MINT(51).EQ.1) GOTO 120
11181       NACC=NACC+1
11182       MVARPT(NACC,1)=MTAU
11183       MVARPT(NACC,2)=MTAUP
11184       MVARPT(NACC,3)=MYST
11185       MVARPT(NACC,4)=MCTH
11186       DO 110 J=1,30
11187   110 VINTPT(NACC,J)=VINT(10+J)
11188       CALL PYSIGH(NCHN,SIGS)
11189       SIGSPT(NACC)=SIGS
11190       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
11191       IF(MSTP(122).GE.2) WRITE(MSTU(11),1100) MTAU,MTAUP,MYST,MCTH,
11192      &VINT(21),VINT(22),VINT(23),VINT(26),SIGS
11193   120 CONTINUE
11194       IF(SIGSAM.EQ.0.) THEN
11195         WRITE(MSTU(11),1200) ISUB
11196         STOP
11197       ENDIF
11198
11199 C...Calculate integrals in tau and y* over maximal phase space limits.
11200       TAUMIN=VINT(11)
11201       TAUMAX=VINT(31)
11202       ATAU1=LOG(TAUMAX/TAUMIN)
11203       ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
11204       IF(NPTS(1).GE.3) THEN
11205         ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
11206         ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
11207      &  GAMR1
11208       ENDIF
11209       IF(NPTS(1).GE.5) THEN
11210         ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
11211         ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
11212      &  GAMR2
11213       ENDIF
11214       YSTMIN=0.5*LOG(TAUMIN)
11215       YSTMAX=-YSTMIN
11216       AYST0=YSTMAX-YSTMIN
11217       AYST1=0.5*(YSTMAX-YSTMIN)**2
11218       AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
11219
11220 C...Reset. Sum up cross-sections in points calculated.
11221       DO 230 IVAR=1,4
11222       IF(NPTS(IVAR).EQ.1) GOTO 230
11223       IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 230
11224       NBIN=NPTS(IVAR)
11225       DO 130 J1=1,NBIN
11226       NAREL(J1)=0
11227       WTREL(J1)=0.
11228       COEFU(J1)=0.
11229       DO 130 J2=1,NBIN
11230   130 WTMAT(J1,J2)=0.
11231       DO 140 IACC=1,NACC
11232       IBIN=MVARPT(IACC,IVAR)
11233       NAREL(IBIN)=NAREL(IBIN)+1
11234       WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
11235
11236 C...Sum up tau cross-section pieces in points used.
11237       IF(IVAR.EQ.1) THEN
11238         TAU=VINTPT(IACC,11)
11239         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
11240         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
11241         IF(NBIN.GE.3) THEN
11242           WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
11243           WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
11244      &    ((TAU-TAUR1)**2+GAMR1**2)
11245         ENDIF
11246         IF(NBIN.GE.5) THEN
11247           WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
11248           WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
11249      &    ((TAU-TAUR2)**2+GAMR2**2)
11250         ENDIF
11251
11252 C...Sum up tau' cross-section pieces in points used.
11253       ELSEIF(IVAR.EQ.2) THEN
11254         TAU=VINTPT(IACC,11)
11255         TAUP=VINTPT(IACC,16)
11256         TAUPMN=VINTPT(IACC,6)
11257         TAUPMX=VINTPT(IACC,26)
11258         ATAUP1=LOG(TAUPMX/TAUPMN)
11259         ATAUP2=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
11260         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
11261         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*(1.-TAU/TAUP)**3/
11262      &  TAUP
11263
11264 C...Sum up y* and cos(theta-hat) cross-section pieces in points used.
11265       ELSEIF(IVAR.EQ.3) THEN
11266         YST=VINTPT(IACC,12)
11267         WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
11268         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST1)*(YSTMAX-YST)
11269         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
11270       ELSE
11271         RM34=2.*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2
11272         RSQM=1.+RM34
11273         CTHMAX=SQRT(1.-4.*VINT(71)**2/(TAUMAX*VINT(2)))
11274         CTHMIN=-CTHMAX
11275         IF(CTHMAX.GT.0.9999) RM34=MAX(RM34,2.*VINT(71)**2/
11276      &  (TAUMAX*VINT(2)))
11277         ACTH1=CTHMAX-CTHMIN
11278         ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
11279         ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
11280         ACTH4=1./MAX(RM34,RSQM-CTHMAX)-1./MAX(RM34,RSQM-CTHMIN)
11281         ACTH5=1./MAX(RM34,RSQM+CTHMIN)-1./MAX(RM34,RSQM+CTHMAX)
11282         CTH=VINTPT(IACC,13)
11283         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
11284         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/MAX(RM34,RSQM-CTH)
11285         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/MAX(RM34,RSQM+CTH)
11286         WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/MAX(RM34,RSQM-CTH)**2
11287         WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/MAX(RM34,RSQM+CTH)**2
11288       ENDIF
11289   140 CONTINUE
11290
11291 C...Check that equation system solvable; else trivial way out.
11292       IF(MSTP(122).GE.2) WRITE(MSTU(11),1300) CVAR(IVAR)
11293       MSOLV=1
11294       DO 150 IBIN=1,NBIN
11295       IF(MSTP(122).GE.2) WRITE(MSTU(11),1400) (WTMAT(IBIN,IRED),
11296      &IRED=1,NBIN),WTREL(IBIN)
11297   150 IF(NAREL(IBIN).EQ.0) MSOLV=0
11298       IF(MSOLV.EQ.0) THEN
11299         DO 160 IBIN=1,NBIN
11300   160   COEFU(IBIN)=1.
11301
11302 C...Solve to find relative importance of cross-section pieces.
11303       ELSE
11304         DO 170 IRED=1,NBIN-1
11305         DO 170 IBIN=IRED+1,NBIN
11306         RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
11307         WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
11308         DO 170 ICOE=IRED,NBIN
11309   170   WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
11310         DO 190 IRED=NBIN,1,-1
11311         DO 180 ICOE=IRED+1,NBIN
11312   180   WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
11313   190   COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
11314       ENDIF
11315
11316 C...Normalize coefficients, with piece shared democratically.
11317       COEFSU=0.
11318       DO 200 IBIN=1,NBIN
11319       COEFU(IBIN)=MAX(0.,COEFU(IBIN))
11320   200 COEFSU=COEFSU+COEFU(IBIN)
11321       IF(IVAR.EQ.1) IOFF=0
11322       IF(IVAR.EQ.2) IOFF=14
11323       IF(IVAR.EQ.3) IOFF=6
11324       IF(IVAR.EQ.4) IOFF=9
11325       IF(COEFSU.GT.0.) THEN
11326         DO 210 IBIN=1,NBIN
11327   210   COEF(ISUB,IOFF+IBIN)=PARP(121)/NBIN+(1.-PARP(121))*COEFU(IBIN)/
11328      &  COEFSU
11329       ELSE
11330         DO 220 IBIN=1,NBIN
11331   220   COEF(ISUB,IOFF+IBIN)=1./NBIN
11332       ENDIF
11333       IF(MSTP(122).GE.2) WRITE(MSTU(11),1500) CVAR(IVAR),
11334      &(COEF(ISUB,IOFF+IBIN),IBIN=1,NBIN)
11335   230 CONTINUE
11336
11337 C...Find two most promising maxima among points previously determined.
11338       DO 240 J=1,4
11339       IACCMX(J)=0
11340   240 SIGSMX(J)=0.
11341       NMAX=0
11342       DO 290 IACC=1,NACC
11343       DO 250 J=1,30
11344   250 VINT(10+J)=VINTPT(IACC,J)
11345       CALL PYSIGH(NCHN,SIGS)
11346       IEQ=0
11347       DO 260 IMV=1,NMAX
11348   260 IF(ABS(SIGS-SIGSMX(IMV)).LT.1E-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
11349       IF(IEQ.EQ.0) THEN
11350         DO 270 IMV=NMAX,1,-1
11351         IIN=IMV+1
11352         IF(SIGS.LE.SIGSMX(IMV)) GOTO 280
11353         IACCMX(IMV+1)=IACCMX(IMV)
11354   270   SIGSMX(IMV+1)=SIGSMX(IMV)
11355         IIN=1
11356   280   IACCMX(IIN)=IACC
11357         SIGSMX(IIN)=SIGS
11358         IF(NMAX.LE.1) NMAX=NMAX+1
11359       ENDIF
11360   290 CONTINUE
11361
11362 C...Read out starting position for search.
11363       IF(MSTP(122).GE.2) WRITE(MSTU(11),1600)
11364       SIGSAM=SIGSMX(1)
11365       DO 330 IMAX=1,NMAX
11366       IACC=IACCMX(IMAX)
11367       MTAU=MVARPT(IACC,1)
11368       MTAUP=MVARPT(IACC,2)
11369       MYST=MVARPT(IACC,3)
11370       MCTH=MVARPT(IACC,4)
11371       VTAU=0.5
11372       VYST=0.5
11373       VCTH=0.5
11374       VTAUP=0.5
11375
11376 C...Starting point and step size in parameter space.
11377       DO 320 IRPT=1,2
11378       DO 310 IVAR=1,4
11379       IF(NPTS(IVAR).EQ.1) GOTO 310
11380       IF(IVAR.EQ.1) VVAR=VTAU
11381       IF(IVAR.EQ.2) VVAR=VTAUP
11382       IF(IVAR.EQ.3) VVAR=VYST
11383       IF(IVAR.EQ.4) VVAR=VCTH
11384       IF(IVAR.EQ.1) MVAR=MTAU
11385       IF(IVAR.EQ.2) MVAR=MTAUP
11386       IF(IVAR.EQ.3) MVAR=MYST
11387       IF(IVAR.EQ.4) MVAR=MCTH
11388       IF(IRPT.EQ.1) VDEL=0.1
11389       IF(IRPT.EQ.2) VDEL=MAX(0.01,MIN(0.05,VVAR-0.02,0.98-VVAR))
11390       IF(IRPT.EQ.1) VMAR=0.02
11391       IF(IRPT.EQ.2) VMAR=0.002
11392       IMOV0=1
11393       IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
11394       DO 300 IMOV=IMOV0,8
11395
11396 C...Define new point in parameter space.
11397       IF(IMOV.EQ.0) THEN
11398         INEW=2
11399         VNEW=VVAR
11400       ELSEIF(IMOV.EQ.1) THEN
11401         INEW=3
11402         VNEW=VVAR+VDEL
11403       ELSEIF(IMOV.EQ.2) THEN
11404         INEW=1
11405         VNEW=VVAR-VDEL
11406       ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
11407      &VVAR+2.*VDEL.LT.1.-VMAR) THEN
11408         VVAR=VVAR+VDEL
11409         SIGSSM(1)=SIGSSM(2)
11410         SIGSSM(2)=SIGSSM(3)
11411         INEW=3
11412         VNEW=VVAR+VDEL
11413       ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
11414      &VVAR-2.*VDEL.GT.VMAR) THEN
11415         VVAR=VVAR-VDEL
11416         SIGSSM(3)=SIGSSM(2)
11417         SIGSSM(2)=SIGSSM(1)
11418         INEW=1
11419         VNEW=VVAR-VDEL
11420       ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
11421         VDEL=0.5*VDEL
11422         VVAR=VVAR+VDEL
11423         SIGSSM(1)=SIGSSM(2)
11424         INEW=2
11425         VNEW=VVAR
11426       ELSE
11427         VDEL=0.5*VDEL
11428         VVAR=VVAR-VDEL
11429         SIGSSM(3)=SIGSSM(2)
11430         INEW=2
11431         VNEW=VVAR
11432       ENDIF
11433
11434 C...Convert to relevant variables and find derived new limits.
11435       IF(IVAR.EQ.1) THEN
11436         VTAU=VNEW
11437         CALL PYKMAP(1,MTAU,VTAU)
11438         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4)
11439       ENDIF
11440       IF(IVAR.LE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) THEN
11441         IF(IVAR.EQ.2) VTAUP=VNEW
11442         CALL PYKMAP(4,MTAUP,VTAUP)
11443       ENDIF
11444       IF(IVAR.LE.2) CALL PYKLIM(2)
11445       IF(IVAR.LE.3) THEN
11446         IF(IVAR.EQ.3) VYST=VNEW
11447         CALL PYKMAP(2,MYST,VYST)
11448         CALL PYKLIM(3)
11449       ENDIF
11450       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
11451         IF(IVAR.EQ.4) VCTH=VNEW
11452         CALL PYKMAP(3,MCTH,VCTH)
11453       ENDIF
11454       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
11455
11456 C...Evaluate cross-section. Save new maximum. Final maximum.
11457       CALL PYSIGH(NCHN,SIGS)
11458       SIGSSM(INEW)=SIGS
11459       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
11460       IF(MSTP(122).GE.2) WRITE(MSTU(11),1700) IMAX,IVAR,MVAR,IMOV,
11461      &VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
11462   300 CONTINUE
11463   310 CONTINUE
11464   320 CONTINUE
11465       IF(IMAX.EQ.1) SIGS11=SIGSAM
11466   330 CONTINUE
11467       XSEC(ISUB,1)=1.05*SIGSAM
11468   340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
11469   350 CONTINUE
11470
11471 C...Print summary table.
11472       IF(MSTP(122).GE.1) THEN
11473         WRITE(MSTU(11),1800)
11474         WRITE(MSTU(11),1900)
11475         DO 360 ISUB=1,200
11476         IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 360
11477         IF(ISUB.EQ.96.AND.MINT(43).NE.4) GOTO 360
11478         IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 360
11479         IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.
11480      &  ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 360
11481         WRITE(MSTU(11),2000) ISUB,PROC(ISUB),XSEC(ISUB,1)
11482   360   CONTINUE
11483         WRITE(MSTU(11),2100)
11484       ENDIF
11485
11486 C...Format statements for maximization results.
11487  1000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
11488      &'subprocess no',I4/1X,'Coefficient modes     tau',10X,'y*',9X,
11489      &'cth',9X,'tau''',7X,'sigma')
11490  1100 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,E12.4)
11491  1200 FORMAT(1X,'Error: requested subprocess ',I3,' has vanishing ',
11492      &'cross-section.'/1X,'Execution stopped!')
11493  1300 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
11494  1400 FORMAT(1X,1P,7E11.3)
11495  1500 FORMAT(1X,'Result for ',A4,':',6F9.4)
11496  1600 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
11497      &'MOD MOV   VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
11498  1700 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,E12.4)
11499  1800 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
11500      &'cross-section maximum search',1X,8('*'))
11501  1900 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I  ISUB  ',
11502      &'Subprocess name',15X,'I  Maximum value  I'/11X,'I',38X,'I',
11503      &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
11504  2000 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,E12.4,3X,'I')
11505  2100 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
11506
11507       RETURN
11508       END
11509
11510 C*********************************************************************
11511
11512       SUBROUTINE PYOVLY(MOVLY)
11513
11514 C...Initializes multiplicity distribution and selects mutliplicity
11515 C...of overlayed events, i.e. several events occuring at the same
11516 C...beam crossing.
11517       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11518       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11519       COMMON/PYINT1/MINT(400),VINT(400)
11520       DIMENSION WTI(0:100)
11521       SAVE
11522
11523 C...Sum of allowed cross-sections for overlayed events.
11524       IF(MOVLY.EQ.1) THEN
11525         VINT(131)=VINT(106)
11526         IF(MSTP(132).GE.2) VINT(131)=VINT(131)+VINT(104)
11527         IF(MSTP(132).GE.3) VINT(131)=VINT(131)+VINT(103)
11528         IF(MSTP(132).GE.4) VINT(131)=VINT(131)+VINT(102)
11529
11530 C...Initialize multiplicity distribution for unbiased events.
11531         IF(MSTP(133).EQ.1) THEN
11532           XNAVE=VINT(131)*PARP(131)
11533           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
11534           WTI(0)=EXP(-MIN(50.,XNAVE))
11535           WTS=0.
11536           WTN=0.
11537           DO 100 I=1,100
11538           WTI(I)=WTI(I-1)*XNAVE/I
11539           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 110
11540           WTS=WTS+WTI(I)
11541           WTN=WTN+WTI(I)*I
11542   100     IMAX=I
11543   110     VINT(132)=XNAVE
11544           VINT(133)=WTN/WTS
11545           VINT(134)=WTS
11546
11547 C...Initialize mutiplicity distribution for biased events.
11548         ELSEIF(MSTP(133).EQ.2) THEN
11549           XNAVE=VINT(131)*PARP(131)
11550           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
11551           WTI(1)=EXP(-MIN(50.,XNAVE))*XNAVE
11552           WTS=WTI(1)
11553           WTN=WTI(1)
11554           DO 120 I=2,100
11555           WTI(I)=WTI(I-1)*XNAVE/(I-1)
11556           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 130
11557           WTS=WTS+WTI(I)
11558           WTN=WTN+WTI(I)*I
11559   120     IMAX=I
11560   130     VINT(132)=XNAVE
11561           VINT(133)=WTN/WTS
11562           VINT(134)=WTS
11563         ENDIF
11564
11565 C...Pick multiplicity of overlayed events.
11566       ELSE
11567         IF(MSTP(133).EQ.0) THEN
11568           MINT(81)=MAX(1,MSTP(134))
11569         ELSE
11570           WTR=WTS*RLU(0)
11571           DO 140 I=1,IMAX
11572           MINT(81)=I
11573           WTR=WTR-WTI(I)
11574           IF(WTR.LE.0.) GOTO 150
11575   140     CONTINUE
11576   150     CONTINUE
11577         ENDIF
11578       ENDIF
11579
11580 C...Format statement for error message.
11581  1000 FORMAT(1X,'Warning: requested average number of events per bunch',
11582      &'crossing too large, ',1P,E12.4)
11583
11584       RETURN
11585       END
11586
11587 C*********************************************************************
11588
11589       SUBROUTINE PYRAND
11590
11591 C...Generates quantities characterizing the high-pT scattering at the
11592 C...parton level according to the matrix elements. Chooses incoming,
11593 C...reacting partons, their momentum fractions and one of the possible
11594 C...subprocesses.
11595       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11596       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11597       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11598       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11599       COMMON/PYINT1/MINT(400),VINT(400)
11600       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11601       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11602       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11603       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
11604       SAVE
11605
11606 C...Initial values, specifically for (first) semihard interaction.
11607       MINT(17)=0
11608       MINT(18)=0
11609       VINT(143)=1.
11610       VINT(144)=1.
11611       IF(MSUB(95).EQ.1.OR.MINT(82).GE.2) CALL PYMULT(2)
11612       ISUB=0
11613   100 MINT(51)=0
11614
11615 C...Choice of process type - first event of overlay.
11616       IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
11617         RSUB=XSEC(0,1)*RLU(0)
11618         DO 110 I=1,200
11619         IF(MSUB(I).NE.1) GOTO 110
11620         ISUB=I
11621         RSUB=RSUB-XSEC(I,1)
11622         IF(RSUB.LE.0.) GOTO 120
11623   110   CONTINUE
11624   120   IF(ISUB.EQ.95) ISUB=96
11625
11626 C...Choice of inclusive process type - overlayed events.
11627       ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
11628         RSUB=VINT(131)*RLU(0)
11629         ISUB=96
11630         IF(RSUB.GT.VINT(106)) ISUB=93
11631         IF(RSUB.GT.VINT(106)+VINT(104)) ISUB=92
11632         IF(RSUB.GT.VINT(106)+VINT(104)+VINT(103)) ISUB=91
11633       ENDIF
11634       IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
11635       IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
11636       MINT(1)=ISUB
11637
11638 C...Find resonances (explicit or implicit in cross-section).
11639       MINT(72)=0
11640       KFR1=0
11641       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
11642         KFR1=KFPR(ISUB,1)
11643       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
11644         KFR1=25
11645       ENDIF
11646       IF(KFR1.NE.0) THEN
11647         TAUR1=PMAS(KFR1,1)**2/VINT(2)
11648         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
11649         MINT(72)=1
11650         MINT(73)=KFR1
11651         VINT(73)=TAUR1
11652         VINT(74)=GAMR1
11653       ENDIF
11654       IF(ISUB.EQ.141) THEN
11655         KFR2=23
11656         TAUR2=PMAS(KFR2,1)**2/VINT(2)
11657         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
11658         MINT(72)=2
11659         MINT(74)=KFR2
11660         VINT(75)=TAUR2
11661         VINT(76)=GAMR2
11662       ENDIF
11663
11664 C...Find product masses and minimum pT of process,
11665 C...optionally with broadening according to a truncated Breit-Wigner.
11666       VINT(63)=0.
11667       VINT(64)=0.
11668       MINT(71)=0
11669       VINT(71)=CKIN(3)
11670       IF(MINT(82).GE.2) VINT(71)=0.
11671       IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
11672         DO 130 I=1,2
11673         IF(KFPR(ISUB,I).EQ.0) THEN
11674         ELSEIF(MSTP(42).LE.0) THEN
11675           VINT(62+I)=PMAS(KFPR(ISUB,I),1)**2
11676         ELSE
11677           VINT(62+I)=ULMASS(KFPR(ISUB,I))**2
11678         ENDIF
11679   130   CONTINUE
11680         IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
11681         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
11682       ENDIF
11683
11684       IF(ISET(ISUB).EQ.0) THEN
11685 C...Double or single diffractive, or elastic scattering:
11686 C...choose m^2 according to 1/m^2 (diffractive), constant (elastic)
11687         IS=INT(1.5+RLU(0))
11688         VINT(63)=VINT(3)**2
11689         VINT(64)=VINT(4)**2
11690         IF(ISUB.EQ.92.OR.ISUB.EQ.93) VINT(62+IS)=PARP(111)**2
11691         IF(ISUB.EQ.93) VINT(65-IS)=PARP(111)**2
11692         SH=VINT(2)
11693         SQM1=VINT(3)**2
11694         SQM2=VINT(4)**2
11695         SQM3=VINT(63)
11696         SQM4=VINT(64)
11697         SQLA12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2
11698         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
11699         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
11700         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
11701         THL=0.5*(THTER1-THTER2)
11702         THU=0.5*(THTER1+THTER2)
11703         THM=MIN(MAX(THL,PARP(101)),THU)
11704         JTMAX=0
11705         IF(ISUB.EQ.92.OR.ISUB.EQ.93) JTMAX=ISUB-91
11706         DO 140 JT=1,JTMAX
11707         MINT(13+3*JT-IS*(2*JT-3))=1
11708         SQMMIN=VINT(59+3*JT-IS*(2*JT-3))
11709         SQMI=VINT(8-3*JT+IS*(2*JT-3))**2
11710         SQMJ=VINT(3*JT-1-IS*(2*JT-3))**2
11711         SQMF=VINT(68-3*JT+IS*(2*JT-3))
11712         SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-
11713      &  SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)
11714         QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+
11715      &  SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))
11716         SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))
11717         IF(ABS(QUAR/SQUA**2).LT.1.E-06) SQMMAX=0.5*QUAR/SQUA
11718         SQMMAX=MIN(SQMMAX,(VINT(1)-SQRT(SQMF))**2)
11719         VINT(59+3*JT-IS*(2*JT-3))=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)
11720   140   CONTINUE
11721 C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).
11722         SQM3=VINT(63)
11723         SQM4=VINT(64)
11724         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
11725         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
11726         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
11727         THL=0.5*(THTER1-THTER2)
11728         THU=0.5*(THTER1+THTER2)
11729         B=VINT(121)
11730         C=VINT(122)
11731         IF(ISUB.EQ.92.OR.ISUB.EQ.93) THEN
11732           B=0.5*B
11733           C=0.5*C
11734         ENDIF
11735         THM=MIN(MAX(THL,PARP(101)),THU)
11736         EXPTH=0.
11737         THARG=B*(THM-THU)
11738         IF(THARG.GT.-20.) EXPTH=EXP(THARG)
11739   150   TH=THU+LOG(EXPTH+(1.-EXPTH)*RLU(0))/B
11740         TH=MAX(THM,MIN(THU,TH))
11741         RATLOG=MIN((B+C*(TH+THM))*(TH-THM),(B+C*(TH+THU))*(TH-THU))
11742         IF(RATLOG.LT.LOG(RLU(0))) GOTO 150
11743         VINT(21)=1.
11744         VINT(22)=0.
11745         VINT(23)=MIN(1.,MAX(-1.,(2.*TH-THTER1)/THTER2))
11746
11747 C...Note: in the following, by In is meant the integral over the
11748 C...quantity multiplying coefficient cn.
11749 C...Choose tau according to h1(tau)/tau, where
11750 C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +
11751 C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
11752 C...I0/I4*c4*1/(tau+tau_R') +
11753 C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and
11754 C...c0 + c1 + c2 + c3 + c4 + c5 = 1
11755       ELSEIF(ISET(ISUB).GE.1.AND.ISET(ISUB).LE.4) THEN
11756         CALL PYKLIM(1)
11757         IF(MINT(51).NE.0) GOTO 100
11758         RTAU=RLU(0)
11759         MTAU=1
11760         IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
11761         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
11762         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
11763         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
11764      &  MTAU=5
11765         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
11766      &  COEF(ISUB,5)) MTAU=6
11767         CALL PYKMAP(1,MTAU,RLU(0))
11768
11769 C...2 -> 3, 4 processes:
11770 C...Choose tau' according to h4(tau,tau')/tau', where
11771 C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and
11772 C...c0 + c1 = 1.
11773         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
11774           CALL PYKLIM(4)
11775           IF(MINT(51).NE.0) GOTO 100
11776           RTAUP=RLU(0)
11777           MTAUP=1
11778           IF(RTAUP.GT.COEF(ISUB,15)) MTAUP=2
11779           CALL PYKMAP(4,MTAUP,RLU(0))
11780         ENDIF
11781
11782 C...Choose y* according to h2(y*), where
11783 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
11784 C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.
11785         CALL PYKLIM(2)
11786         IF(MINT(51).NE.0) GOTO 100
11787         RYST=RLU(0)
11788         MYST=1
11789         IF(RYST.GT.COEF(ISUB,7)) MYST=2
11790         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
11791         CALL PYKMAP(2,MYST,RLU(0))
11792
11793 C...2 -> 2 processes:
11794 C...Choose cos(theta-hat) (cth) according to h3(cth), where
11795 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
11796 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
11797 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
11798 C...and c0 + c1 + c2 + c3 + c4 = 1.
11799         CALL PYKLIM(3)
11800         IF(MINT(51).NE.0) GOTO 100
11801         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
11802           RCTH=RLU(0)
11803           MCTH=1
11804           IF(RCTH.GT.COEF(ISUB,10)) MCTH=2
11805           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)) MCTH=3
11806           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)) MCTH=4
11807           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)+
11808      &    COEF(ISUB,13)) MCTH=5
11809           CALL PYKMAP(3,MCTH,RLU(0))
11810         ENDIF
11811
11812 C...Low-pT or multiple interactions (first semihard interaction).
11813       ELSEIF(ISET(ISUB).EQ.5) THEN
11814         CALL PYMULT(3)
11815         ISUB=MINT(1)
11816       ENDIF
11817
11818 C...Choose azimuthal angle.
11819       VINT(24)=PARU(2)*RLU(0)
11820
11821 C...Check against user cuts on kinematics at parton level.
11822       MINT(51)=0
11823       IF(ISUB.LE.90.OR.ISUB.GT.100) CALL PYKLIM(0)
11824       IF(MINT(51).NE.0) GOTO 100
11825       IF(MINT(82).EQ.1.AND.MSTP(141).GE.1) THEN
11826         MCUT=0
11827         IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
11828      &  CALL PYKCUT(MCUT)
11829         IF(MCUT.NE.0) GOTO 100
11830       ENDIF
11831
11832 C...Calculate differential cross-section for different subprocesses.
11833       CALL PYSIGH(NCHN,SIGS)
11834
11835 C...Calculations for Monte Carlo estimate of all cross-sections.
11836       IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
11837         XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
11838       ELSEIF(MINT(82).EQ.1) THEN
11839         XSEC(ISUB,2)=XSEC(ISUB,2)+XSEC(ISUB,1)
11840       ENDIF
11841
11842 C...Multiple interactions: store results of cross-section calculation.
11843       IF(MINT(43).EQ.4.AND.MSTP(82).GE.3) THEN
11844         VINT(153)=SIGS
11845         CALL PYMULT(4)
11846       ENDIF
11847
11848 C...Weighting using estimate of maximum of differential cross-section.
11849       VIOL=SIGS/XSEC(ISUB,1)
11850       IF(VIOL.LT.RLU(0)) GOTO 100
11851
11852 C...Check for possible violation of estimated maximum of differential
11853 C...cross-section used in weighting.
11854       IF(MSTP(123).LE.0) THEN
11855         IF(VIOL.GT.1.) THEN
11856           WRITE(MSTU(11),1000) VIOL,NGEN(0,3)+1
11857           WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
11858           STOP
11859         ENDIF
11860       ELSEIF(MSTP(123).EQ.1) THEN
11861         IF(VIOL.GT.VINT(108)) THEN
11862           VINT(108)=VIOL
11863 C          IF(VIOL.GT.1.) THEN
11864 C            WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
11865 C            WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),
11866 C     &      VINT(26)
11867 C          ENDIF
11868         ENDIF
11869       ELSEIF(VIOL.GT.VINT(108)) THEN
11870         VINT(108)=VIOL
11871         IF(VIOL.GT.1.) THEN
11872           XDIF=XSEC(ISUB,1)*(VIOL-1.)
11873           XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
11874           IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
11875      &    XSEC(0,1)=XSEC(0,1)+XDIF
11876 C          WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
11877 C          WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
11878 C          IF(ISUB.LE.9) THEN
11879 C            WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)
11880 C          ELSEIF(ISUB.LE.99) THEN
11881 C            WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)
11882 C          ELSE
11883 C            WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)
11884 C          ENDIF
11885           VINT(108)=1.
11886         ENDIF
11887       ENDIF
11888
11889 C...Multiple interactions: choose impact parameter.
11890       VINT(148)=1.
11891       IF(MINT(43).EQ.4.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.MSTP(82).GE.3)
11892      &THEN
11893         CALL PYMULT(5)
11894         IF(VINT(150).LT.RLU(0)) GOTO 100
11895       ENDIF
11896       IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
11897         IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
11898         IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
11899       ENDIF
11900       IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
11901
11902 C...Choose flavour of reacting partons (and subprocess).
11903       RSIGS=SIGS*RLU(0)
11904       QT2=VINT(48)
11905       RQQBAR=PARP(87)*(1.-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
11906       IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
11907      &RLU(0).GT.RQQBAR)) THEN
11908         DO 190 ICHN=1,NCHN
11909         KFL1=ISIG(ICHN,1)
11910         KFL2=ISIG(ICHN,2)
11911         MINT(2)=ISIG(ICHN,3)
11912         RSIGS=RSIGS-SIGH(ICHN)
11913         IF(RSIGS.LE.0.) GOTO 210
11914   190   CONTINUE
11915
11916 C...Multiple interactions: choose qqbar preferentially at small pT.
11917       ELSEIF(ISUB.EQ.96) THEN
11918         CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
11919         CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
11920         MINT(1)=11
11921         MINT(2)=1
11922         IF(KFL1.EQ.KFL2.AND.RLU(0).LT.0.5) MINT(2)=2
11923
11924 C...Low-pT: choose string drawing configuration.
11925       ELSE
11926         KFL1=21
11927         KFL2=21
11928         RSIGS=6.*RLU(0)
11929         MINT(2)=1
11930         IF(RSIGS.GT.1.) MINT(2)=2
11931         IF(RSIGS.GT.2.) MINT(2)=3
11932       ENDIF
11933
11934 C...Reassign QCD process. Partons before initial state radiation.
11935   210 IF(MINT(2).GT.10) THEN
11936         MINT(1)=MINT(2)/10
11937         MINT(2)=MOD(MINT(2),10)
11938       ENDIF
11939       MINT(15)=KFL1
11940       MINT(16)=KFL2
11941       MINT(13)=MINT(15)
11942       MINT(14)=MINT(16)
11943       VINT(141)=VINT(41)
11944       VINT(142)=VINT(42)
11945
11946 C...Format statements for differential cross-section maximum violations.
11947  1000 FORMAT(1X,'Error: maximum violated by',1P,E11.3,1X,
11948      &'in event',1X,I7,'.'/1X,'Execution stopped!')
11949  1100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
11950      &E11.3,', y* =',E11.3,', cthe = ',0P,F11.7,', tau'' =',1P,E11.3)
11951 C 1200 FORMAT(1X,'Warning: maximum violated by',1P,E11.3,1X,
11952 C     &'in event',1X,I7)
11953 C 1300 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,E11.3)
11954 C 1400 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,E11.3)
11955 C 1500 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,E11.3)
11956
11957       RETURN
11958       END
11959
11960 C*********************************************************************
11961
11962       SUBROUTINE PYSCAT
11963
11964 C...Finds outgoing flavours and event type; sets up the kinematics
11965 C...and colour flow of the hard scattering.
11966       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
11967       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11968       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11969       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
11970       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11971       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11972       COMMON/PYINT1/MINT(400),VINT(400)
11973       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11974       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11975       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11976       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
11977       DIMENSION WDTP(0:40),WDTE(0:40,0:5),PMQ(2),Z(2),CTHE(2),PHI(2)
11978       SAVE
11979
11980 C...Choice of subprocess, number of documentation lines.
11981       ISUB=MINT(1)
11982       IDOC=6+ISET(ISUB)
11983       IF(ISUB.EQ.95) IDOC=8
11984       MINT(3)=IDOC-6
11985       IF(IDOC.GE.9) IDOC=IDOC+2
11986       MINT(4)=IDOC
11987       IPU1=MINT(84)+1
11988       IPU2=MINT(84)+2
11989       IPU3=MINT(84)+3
11990       IPU4=MINT(84)+4
11991       IPU5=MINT(84)+5
11992       IPU6=MINT(84)+6
11993
11994 C...Reset K, P and V vectors. Store incoming particles.
11995       DO 100 JT=1,MSTP(126)+10
11996       I=MINT(83)+JT
11997       DO 100 J=1,5
11998       K(I,J)=0
11999       P(I,J)=0.
12000   100 V(I,J)=0.
12001       DO 110 JT=1,2
12002       I=MINT(83)+JT
12003       K(I,1)=21
12004       K(I,2)=MINT(10+JT)
12005       P(I,1)=0.
12006       P(I,2)=0.
12007       P(I,5)=VINT(2+JT)
12008       P(I,3)=VINT(5)*(-1)**(JT+1)
12009   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
12010       MINT(6)=2
12011       KFRES=0
12012
12013 C...Store incoming partons in their CM-frame.
12014       SH=VINT(44)
12015       SHR=SQRT(SH)
12016       SHP=VINT(26)*VINT(2)
12017       SHPR=SQRT(SHP)
12018       SHUSER=SHR
12019       IF(ISET(ISUB).GE.3) SHUSER=SHPR
12020       DO 120 JT=1,2
12021       I=MINT(84)+JT
12022       K(I,1)=14
12023       K(I,2)=MINT(14+JT)
12024       K(I,3)=MINT(83)+2+JT
12025   120 P(I,5)=ULMASS(K(I,2))
12026       IF(P(IPU1,5)+P(IPU2,5).GE.SHUSER) THEN
12027         P(IPU1,5)=0.
12028         P(IPU2,5)=0.
12029       ENDIF
12030       P(IPU1,4)=0.5*(SHUSER+(P(IPU1,5)**2-P(IPU2,5)**2)/SHUSER)
12031       P(IPU1,3)=SQRT(MAX(0.,P(IPU1,4)**2-P(IPU1,5)**2))
12032       P(IPU2,4)=SHUSER-P(IPU1,4)
12033       P(IPU2,3)=-P(IPU1,3)
12034
12035 C...Copy incoming partons to documentation lines.
12036       DO 130 JT=1,2
12037       I1=MINT(83)+4+JT
12038       I2=MINT(84)+JT
12039       K(I1,1)=21
12040       K(I1,2)=K(I2,2)
12041       K(I1,3)=I1-2
12042       DO 130 J=1,5
12043   130 P(I1,J)=P(I2,J)
12044
12045 C...Choose new quark flavour for relevant annihilation graphs.
12046       IF(ISUB.EQ.12.OR.ISUB.EQ.53) THEN
12047         CALL PYWIDT(21,SHR,WDTP,WDTE)
12048         RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*RLU(0)
12049         DO 140 I=1,2*MSTP(1)
12050         KFLQ=I
12051         RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
12052         IF(RKFL.LE.0.) GOTO 150
12053   140   CONTINUE
12054   150   CONTINUE
12055       ENDIF
12056
12057 C...Final state flavours and colour flow: default values.
12058       JS=1
12059       MINT(21)=MINT(15)
12060       MINT(22)=MINT(16)
12061       MINT(23)=0
12062       MINT(24)=0
12063       KCC=20
12064       KCS=ISIGN(1,MINT(15))
12065
12066       IF(ISUB.LE.10) THEN
12067       IF(ISUB.EQ.1) THEN
12068 C...f + fb -> gamma*/Z0.
12069         KFRES=23
12070
12071       ELSEIF(ISUB.EQ.2) THEN
12072 C...f + fb' -> W+/- .
12073         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12074         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12075         KFRES=ISIGN(24,KCH1+KCH2)
12076
12077       ELSEIF(ISUB.EQ.3) THEN
12078 C...f + fb -> H0.
12079         KFRES=25
12080
12081       ELSEIF(ISUB.EQ.4) THEN
12082 C...gamma + W+/- -> W+/-.
12083
12084       ELSEIF(ISUB.EQ.5) THEN
12085 C...Z0 + Z0 -> H0.
12086         XH=SH/SHP
12087         MINT(21)=MINT(15)
12088         MINT(22)=MINT(16)
12089         PMQ(1)=ULMASS(MINT(21))
12090         PMQ(2)=ULMASS(MINT(22))
12091   240   JT=INT(1.5+RLU(0))
12092         ZMIN=2.*PMQ(JT)/SHPR
12093         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12094         ZMAX=MIN(1.-XH,ZMAX)
12095         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12096         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12097      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 240
12098         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12099         IF(SQC1.LT.1.E-8) GOTO 240
12100         C1=SQRT(SQC1)
12101         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12102         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12103         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12104         Z(3-JT)=1.-XH/(1.-Z(JT))
12105         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12106         IF(SQC1.LT.1.E-8) GOTO 240
12107         C1=SQRT(SQC1)
12108         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12109         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12110         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12111         PHIR=PARU(2)*RLU(0)
12112         CPHI=COS(PHIR)
12113         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12114         Z1=2.-Z(JT)
12115         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12116         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12117         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12118      &  PMQ(3-JT)**2/SHP))
12119         ZMIN=2.*PMQ(3-JT)/SHPR
12120         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12121         ZMAX=MIN(1.-XH,ZMAX)
12122         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 240
12123         KCC=22
12124         KFRES=25
12125
12126       ELSEIF(ISUB.EQ.6) THEN
12127 C...Z0 + W+/- -> W+/-.
12128
12129       ELSEIF(ISUB.EQ.7) THEN
12130 C...W+ + W- -> Z0.
12131
12132       ELSEIF(ISUB.EQ.8) THEN
12133 C...W+ + W- -> H0.
12134         XH=SH/SHP
12135   250   DO 280 JT=1,2
12136         I=MINT(14+JT)
12137         IA=IABS(I)
12138         IF(IA.LE.10) THEN
12139           RVCKM=VINT(180+I)*RLU(0)
12140           DO 270 J=1,MSTP(1)
12141           IB=2*J-1+MOD(IA,2)
12142           IPM=(5-ISIGN(1,I))/2
12143           IDC=J+MDCY(IA,2)+2
12144           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
12145           MINT(20+JT)=ISIGN(IB,I)
12146           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12147           IF(RVCKM.LE.0.) GOTO 280
12148   270     CONTINUE
12149         ELSE
12150           IB=2*((IA+1)/2)-1+MOD(IA,2)
12151           MINT(20+JT)=ISIGN(IB,I)
12152         ENDIF
12153   280   PMQ(JT)=ULMASS(MINT(20+JT))
12154         JT=INT(1.5+RLU(0))
12155         ZMIN=2.*PMQ(JT)/SHPR
12156         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12157         ZMAX=MIN(1.-XH,ZMAX)
12158         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12159         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12160      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 250
12161         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12162         IF(SQC1.LT.1.E-8) GOTO 250
12163         C1=SQRT(SQC1)
12164         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12165         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12166         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12167         Z(3-JT)=1.-XH/(1.-Z(JT))
12168         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12169         IF(SQC1.LT.1.E-8) GOTO 250
12170         C1=SQRT(SQC1)
12171         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12172         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12173         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12174         PHIR=PARU(2)*RLU(0)
12175         CPHI=COS(PHIR)
12176         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12177         Z1=2.-Z(JT)
12178         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12179         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12180         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12181      &  PMQ(3-JT)**2/SHP))
12182         ZMIN=2.*PMQ(3-JT)/SHPR
12183         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12184         ZMAX=MIN(1.-XH,ZMAX)
12185         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 250
12186         KCC=22
12187         KFRES=25
12188       ENDIF
12189
12190       ELSEIF(ISUB.LE.20) THEN
12191       IF(ISUB.EQ.11) THEN
12192 C...f + f' -> f + f'; th = (p(f)-p(f))**2.
12193         KCC=MINT(2)
12194         IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12195
12196       ELSEIF(ISUB.EQ.12) THEN
12197 C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.
12198         MINT(21)=ISIGN(KFLQ,MINT(15))
12199         MINT(22)=-MINT(21)
12200         KCC=4
12201
12202       ELSEIF(ISUB.EQ.13) THEN
12203 C...f + fb -> g + g; th arbitrary.
12204         MINT(21)=21
12205         MINT(22)=21
12206         KCC=MINT(2)+4
12207
12208       ELSEIF(ISUB.EQ.14) THEN
12209 C...f + fb -> g + gam; th arbitrary.
12210         IF(RLU(0).GT.0.5) JS=2
12211         MINT(20+JS)=21
12212         MINT(23-JS)=22
12213         KCC=17+JS
12214
12215       ELSEIF(ISUB.EQ.15) THEN
12216 C...f + fb -> g + Z0; th arbitrary.
12217         IF(RLU(0).GT.0.5) JS=2
12218         MINT(20+JS)=21
12219         MINT(23-JS)=23
12220         KCC=17+JS
12221
12222       ELSEIF(ISUB.EQ.16) THEN
12223 C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12224         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12225         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12226         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12227         MINT(20+JS)=21
12228         MINT(23-JS)=ISIGN(24,KCH1+KCH2)
12229         KCC=17+JS
12230
12231       ELSEIF(ISUB.EQ.17) THEN
12232 C...f + fb -> g + H0; th arbitrary.
12233         IF(RLU(0).GT.0.5) JS=2
12234         MINT(20+JS)=21
12235         MINT(23-JS)=25
12236         KCC=17+JS
12237
12238       ELSEIF(ISUB.EQ.18) THEN
12239 C...f + fb -> gamma + gamma; th arbitrary.
12240         MINT(21)=22
12241         MINT(22)=22
12242
12243       ELSEIF(ISUB.EQ.19) THEN
12244 C...f + fb -> gamma + Z0; th arbitrary.
12245         IF(RLU(0).GT.0.5) JS=2
12246         MINT(20+JS)=22
12247         MINT(23-JS)=23
12248
12249       ELSEIF(ISUB.EQ.20) THEN
12250 C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12251         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12252         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12253         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12254         MINT(20+JS)=22
12255         MINT(23-JS)=ISIGN(24,KCH1+KCH2)
12256       ENDIF
12257
12258       ELSEIF(ISUB.LE.30) THEN
12259       IF(ISUB.EQ.21) THEN
12260 C...f + fb -> gamma + H0; th arbitrary.
12261         IF(RLU(0).GT.0.5) JS=2
12262         MINT(20+JS)=22
12263         MINT(23-JS)=25
12264
12265       ELSEIF(ISUB.EQ.22) THEN
12266 C...f + fb -> Z0 + Z0; th arbitrary.
12267         MINT(21)=23
12268         MINT(22)=23
12269
12270       ELSEIF(ISUB.EQ.23) THEN
12271 C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12272         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12273         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12274         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12275         MINT(20+JS)=23
12276         MINT(23-JS)=ISIGN(24,KCH1+KCH2)
12277
12278       ELSEIF(ISUB.EQ.24) THEN
12279 C...f + fb -> Z0 + H0; th arbitrary.
12280         IF(RLU(0).GT.0.5) JS=2
12281         MINT(20+JS)=23
12282         MINT(23-JS)=25
12283
12284       ELSEIF(ISUB.EQ.25) THEN
12285 C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.
12286         MINT(21)=-ISIGN(24,MINT(15))
12287         MINT(22)=-MINT(21)
12288
12289       ELSEIF(ISUB.EQ.26) THEN
12290 C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
12291         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12292         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12293         IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12294         MINT(20+JS)=ISIGN(24,KCH1+KCH2)
12295         MINT(23-JS)=25
12296
12297       ELSEIF(ISUB.EQ.27) THEN
12298 C...f + fb -> H0 + H0.
12299
12300       ELSEIF(ISUB.EQ.28) THEN
12301 C...f + g -> f + g; th = (p(f)-p(f))**2.
12302         KCC=MINT(2)+6
12303         IF(MINT(15).EQ.21) KCC=KCC+2
12304         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12305         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12306
12307       ELSEIF(ISUB.EQ.29) THEN
12308 C...f + g -> f + gamma; th = (p(f)-p(f))**2.
12309         IF(MINT(15).EQ.21) JS=2
12310         MINT(23-JS)=22
12311         KCC=15+JS
12312         KCS=ISIGN(1,MINT(14+JS))
12313
12314       ELSEIF(ISUB.EQ.30) THEN
12315 C...f + g -> f + Z0; th = (p(f)-p(f))**2.
12316         IF(MINT(15).EQ.21) JS=2
12317         MINT(23-JS)=23
12318         KCC=15+JS
12319         KCS=ISIGN(1,MINT(14+JS))
12320       ENDIF
12321
12322       ELSEIF(ISUB.LE.40) THEN
12323       IF(ISUB.EQ.31) THEN
12324 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.
12325         IF(MINT(15).EQ.21) JS=2
12326         I=MINT(14+JS)
12327         IA=IABS(I)
12328         MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
12329         RVCKM=VINT(180+I)*RLU(0)
12330         DO 220 J=1,MSTP(1)
12331         IB=2*J-1+MOD(IA,2)
12332         IPM=(5-ISIGN(1,I))/2
12333         IDC=J+MDCY(IA,2)+2
12334         IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 220
12335         MINT(20+JS)=ISIGN(IB,I)
12336         RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12337         IF(RVCKM.LE.0.) GOTO 230
12338   220   CONTINUE
12339   230   KCC=15+JS
12340         KCS=ISIGN(1,MINT(14+JS))
12341
12342       ELSEIF(ISUB.EQ.32) THEN
12343 C...f + g -> f + H0; th = (p(f)-p(f))**2.
12344         IF(MINT(15).EQ.21) JS=2
12345         MINT(23-JS)=25
12346         KCC=15+JS
12347         KCS=ISIGN(1,MINT(14+JS))
12348
12349       ELSEIF(ISUB.EQ.33) THEN
12350 C...f + gamma -> f + g.
12351
12352       ELSEIF(ISUB.EQ.34) THEN
12353 C...f + gamma -> f + gamma.
12354
12355       ELSEIF(ISUB.EQ.35) THEN
12356 C...f + gamma -> f + Z0.
12357
12358       ELSEIF(ISUB.EQ.36) THEN
12359 C...f + gamma -> f' + W+/-.
12360
12361       ELSEIF(ISUB.EQ.37) THEN
12362 C...f + gamma -> f + H0.
12363
12364       ELSEIF(ISUB.EQ.38) THEN
12365 C...f + Z0 -> f + g.
12366
12367       ELSEIF(ISUB.EQ.39) THEN
12368 C...f + Z0 -> f + gamma.
12369
12370       ELSEIF(ISUB.EQ.40) THEN
12371 C...f + Z0 -> f + Z0.
12372       ENDIF
12373
12374       ELSEIF(ISUB.LE.50) THEN
12375       IF(ISUB.EQ.41) THEN
12376 C...f + Z0 -> f' + W+/-.
12377
12378       ELSEIF(ISUB.EQ.42) THEN
12379 C...f + Z0 -> f + H0.
12380
12381       ELSEIF(ISUB.EQ.43) THEN
12382 C...f + W+/- -> f' + g.
12383
12384       ELSEIF(ISUB.EQ.44) THEN
12385 C...f + W+/- -> f' + gamma.
12386
12387       ELSEIF(ISUB.EQ.45) THEN
12388 C...f + W+/- -> f' + Z0.
12389
12390       ELSEIF(ISUB.EQ.46) THEN
12391 C...f + W+/- -> f' + W+/-.
12392
12393       ELSEIF(ISUB.EQ.47) THEN
12394 C...f + W+/- -> f' + H0.
12395
12396       ELSEIF(ISUB.EQ.48) THEN
12397 C...f + H0 -> f + g.
12398
12399       ELSEIF(ISUB.EQ.49) THEN
12400 C...f + H0 -> f + gamma.
12401
12402       ELSEIF(ISUB.EQ.50) THEN
12403 C...f + H0 -> f + Z0.
12404       ENDIF
12405
12406       ELSEIF(ISUB.LE.60) THEN
12407       IF(ISUB.EQ.51) THEN
12408 C...f + H0 -> f' + W+/-.
12409
12410       ELSEIF(ISUB.EQ.52) THEN
12411 C...f + H0 -> f + H0.
12412
12413       ELSEIF(ISUB.EQ.53) THEN
12414 C...g + g -> f + fb; th arbitrary.
12415         KCS=(-1)**INT(1.5+RLU(0))
12416         MINT(21)=ISIGN(KFLQ,KCS)
12417         MINT(22)=-MINT(21)
12418         KCC=MINT(2)+10
12419
12420       ELSEIF(ISUB.EQ.54) THEN
12421 C...g + gamma -> f + fb.
12422
12423       ELSEIF(ISUB.EQ.55) THEN
12424 C...g + Z0 -> f + fb.
12425
12426       ELSEIF(ISUB.EQ.56) THEN
12427 C...g + W+/- -> f + fb'.
12428
12429       ELSEIF(ISUB.EQ.57) THEN
12430 C...g + H0 -> f + fb.
12431
12432       ELSEIF(ISUB.EQ.58) THEN
12433 C...gamma + gamma -> f + fb.
12434
12435       ELSEIF(ISUB.EQ.59) THEN
12436 C...gamma + Z0 -> f + fb.
12437
12438       ELSEIF(ISUB.EQ.60) THEN
12439 C...gamma + W+/- -> f + fb'.
12440       ENDIF
12441
12442       ELSEIF(ISUB.LE.70) THEN
12443       IF(ISUB.EQ.61) THEN
12444 C...gamma + H0 -> f + fb.
12445
12446       ELSEIF(ISUB.EQ.62) THEN
12447 C...Z0 + Z0 -> f + fb.
12448
12449       ELSEIF(ISUB.EQ.63) THEN
12450 C...Z0 + W+/- -> f + fb'.
12451
12452       ELSEIF(ISUB.EQ.64) THEN
12453 C...Z0 + H0 -> f + fb.
12454
12455       ELSEIF(ISUB.EQ.65) THEN
12456 C...W+ + W- -> f + fb.
12457
12458       ELSEIF(ISUB.EQ.66) THEN
12459 C...W+/- + H0 -> f + fb'.
12460
12461       ELSEIF(ISUB.EQ.67) THEN
12462 C...H0 + H0 -> f + fb.
12463
12464       ELSEIF(ISUB.EQ.68) THEN
12465 C...g + g -> g + g; th arbitrary.
12466         KCC=MINT(2)+12
12467         KCS=(-1)**INT(1.5+RLU(0))
12468
12469       ELSEIF(ISUB.EQ.69) THEN
12470 C...gamma + gamma -> W+ + W-.
12471
12472       ELSEIF(ISUB.EQ.70) THEN
12473 C...gamma + W+/- -> gamma + W+/-
12474       ENDIF
12475
12476       ELSEIF(ISUB.LE.80) THEN
12477       IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
12478 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-.
12479         XH=SH/SHP
12480         MINT(21)=MINT(15)
12481         MINT(22)=MINT(16)
12482         PMQ(1)=ULMASS(MINT(21))
12483         PMQ(2)=ULMASS(MINT(22))
12484   290   JT=INT(1.5+RLU(0))
12485         ZMIN=2.*PMQ(JT)/SHPR
12486         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12487         ZMAX=MIN(1.-XH,ZMAX)
12488         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12489         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12490      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 290
12491         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12492         IF(SQC1.LT.1.E-8) GOTO 290
12493         C1=SQRT(SQC1)
12494         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12495         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12496         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12497         Z(3-JT)=1.-XH/(1.-Z(JT))
12498         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12499         IF(SQC1.LT.1.E-8) GOTO 290
12500         C1=SQRT(SQC1)
12501         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12502         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12503         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12504         PHIR=PARU(2)*RLU(0)
12505         CPHI=COS(PHIR)
12506         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12507         Z1=2.-Z(JT)
12508         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12509         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12510         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12511      &  PMQ(3-JT)**2/SHP))
12512         ZMIN=2.*PMQ(3-JT)/SHPR
12513         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12514         ZMAX=MIN(1.-XH,ZMAX)
12515         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 290
12516         KCC=22
12517
12518       ELSEIF(ISUB.EQ.73) THEN
12519 C...Z0 + W+/- -> Z0 + W+/-.
12520         XH=SH/SHP
12521   300   JT=INT(1.5+RLU(0))
12522         I=MINT(14+JT)
12523         IA=IABS(I)
12524         IF(IA.LE.10) THEN
12525           RVCKM=VINT(180+I)*RLU(0)
12526           DO 320 J=1,MSTP(1)
12527           IB=2*J-1+MOD(IA,2)
12528           IPM=(5-ISIGN(1,I))/2
12529           IDC=J+MDCY(IA,2)+2
12530           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 320
12531           MINT(20+JT)=ISIGN(IB,I)
12532           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12533           IF(RVCKM.LE.0.) GOTO 330
12534   320     CONTINUE
12535         ELSE
12536           IB=2*((IA+1)/2)-1+MOD(IA,2)
12537           MINT(20+JT)=ISIGN(IB,I)
12538         ENDIF
12539   330   PMQ(JT)=ULMASS(MINT(20+JT))
12540         MINT(23-JT)=MINT(17-JT)
12541         PMQ(3-JT)=ULMASS(MINT(23-JT))
12542         JT=INT(1.5+RLU(0))
12543         ZMIN=2.*PMQ(JT)/SHPR
12544         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12545         ZMAX=MIN(1.-XH,ZMAX)
12546         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12547         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12548      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 300
12549         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12550         IF(SQC1.LT.1.E-8) GOTO 300
12551         C1=SQRT(SQC1)
12552         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12553         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12554         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12555         Z(3-JT)=1.-XH/(1.-Z(JT))
12556         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12557         IF(SQC1.LT.1.E-8) GOTO 300
12558         C1=SQRT(SQC1)
12559         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12560         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12561         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12562         PHIR=PARU(2)*RLU(0)
12563         CPHI=COS(PHIR)
12564         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12565         Z1=2.-Z(JT)
12566         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12567         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12568         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12569      &  PMQ(3-JT)**2/SHP))
12570         ZMIN=2.*PMQ(3-JT)/SHPR
12571         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12572         ZMAX=MIN(1.-XH,ZMAX)
12573         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 300
12574         KCC=22
12575
12576       ELSEIF(ISUB.EQ.74) THEN
12577 C...Z0 + H0 -> Z0 + H0.
12578
12579       ELSEIF(ISUB.EQ.75) THEN
12580 C...W+ + W- -> gamma + gamma.
12581
12582       ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
12583 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-.
12584         XH=SH/SHP
12585   340   DO 370 JT=1,2
12586         I=MINT(14+JT)
12587         IA=IABS(I)
12588         IF(IA.LE.10) THEN
12589           RVCKM=VINT(180+I)*RLU(0)
12590           DO 360 J=1,MSTP(1)
12591           IB=2*J-1+MOD(IA,2)
12592           IPM=(5-ISIGN(1,I))/2
12593           IDC=J+MDCY(IA,2)+2
12594           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 360
12595           MINT(20+JT)=ISIGN(IB,I)
12596           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12597           IF(RVCKM.LE.0.) GOTO 370
12598   360     CONTINUE
12599         ELSE
12600           IB=2*((IA+1)/2)-1+MOD(IA,2)
12601           MINT(20+JT)=ISIGN(IB,I)
12602         ENDIF
12603   370   PMQ(JT)=ULMASS(MINT(20+JT))
12604         JT=INT(1.5+RLU(0))
12605         ZMIN=2.*PMQ(JT)/SHPR
12606         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
12607         ZMAX=MIN(1.-XH,ZMAX)
12608         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
12609         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
12610      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 340
12611         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
12612         IF(SQC1.LT.1.E-8) GOTO 340
12613         C1=SQRT(SQC1)
12614         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
12615         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12616         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
12617         Z(3-JT)=1.-XH/(1.-Z(JT))
12618         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
12619         IF(SQC1.LT.1.E-8) GOTO 340
12620         C1=SQRT(SQC1)
12621         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
12622         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
12623         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
12624         PHIR=PARU(2)*RLU(0)
12625         CPHI=COS(PHIR)
12626         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
12627         Z1=2.-Z(JT)
12628         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
12629         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
12630         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
12631      &  PMQ(3-JT)**2/SHP))
12632         ZMIN=2.*PMQ(3-JT)/SHPR
12633         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
12634         ZMAX=MIN(1.-XH,ZMAX)
12635         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
12636         KCC=22
12637
12638       ELSEIF(ISUB.EQ.78) THEN
12639 C...W+/- + H0 -> W+/- + H0.
12640
12641       ELSEIF(ISUB.EQ.79) THEN
12642 C...H0 + H0 -> H0 + H0.
12643       ENDIF
12644
12645       ELSEIF(ISUB.LE.90) THEN
12646       IF(ISUB.EQ.81) THEN
12647 C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.
12648         MINT(21)=ISIGN(MINT(46),MINT(15))
12649         MINT(22)=-MINT(21)
12650         KCC=4
12651
12652       ELSEIF(ISUB.EQ.82) THEN
12653 C...g + g -> Q + Qb; th arbitrary.
12654         KCS=(-1)**INT(1.5+RLU(0))
12655         MINT(21)=ISIGN(MINT(46),KCS)
12656         MINT(22)=-MINT(21)
12657         KCC=MINT(2)+10
12658       ENDIF
12659
12660       ELSEIF(ISUB.LE.100) THEN
12661       IF(ISUB.EQ.95) THEN
12662 C...Low-pT ( = energyless g + g -> g + g).
12663         KCC=MINT(2)+12
12664         KCS=(-1)**INT(1.5+RLU(0))
12665
12666       ELSEIF(ISUB.EQ.96) THEN
12667 C...Multiple interactions (should be reassigned to QCD process).
12668       ENDIF
12669
12670       ELSEIF(ISUB.LE.110) THEN
12671       IF(ISUB.EQ.101) THEN
12672 C...g + g -> gamma*/Z0.
12673         KCC=21
12674         KFRES=22
12675
12676       ELSEIF(ISUB.EQ.102) THEN
12677 C...g + g -> H0.
12678         KCC=21
12679         KFRES=25
12680       ENDIF
12681
12682       ELSEIF(ISUB.LE.120) THEN
12683       IF(ISUB.EQ.111) THEN
12684 C...f + fb -> g + H0; th arbitrary.
12685         IF(RLU(0).GT.0.5) JS=2
12686         MINT(20+JS)=21
12687         MINT(23-JS)=25
12688         KCC=17+JS
12689
12690       ELSEIF(ISUB.EQ.112) THEN
12691 C...f + g -> f + H0; th = (p(f) - p(f))**2.
12692         IF(MINT(15).EQ.21) JS=2
12693         MINT(23-JS)=25
12694         KCC=15+JS
12695         KCS=ISIGN(1,MINT(14+JS))
12696
12697       ELSEIF(ISUB.EQ.113) THEN
12698 C...g + g -> g + H0; th arbitrary.
12699         IF(RLU(0).GT.0.5) JS=2
12700         MINT(23-JS)=25
12701         KCC=22+JS
12702         KCS=(-1)**INT(1.5+RLU(0))
12703
12704       ELSEIF(ISUB.EQ.114) THEN
12705 C...g + g -> gamma + gamma; th arbitrary.
12706         IF(RLU(0).GT.0.5) JS=2
12707         MINT(21)=22
12708         MINT(22)=22
12709         KCC=21
12710
12711       ELSEIF(ISUB.EQ.115) THEN
12712 C...g + g -> gamma + Z0.
12713
12714       ELSEIF(ISUB.EQ.116) THEN
12715 C...g + g -> Z0 + Z0.
12716
12717       ELSEIF(ISUB.EQ.117) THEN
12718 C...g + g -> W+ + W-.
12719       ENDIF
12720
12721       ELSEIF(ISUB.LE.140) THEN
12722       IF(ISUB.EQ.121) THEN
12723 C...g + g -> f + fb + H0.
12724       ENDIF
12725
12726       ELSEIF(ISUB.LE.160) THEN
12727       IF(ISUB.EQ.141) THEN
12728 C...f + fb -> gamma*/Z0/Z'0.
12729         KFRES=32
12730
12731       ELSEIF(ISUB.EQ.142) THEN
12732 C...f + fb' -> H+/-.
12733         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12734         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12735         KFRES=ISIGN(37,KCH1+KCH2)
12736
12737       ELSEIF(ISUB.EQ.143) THEN
12738 C...f + fb' -> R.
12739         KFRES=ISIGN(40,MINT(15)+MINT(16))
12740       ENDIF
12741
12742       ELSE
12743       IF(ISUB.EQ.161) THEN
12744 C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.
12745         IF(MINT(16).EQ.21) JS=2
12746         IA=IABS(MINT(17-JS))
12747         MINT(20+JS)=ISIGN(37,KCHG(IA,1)*MINT(17-JS))
12748         JA=IA+MOD(IA,2)-MOD(IA+1,2)
12749         MINT(23-JS)=ISIGN(JA,MINT(17-JS))
12750         KCC=18-JS
12751         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12752         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12753       ENDIF
12754       ENDIF
12755
12756       IF(IDOC.EQ.7) THEN
12757 C...Resonance not decaying: store colour connection indices.
12758         I=MINT(83)+7
12759         K(IPU3,1)=1
12760         K(IPU3,2)=KFRES
12761         K(IPU3,3)=I
12762         P(IPU3,4)=SHUSER
12763         P(IPU3,5)=SHUSER
12764         K(IPU1,4)=IPU2
12765         K(IPU1,5)=IPU2
12766         K(IPU2,4)=IPU1
12767         K(IPU2,5)=IPU1
12768         K(I,1)=21
12769         K(I,2)=KFRES
12770         P(I,4)=SHUSER
12771         P(I,5)=SHUSER
12772         N=IPU3
12773         MINT(21)=KFRES
12774         MINT(22)=0
12775
12776       ELSEIF(IDOC.EQ.8) THEN
12777 C...2 -> 2 processes: store outgoing partons in their CM-frame.
12778         DO 390 JT=1,2
12779         I=MINT(84)+2+JT
12780         K(I,1)=1
12781         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
12782         K(I,2)=MINT(20+JT)
12783         K(I,3)=MINT(83)+IDOC+JT-2
12784         IF(IABS(K(I,2)).LE.10.OR.K(I,2).EQ.21) THEN
12785           P(I,5)=ULMASS(K(I,2))
12786         ELSE
12787           P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12788         ENDIF
12789   390   CONTINUE
12790         IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12791           KFA1=IABS(MINT(21))
12792           KFA2=IABS(MINT(22))
12793           IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12794      &    THEN
12795             MINT(51)=1
12796             RETURN
12797           ENDIF
12798           P(IPU3,5)=0.
12799           P(IPU4,5)=0.
12800         ENDIF
12801         P(IPU3,4)=0.5*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12802         P(IPU3,3)=SQRT(MAX(0.,P(IPU3,4)**2-P(IPU3,5)**2))
12803         P(IPU4,4)=SHR-P(IPU3,4)
12804         P(IPU4,3)=-P(IPU3,3)
12805         N=IPU4
12806         MINT(7)=MINT(83)+7
12807         MINT(8)=MINT(83)+8
12808
12809 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4).
12810         CALL LUDBRB(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12811
12812       ELSEIF(IDOC.EQ.9) THEN
12813 C'''2 -> 3 processes:
12814
12815       ELSEIF(IDOC.EQ.11) THEN
12816 C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons.
12817         PHI(1)=PARU(2)*RLU(0)
12818         PHI(2)=PHI(1)-PHIR
12819         DO 400 JT=1,2
12820         I=MINT(84)+2+JT
12821         K(I,1)=1
12822         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
12823         K(I,2)=MINT(20+JT)
12824         K(I,3)=MINT(83)+IDOC+JT-2
12825         P(I,5)=ULMASS(K(I,2))
12826         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
12827         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
12828         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
12829         P(I,1)=PTABS*COS(PHI(JT))
12830         P(I,2)=PTABS*SIN(PHI(JT))
12831         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12832         P(I,4)=0.5*SHPR*Z(JT)
12833         IZW=MINT(83)+6+JT
12834         K(IZW,1)=21
12835         K(IZW,2)=23
12836         IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT)))
12837         K(IZW,3)=IZW-2
12838         P(IZW,1)=-P(I,1)
12839         P(IZW,2)=-P(I,2)
12840         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12841         P(IZW,4)=0.5*SHPR*(1.-Z(JT))
12842   400   P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12843         I=MINT(83)+9
12844         K(IPU5,1)=1
12845         K(IPU5,2)=KFRES
12846         K(IPU5,3)=I
12847         P(IPU5,5)=SHR
12848         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12849         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12850         P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12851         P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12852         K(I,1)=21
12853         K(I,2)=KFRES
12854         DO 410 J=1,5
12855   410   P(I,J)=P(IPU5,J)
12856         N=IPU5
12857         MINT(23)=KFRES
12858
12859       ELSEIF(IDOC.EQ.12) THEN
12860 C...Z0 and W+/- scattering: store bosons and outgoing partons.
12861         PHI(1)=PARU(2)*RLU(0)
12862         PHI(2)=PHI(1)-PHIR
12863         DO 420 JT=1,2
12864         I=MINT(84)+2+JT
12865         K(I,1)=1
12866         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
12867         K(I,2)=MINT(20+JT)
12868         K(I,3)=MINT(83)+IDOC+JT-2
12869         P(I,5)=ULMASS(K(I,2))
12870         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
12871         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
12872         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
12873         P(I,1)=PTABS*COS(PHI(JT))
12874         P(I,2)=PTABS*SIN(PHI(JT))
12875         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12876         P(I,4)=0.5*SHPR*Z(JT)
12877         IZW=MINT(83)+6+JT
12878         K(IZW,1)=21
12879         IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12880           K(IZW,2)=23
12881         ELSE
12882           K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT))-LUCHGE(MINT(20+JT)))
12883         ENDIF
12884         K(IZW,3)=IZW-2
12885         P(IZW,1)=-P(I,1)
12886         P(IZW,2)=-P(I,2)
12887         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12888         P(IZW,4)=0.5*SHPR*(1.-Z(JT))
12889         P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12890         IPU=MINT(84)+4+JT
12891         K(IPU,1)=3
12892         K(IPU,2)=KFPR(ISUB,JT)
12893         K(IPU,3)=MINT(83)+8+JT
12894         IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12895           P(IPU,5)=ULMASS(K(IPU,2))
12896         ELSE
12897           P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12898         ENDIF
12899         MINT(22+JT)=K(IZW,2)
12900   420   CONTINUE
12901         IF(ISUB.EQ.72) K(MINT(84)+4+INT(1.5+RLU(0)),2)=-24
12902 C...Find rotation and boost for hard scattering subsystem.
12903         I1=MINT(83)+7
12904         I2=MINT(83)+8
12905         BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12906         BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12907         BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12908         GAMCM=(P(I1,4)+P(I2,4))/SHR
12909         BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12910         PX=P(I1,1)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEXCM
12911         PY=P(I1,2)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEYCM
12912         PZ=P(I1,3)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEZCM
12913         THECM=ULANGL(PZ,SQRT(PX**2+PY**2))
12914         PHICM=ULANGL(PX,PY)
12915 C...Store hard scattering subsystem. Rotate and boost it.
12916         SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4.*P(IPU5,5)**2*
12917      &  P(IPU6,5)**2
12918         PABS=SQRT(MAX(0.,SQLAM/(4.*SH)))
12919         CTHWZ=VINT(23)
12920         STHWZ=SQRT(MAX(0.,1.-CTHWZ**2))
12921         PHIWZ=VINT(24)-PHICM
12922         P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12923         P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12924         P(IPU5,3)=PABS*CTHWZ
12925         P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12926         P(IPU6,1)=-P(IPU5,1)
12927         P(IPU6,2)=-P(IPU5,2)
12928         P(IPU6,3)=-P(IPU5,3)
12929         P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12930         CALL LUDBRB(IPU5,IPU6,THECM,PHICM,DBLE(BEXCM),DBLE(BEYCM),
12931      &  DBLE(BEZCM))
12932         DO 430 JT=1,2
12933         I1=MINT(83)+8+JT
12934         I2=MINT(84)+4+JT
12935         K(I1,1)=21
12936         K(I1,2)=K(I2,2)
12937         DO 430 J=1,5
12938   430   P(I1,J)=P(I2,J)
12939         N=IPU6
12940         MINT(7)=MINT(83)+9
12941         MINT(8)=MINT(83)+10
12942       ENDIF
12943
12944       IF(IDOC.GE.8) THEN
12945 C...Store colour connection indices.
12946         DO 440 J=1,2
12947         JC=J
12948         IF(KCS.EQ.-1) JC=3-J
12949         IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12950      &  K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12951         IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12952      &  K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12953         IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12954      &  MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12955   440   IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12956      &  MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12957
12958 C...Copy outgoing partons to documentation lines.
12959         DO 450 I=1,2
12960         I1=MINT(83)+IDOC-2+I
12961         I2=MINT(84)+2+I
12962         K(I1,1)=21
12963         K(I1,2)=K(I2,2)
12964         IF(IDOC.LE.9) K(I1,3)=0
12965         IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12966         DO 450 J=1,5
12967   450   P(I1,J)=P(I2,J)
12968       ENDIF
12969       MINT(52)=N
12970
12971 C...Low-pT events: remove gluons used for string drawing purposes.
12972       IF(ISUB.EQ.95) THEN
12973         K(IPU3,1)=K(IPU3,1)+10
12974         K(IPU4,1)=K(IPU4,1)+10
12975         DO 460 J=41,66
12976   460   VINT(J)=0.
12977         DO 470 I=MINT(83)+5,MINT(83)+8
12978         DO 470 J=1,5
12979   470   P(I,J)=0.
12980       ENDIF
12981
12982       RETURN
12983       END
12984
12985 C*********************************************************************
12986
12987       SUBROUTINE PYSSPA(IPU1,IPU2)
12988
12989 C...Generates spacelike parton showers.
12990       IMPLICIT DOUBLE PRECISION(D)
12991       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
12992       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12993       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
12994       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
12995       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12996       COMMON/PYINT1/MINT(400),VINT(400)
12997       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
12998       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12999       DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVS(2),ROBO(5),
13000      &XFS(2,-6:6),XFA(-6:6),XFB(-6:6),XFN(-6:6),WTAP(-6:6),WTSF(-6:6),
13001      &THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),DPB(4)
13002       SAVE
13003
13004 C...Calculate maximum virtuality and check that evolution possible.
13005       IPUS1=IPU1
13006       IPUS2=IPU2
13007       ISUB=MINT(1)
13008       Q2E=VINT(52)
13009       IF(ISET(ISUB).EQ.1) THEN
13010         Q2E=Q2E/PARP(67)
13011       ELSEIF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
13012         Q2E=PMAS(23,1)**2
13013         IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2E=PMAS(24,1)**2
13014       ENDIF
13015       TMAX=LOG(PARP(67)*PARP(63)*Q2E/PARP(61)**2)
13016       IF(PARP(67)*Q2E.LT.MAX(PARP(62)**2,2.*PARP(61)**2).OR.
13017      &TMAX.LT.0.2) RETURN
13018
13019 C...Common constants and initial values. Save normal Lambda value.
13020       XE0=2.*PARP(65)/VINT(1)
13021       ALAMS=PARU(111)
13022       PARU(111)=PARP(61)
13023       NS=N
13024   100 N=NS
13025       DO 110 JT=1,2
13026       KFLS(JT)=MINT(14+JT)
13027       KFLS(JT+2)=KFLS(JT)
13028       XS(JT)=VINT(40+JT)
13029       ZS(JT)=1.
13030       Q2S(JT)=PARP(67)*Q2E
13031       TEVS(JT)=TMAX
13032       ALAM(JT)=PARP(61)
13033       THE2(JT)=100.
13034       DO 110 KFL=-6,6
13035   110 XFS(JT,KFL)=XSFX(JT,KFL)
13036       DSH=VINT(44)
13037       IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) DSH=VINT(26)*VINT(2)
13038
13039 C...Pick up leg with highest virtuality.
13040   120 N=N+1
13041       JT=1
13042       IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13043       KFLB=KFLS(JT)
13044       XB=XS(JT)
13045       DO 130 KFL=-6,6
13046   130 XFB(KFL)=XFS(JT,KFL)
13047       DSHR=2D0*SQRT(DSH)
13048       DSHZ=DSH/DBLE(ZS(JT))
13049       XE=MAX(XE0,XB*(1./(1.-PARP(66))-1.))
13050       IF(XB+XE.GE.0.999) THEN
13051         Q2B=0.
13052         GOTO 220
13053       ENDIF
13054
13055 C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.
13056       IF(MSTP(62).LE.1) THEN
13057         Q2B=0.5*(1./ZS(JT)+1.)*Q2S(JT)+0.5*(1./ZS(JT)-1.)*(Q2S(3-JT)-
13058      &  SNGL(DSH)+SQRT((SNGL(DSH)+Q2S(1)+Q2S(2))**2+8.*Q2S(1)*Q2S(2)*
13059      &  ZS(JT)/(1.-ZS(JT))))
13060         TEVB=LOG(PARP(63)*Q2B/ALAM(JT)**2)
13061       ELSE
13062         Q2B=Q2S(JT)
13063         TEVB=TEVS(JT)
13064       ENDIF
13065       ALSDUM=ULALPS(PARP(63)*Q2B)
13066       TEVB=TEVB+2.*LOG(ALAM(JT)/PARU(117))
13067       TEVBSV=TEVB
13068       ALAM(JT)=PARU(117)
13069       B0=(33.-2.*MSTU(118))/6.
13070
13071 C...Calculate Altarelli-Parisi and structure function weights.
13072       DO 140 KFL=-6,6
13073       WTAP(KFL)=0.
13074   140 WTSF(KFL)=0.
13075       IF(KFLB.EQ.21) THEN
13076         WTAPQ=16.*(1.-SQRT(XB+XE))/(3.*SQRT(XB))
13077         DO 150 KFL=-MSTP(54),MSTP(54)
13078         IF(KFL.EQ.0) WTAP(KFL)=6.*LOG((1.-XB)/XE)
13079   150   IF(KFL.NE.0) WTAP(KFL)=WTAPQ
13080       ELSE
13081         WTAP(0)=0.5*XB*(1./(XB+XE)-1.)
13082         WTAP(KFLB)=8.*LOG((1.-XB)*(XB+XE)/XE)/3.
13083       ENDIF
13084   160 WTSUM=0.
13085       IF(KFLB.NE.21) XFBO=XFB(KFLB)
13086       IF(KFLB.EQ.21) XFBO=XFB(0)
13087 C***************************************************************
13088 C**********ERROR HAS OCCURED HERE
13089       IF(XFBO.EQ.0.0) THEN
13090                 WRITE(MSTU(11),1000)
13091                 WRITE(MSTU(11),1001) KFLB,XFB(KFLB)
13092                 XFBO=0.00001
13093       ENDIF
13094 C****************************************************************
13095       DO 170 KFL=-MSTP(54),MSTP(54)
13096       WTSF(KFL)=XFB(KFL)/XFBO
13097   170 WTSUM=WTSUM+WTAP(KFL)*WTSF(KFL)
13098       WTSUM=MAX(0.0001,WTSUM)
13099
13100 C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).
13101   180 IF(MSTP(64).LE.0) THEN
13102         TEVB=TEVB+LOG(RLU(0))*PARU(2)/(PARU(111)*WTSUM)
13103       ELSEIF(MSTP(64).EQ.1) THEN
13104         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/WTSUM))
13105       ELSE
13106         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/(5.*WTSUM)))
13107       ENDIF
13108   190 Q2REF=ALAM(JT)**2*EXP(TEVB)
13109       Q2B=Q2REF/PARP(63)
13110
13111 C...Evolution ended or select flavour for branching parton.
13112       IF(Q2B.LT.PARP(62)**2) THEN
13113         Q2B=0.
13114       ELSE
13115         WTRAN=RLU(0)*WTSUM
13116         KFLA=-MSTP(54)-1
13117   200   KFLA=KFLA+1
13118         WTRAN=WTRAN-WTAP(KFLA)*WTSF(KFLA)
13119         IF(KFLA.LT.MSTP(54).AND.WTRAN.GT.0.) GOTO 200
13120         IF(KFLA.EQ.0) KFLA=21
13121
13122 C...Choose z value and corrective weight.
13123         IF(KFLB.EQ.21.AND.KFLA.EQ.21) THEN
13124           Z=1./(1.+((1.-XB)/XB)*(XE/(1.-XB))**RLU(0))
13125           WTZ=(1.-Z*(1.-Z))**2
13126         ELSEIF(KFLB.EQ.21) THEN
13127           Z=XB/(1.-RLU(0)*(1.-SQRT(XB+XE)))**2
13128           WTZ=0.5*(1.+(1.-Z)**2)*SQRT(Z)
13129         ELSEIF(KFLA.EQ.21) THEN
13130           Z=XB*(1.+RLU(0)*(1./(XB+XE)-1.))
13131           WTZ=1.-2.*Z*(1.-Z)
13132         ELSE
13133           Z=1.-(1.-XB)*(XE/((XB+XE)*(1.-XB)))**RLU(0)
13134           WTZ=0.5*(1.+Z**2)
13135         ENDIF
13136
13137 C...Option with resummation of soft gluon emission as effective z shift.
13138         IF(MSTP(65).GE.1) THEN
13139           RSOFT=6.
13140           IF(KFLB.NE.21) RSOFT=8./3.
13141           Z=Z*(TEVB/TEVS(JT))**(RSOFT*XE/((XB+XE)*B0))
13142           IF(Z.LE.XB) GOTO 180
13143         ENDIF
13144
13145 C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.
13146         IF(MSTP(64).GE.2) THEN
13147           IF((1.-Z)*Q2B.LT.PARP(62)**2) GOTO 180
13148           ALPRAT=TEVB/(TEVB+LOG(1.-Z))
13149           IF(ALPRAT.LT.5.*RLU(0)) GOTO 180
13150           IF(ALPRAT.GT.5.) WTZ=WTZ*ALPRAT/5.
13151         ENDIF
13152
13153 C...Option with angular ordering requirement.
13154         IF(MSTP(62).GE.3) THEN
13155           THE2T=(4.*Z**2*Q2B)/(VINT(2)*(1.-Z)*XB**2)
13156           IF(THE2T.GT.THE2(JT)) GOTO 180
13157         ENDIF
13158
13159 C...Weighting with new structure functions.
13160         CALL PYSTFU(MINT(10+JT),XB,Q2REF,XFN,JT)
13161         IF(KFLB.NE.21) XFBN=XFN(KFLB)
13162         IF(KFLB.EQ.21) XFBN=XFN(0)
13163         IF(XFBN.LT.1E-20) THEN
13164           IF(KFLA.EQ.KFLB) THEN
13165             TEVB=TEVBSV
13166             WTAP(KFLB)=0.
13167             GOTO 160
13168           ELSEIF(TEVBSV-TEVB.GT.0.2) THEN
13169             TEVB=0.5*(TEVBSV+TEVB)
13170             GOTO 190
13171           ELSE
13172             XFBN=1E-10
13173           ENDIF
13174         ENDIF
13175         DO 210 KFL=-MSTP(54),MSTP(54)
13176   210   XFB(KFL)=XFN(KFL)
13177         XA=XB/Z
13178         CALL PYSTFU(MINT(10+JT),XA,Q2REF,XFA,JT)
13179         IF(KFLA.NE.21) XFAN=XFA(KFLA)
13180         IF(KFLA.EQ.21) XFAN=XFA(0)
13181         IF(XFAN.LT.1E-20) GOTO 160
13182         IF(KFLA.NE.21) WTSFA=WTSF(KFLA)
13183         IF(KFLA.EQ.21) WTSFA=WTSF(0)
13184         IF(WTZ*XFAN/XFBN.LT.RLU(0)*WTSFA) GOTO 160
13185       ENDIF
13186
13187 C...Define two hard scatterers in their CM-frame.
13188   220 IF(N.EQ.NS+2) THEN
13189         DQ2(JT)=Q2B
13190         DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13191         DO 240 JR=1,2
13192         I=NS+JR
13193         IF(JR.EQ.1) IPO=IPUS1
13194         IF(JR.EQ.2) IPO=IPUS2
13195         DO 230 J=1,5
13196         K(I,J)=0
13197         P(I,J)=0.
13198   230   V(I,J)=0.
13199         K(I,1)=14
13200         K(I,2)=KFLS(JR+2)
13201         K(I,4)=IPO
13202         K(I,5)=IPO
13203         P(I,3)=DPLCM*(-1)**(JR+1)
13204         P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13205         P(I,5)=-SQRT(SNGL(DQ2(JR)))
13206         K(IPO,1)=14
13207         K(IPO,3)=I
13208         K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13209   240   K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13210
13211 C...Find maximum allowed mass of timelike parton.
13212       ELSEIF(N.GT.NS+2) THEN
13213         JR=3-JT
13214         DQ2(3)=Q2B
13215         DPC(1)=P(IS(1),4)
13216         DPC(2)=P(IS(2),4)
13217         DPC(3)=0.5*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13218         DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13219         DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13220         DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13221         DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13222         IKIN=0
13223         IF(Q2S(JR).GE.(0.5*PARP(62))**2.AND.DPD(1)-DPD(3).GE.
13224      &  1D-10*DPD(1)) IKIN=1
13225         IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/DBLE(ZS(JT))-DQ2(3))*(DSH/
13226      &  (DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13227         IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/(2.*
13228      &  DQ2(JR))-DQ2(JT)-DQ2(3)
13229
13230 C...Generate timelike parton shower (if required).
13231         IT=N
13232         DO 250 J=1,5
13233         K(IT,J)=0
13234         P(IT,J)=0.
13235   250   V(IT,J)=0.
13236         K(IT,1)=3
13237         K(IT,2)=21
13238         IF(KFLB.EQ.21.AND.KFLS(JT+2).NE.21) K(IT,2)=-KFLS(JT+2)
13239         IF(KFLB.NE.21.AND.KFLS(JT+2).EQ.21) K(IT,2)=KFLB
13240         P(IT,5)=ULMASS(K(IT,2))
13241         IF(SNGL(DMSMA).LE.P(IT,5)**2) GOTO 100
13242         IF(MSTP(63).GE.1) THEN
13243           P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13244           P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13245           IF(MSTP(63).EQ.1) THEN
13246             Q2TIM=DMSMA
13247           ELSEIF(MSTP(63).EQ.2) THEN
13248             Q2TIM=MIN(SNGL(DMSMA),PARP(71)*Q2S(JT))
13249           ELSE
13250 C'''Here remains to introduce angular ordering in first branching.
13251             Q2TIM=DMSMA
13252           ENDIF
13253           CALL LUSHOW(IT,0,SQRT(Q2TIM))
13254           IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13255         ENDIF
13256
13257 C...Reconstruct kinematics of branching: timelike parton shower.
13258         DMS=P(IT,5)**2
13259         IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13260         IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5*DPD(1)*DPD(2)+0.5*DPD(3)*
13261      &  DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.*DSH*DPC(3)**2)
13262         IF(DPT2.LT.0.) GOTO 100
13263         DPB(1)=(0.5*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13264      &  DSHR)/DPC(3)-DPC(3)
13265         P(IT,1)=SQRT(SNGL(DPT2))
13266         P(IT,3)=DPB(1)*(-1)**(JT+1)
13267         P(IT,4)=(DSHZ-DSH-DMS)/DSHR
13268         IF(N.GE.IT+1) THEN
13269           DPB(1)=SQRT(DPB(1)**2+DPT2)
13270           DPB(2)=SQRT(DPB(1)**2+DMS)
13271           DPB(3)=P(IT+1,3)
13272           DPB(4)=SQRT(DPB(3)**2+DMS)
13273           DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13274      &    DPB(1))
13275           CALL LUDBRB(IT+1,N,0.,0.,0D0,0D0,DBEZ)
13276           THE=ULANGL(P(IT,3),P(IT,1))
13277           CALL LUDBRB(IT+1,N,THE,0.,0D0,0D0,0D0)
13278         ENDIF
13279
13280 C...Reconstruct kinematics of branching: spacelike parton.
13281         DO 260 J=1,5
13282         K(N+1,J)=0
13283         P(N+1,J)=0.
13284   260   V(N+1,J)=0.
13285         K(N+1,1)=14
13286         K(N+1,2)=KFLB
13287         P(N+1,1)=P(IT,1)
13288         P(N+1,3)=P(IT,3)+P(IS(JT),3)
13289         P(N+1,4)=P(IT,4)+P(IS(JT),4)
13290         P(N+1,5)=-SQRT(SNGL(DQ2(3)))
13291
13292 C...Define colour flow of branching.
13293         K(IS(JT),3)=N+1
13294         K(IT,3)=N+1
13295         ID1=IT
13296         IF((K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(ID1,2).GT.0.AND.
13297      &  K(ID1,2).NE.21).OR.(K(N+1,2).LT.0.AND.K(ID1,2).EQ.21).OR.
13298      &  (K(N+1,2).EQ.21.AND.K(ID1,2).EQ.21.AND.RLU(0).GT.0.5).OR.
13299      &  (K(N+1,2).EQ.21.AND.K(ID1,2).LT.0)) ID1=IS(JT)
13300         ID2=IT+IS(JT)-ID1
13301         K(N+1,4)=K(N+1,4)+ID1
13302         K(N+1,5)=K(N+1,5)+ID2
13303         K(ID1,4)=K(ID1,4)+MSTU(5)*(N+1)
13304         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13305         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13306         K(ID2,5)=K(ID2,5)+MSTU(5)*(N+1)
13307         N=N+1
13308
13309 C...Boost to new CM-frame.
13310         CALL LUDBRB(NS+1,N,0.,0.,-DBLE((P(N,1)+P(IS(JR),1))/(P(N,4)+
13311      &  P(IS(JR),4))),0D0,-DBLE((P(N,3)+P(IS(JR),3))/(P(N,4)+
13312      &  P(IS(JR),4))))
13313         IR=N+(JT-1)*(IS(1)-N)
13314         CALL LUDBRB(NS+1,N,-ULANGL(P(IR,3),P(IR,1)),PARU(2)*RLU(0),
13315      &  0D0,0D0,0D0)
13316       ENDIF
13317
13318 C...Save quantities, loop back.
13319       IS(JT)=N
13320       Q2S(JT)=Q2B
13321       DQ2(JT)=Q2B
13322       IF(MSTP(62).GE.3) THE2(JT)=THE2T
13323       DSH=DSHZ
13324       IF(Q2B.GE.(0.5*PARP(62))**2) THEN
13325         KFLS(JT+2)=KFLS(JT)
13326         KFLS(JT)=KFLA
13327         XS(JT)=XA
13328         ZS(JT)=Z
13329         DO 270 KFL=-6,6
13330   270   XFS(JT,KFL)=XFA(KFL)
13331         TEVS(JT)=TEVB
13332       ELSE
13333         IF(JT.EQ.1) IPU1=N
13334         IF(JT.EQ.2) IPU2=N
13335       ENDIF
13336       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13337         CALL LUERRM(11,'(PYSSPA:) no more memory left in LUJETS')
13338         IF(MSTU(21).GE.1) N=NS
13339         IF(MSTU(21).GE.1) RETURN
13340       ENDIF
13341       IF(MAX(Q2S(1),Q2S(2)).GE.(0.5*PARP(62))**2.OR.N.LE.NS+1) GOTO 120
13342
13343 C...Boost hard scattering partons to frame of shower initiators.
13344       DO 280 J=1,3
13345   280 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13346       DO 290 J=1,5
13347   290 P(N+2,J)=P(NS+1,J)
13348       ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
13349       IF(ROBOT.GE.0.999999) THEN
13350         ROBOT=1.00001*SQRT(ROBOT)
13351         ROBO(3)=ROBO(3)/ROBOT
13352         ROBO(4)=ROBO(4)/ROBOT
13353         ROBO(5)=ROBO(5)/ROBOT
13354       ENDIF
13355       CALL LUDBRB(N+2,N+2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),
13356      &-DBLE(ROBO(5)))
13357       ROBO(2)=ULANGL(P(N+2,1),P(N+2,2))
13358       ROBO(1)=ULANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
13359       CALL LUDBRB(MINT(83)+5,NS,ROBO(1),ROBO(2),DBLE(ROBO(3)),
13360      &DBLE(ROBO(4)),DBLE(ROBO(5)))
13361
13362 C...Store user information. Reset Lambda value.
13363       K(IPU1,3)=MINT(83)+3
13364       K(IPU2,3)=MINT(83)+4
13365       DO 300 JT=1,2
13366       MINT(12+JT)=KFLS(JT)
13367   300 VINT(140+JT)=XS(JT)
13368       PARU(111)=ALAMS
13369  1000 FORMAT(5X,'structure function has a zero point here')
13370  1001 FORMAT(5X,'xf(x,i=',I5,')=',F10.5)
13371
13372       RETURN
13373       END
13374
13375 C*********************************************************************
13376
13377       SUBROUTINE PYMULT(MMUL)
13378
13379 C...Initializes treatment of multiple interactions, selects kinematics
13380 C...of hardest interaction if low-pT physics included in run, and
13381 C...generates all non-hardest interactions.
13382       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
13383       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13384       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
13385       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
13386       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13387       COMMON/PYINT1/MINT(400),VINT(400)
13388       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
13389       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13390       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
13391       DIMENSION NMUL(20),SIGM(20),KSTR(500,2)
13392       SAVE
13393
13394 C...Initialization of multiple interaction treatment.
13395       IF(MMUL.EQ.1) THEN
13396         IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(82)
13397         ISUB=96
13398         MINT(1)=96
13399         VINT(63)=0.
13400         VINT(64)=0.
13401         VINT(143)=1.
13402         VINT(144)=1.
13403
13404 C...Loop over phase space points: xT2 choice in 20 bins.
13405   100   SIGSUM=0.
13406         DO 120 IXT2=1,20
13407         NMUL(IXT2)=MSTP(83)
13408         SIGM(IXT2)=0.
13409         DO 110 ITRY=1,MSTP(83)
13410         RSCA=0.05*((21-IXT2)-RLU(0))
13411         XT2=VINT(149)*(1.+VINT(149))/(VINT(149)+RSCA)-VINT(149)
13412         XT2=MAX(0.01*VINT(149),XT2)
13413         VINT(25)=XT2
13414
13415 C...Choose tau and y*. Calculate cos(theta-hat).
13416         IF(RLU(0).LE.COEF(ISUB,1)) THEN
13417           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
13418           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
13419         ELSE
13420           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
13421         ENDIF
13422         VINT(21)=TAU
13423         CALL PYKLIM(2)
13424         RYST=RLU(0)
13425         MYST=1
13426         IF(RYST.GT.COEF(ISUB,7)) MYST=2
13427         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
13428         CALL PYKMAP(2,MYST,RLU(0))
13429         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
13430
13431 C...Calculate differential cross-section.
13432         VINT(71)=0.5*VINT(1)*SQRT(XT2)
13433         CALL PYSIGH(NCHN,SIGS)
13434   110   SIGM(IXT2)=SIGM(IXT2)+SIGS
13435   120   SIGSUM=SIGSUM+SIGM(IXT2)
13436         SIGSUM=SIGSUM/(20.*MSTP(83))
13437
13438 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
13439         IF(SIGSUM.LT.1.1*VINT(106)) THEN
13440           IF(MSTP(122).GE.1) WRITE(MSTU(11),1100) PARP(82),SIGSUM
13441           PARP(82)=0.9*PARP(82)
13442           VINT(149)=4.*PARP(82)**2/VINT(2)
13443           GOTO 100
13444         ENDIF
13445         IF(MSTP(122).GE.1) WRITE(MSTU(11),1200) PARP(82), SIGSUM
13446
13447 C...Start iteration to find k factor.
13448         YKE=SIGSUM/VINT(106)
13449         SO=0.5
13450         XI=0.
13451         YI=0.
13452         XK=0.5
13453         IIT=0
13454   130   IF(IIT.EQ.0) THEN
13455           XK=2.*XK
13456         ELSEIF(IIT.EQ.1) THEN
13457           XK=0.5*XK
13458         ELSE
13459           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
13460         ENDIF
13461
13462 C...Evaluate overlap integrals.
13463         IF(MSTP(82).EQ.2) THEN
13464           SP=0.5*PARU(1)*(1.-EXP(-XK))
13465           SOP=SP/PARU(1)
13466         ELSE
13467           IF(MSTP(82).EQ.3) DELTAB=0.02
13468           IF(MSTP(82).EQ.4) DELTAB=MIN(0.01,0.05*PARP(84))
13469           SP=0.
13470           SOP=0.
13471           B=-0.5*DELTAB
13472   140     B=B+DELTAB
13473           IF(MSTP(82).EQ.3) THEN
13474             OV=EXP(-B**2)/PARU(2)
13475           ELSE
13476             CQ2=PARP(84)**2
13477             OV=((1.-PARP(83))**2*EXP(-MIN(100.,B**2))+2.*PARP(83)*
13478      &      (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B**2*2./(1.+CQ2)))+
13479      &      PARP(83)**2/CQ2*EXP(-MIN(100.,B**2/CQ2)))/PARU(2)
13480           ENDIF
13481           PACC=1.-EXP(-MIN(100.,PARU(1)*XK*OV))
13482           SP=SP+PARU(2)*B*DELTAB*PACC
13483           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
13484           IF(B.LT.1..OR.B*PACC.GT.1E-6) GOTO 140
13485         ENDIF
13486         YK=PARU(1)*XK*SO/SP
13487
13488 C...Continue iteration until convergence.
13489         IF(YK.LT.YKE) THEN
13490           XI=XK
13491           YI=YK
13492           IF(IIT.EQ.1) IIT=2
13493         ELSE
13494           XF=XK
13495           YF=YK
13496           IF(IIT.EQ.0) IIT=1
13497         ENDIF
13498         IF(ABS(YK-YKE).GE.1E-5*YKE) GOTO 130
13499
13500 C...Store some results for subsequent use.
13501         VINT(145)=SIGSUM
13502         VINT(146)=SOP/SO
13503         VINT(147)=SOP/SP
13504
13505 C...Initialize iteration in xT2 for hardest interaction.
13506       ELSEIF(MMUL.EQ.2) THEN
13507         IF(MSTP(82).LE.0) THEN
13508         ELSEIF(MSTP(82).EQ.1) THEN
13509           XT2=1.
13510           XT2FAC=XSEC(96,1)/VINT(106)*VINT(149)/(1.-VINT(149))
13511         ELSEIF(MSTP(82).EQ.2) THEN
13512           XT2=1.
13513           XT2FAC=VINT(146)*XSEC(96,1)/VINT(106)*VINT(149)*(1.+VINT(149))
13514         ELSE
13515           XC2=4.*CKIN(3)**2/VINT(2)
13516           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0.
13517         ENDIF
13518
13519       ELSEIF(MMUL.EQ.3) THEN
13520 C...Low-pT or multiple interactions (first semihard interaction):
13521 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
13522 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
13523         ISUB=MINT(1)
13524         IF(MSTP(82).LE.0) THEN
13525           XT2=0.
13526         ELSEIF(MSTP(82).EQ.1) THEN
13527           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
13528         ELSEIF(MSTP(82).EQ.2) THEN
13529           IF(XT2.LT.1..AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
13530      &    VINT(149)))).GT.RLU(0)) XT2=1.
13531           IF(XT2.GE.1.) THEN
13532             XT2=(1.+VINT(149))*XT2FAC/(XT2FAC-(1.+VINT(149))*LOG(1.-
13533      &      RLU(0)*(1.-EXP(-XT2FAC/(VINT(149)*(1.+VINT(149)))))))-
13534      &      VINT(149)
13535           ELSE
13536             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+RLU(0)*
13537      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
13538      &      VINT(149)
13539           ENDIF
13540           XT2=MAX(0.01*VINT(149),XT2)
13541         ELSE
13542           XT2=(XC2+VINT(149))*(1.+VINT(149))/(1.+VINT(149)-
13543      &    RLU(0)*(1.-XC2))-VINT(149)
13544           XT2=MAX(0.01*VINT(149),XT2)
13545         ENDIF
13546         VINT(25)=XT2
13547
13548 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
13549         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
13550           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
13551           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
13552           ISUB=95
13553           MINT(1)=ISUB
13554           VINT(21)=0.01*VINT(149)
13555           VINT(22)=0.
13556           VINT(23)=0.
13557           VINT(25)=0.01*VINT(149)
13558
13559         ELSE
13560 C...Multiple interactions (first semihard interaction).
13561 C...Choose tau and y*. Calculate cos(theta-hat).
13562           IF(RLU(0).LE.COEF(ISUB,1)) THEN
13563             TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
13564             TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
13565           ELSE
13566             TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
13567           ENDIF
13568           VINT(21)=TAU
13569           CALL PYKLIM(2)
13570           RYST=RLU(0)
13571           MYST=1
13572           IF(RYST.GT.COEF(ISUB,7)) MYST=2
13573           IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
13574           CALL PYKMAP(2,MYST,RLU(0))
13575           VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
13576         ENDIF
13577         VINT(71)=0.5*VINT(1)*SQRT(VINT(25))
13578
13579 C...Store results of cross-section calculation.
13580       ELSEIF(MMUL.EQ.4) THEN
13581         ISUB=MINT(1)
13582         XTS=VINT(25)
13583         IF(ISET(ISUB).EQ.1) XTS=VINT(21)
13584         IF(ISET(ISUB).EQ.2) XTS=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
13585      &  VINT(2)
13586         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XTS=VINT(26)
13587         RBIN=MAX(0.000001,MIN(0.999999,XTS*(1.+VINT(149))/
13588      &  (XTS+VINT(149))))
13589         IRBIN=INT(1.+20.*RBIN)
13590         IF(ISUB.EQ.96) NMUL(IRBIN)=NMUL(IRBIN)+1
13591         IF(ISUB.EQ.96) SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
13592
13593 C...Choose impact parameter.
13594       ELSEIF(MMUL.EQ.5) THEN
13595         IF(MSTP(82).EQ.3) THEN
13596           VINT(148)=RLU(0)/(PARU(2)*VINT(147))
13597         ELSE
13598           RTYPE=RLU(0)
13599           CQ2=PARP(84)**2
13600           IF(RTYPE.LT.(1.-PARP(83))**2) THEN
13601             B2=-LOG(RLU(0))
13602           ELSEIF(RTYPE.LT.1.-PARP(83)**2) THEN
13603             B2=-0.5*(1.+CQ2)*LOG(RLU(0))
13604           ELSE
13605             B2=-CQ2*LOG(RLU(0))
13606           ENDIF
13607           VINT(148)=((1.-PARP(83))**2*EXP(-MIN(100.,B2))+2.*PARP(83)*
13608      &    (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B2*2./(1.+CQ2)))+
13609      &    PARP(83)**2/CQ2*EXP(-MIN(100.,B2/CQ2)))/(PARU(2)*VINT(147))
13610         ENDIF
13611
13612 C...Multiple interactions (variable impact parameter) : reject with
13613 C...probability exp(-overlap*cross-section above pT/normalization).
13614         RNCOR=(IRBIN-20.*RBIN)*NMUL(IRBIN)
13615         SIGCOR=(IRBIN-20.*RBIN)*SIGM(IRBIN)
13616         DO 150 IBIN=IRBIN+1,20
13617         RNCOR=RNCOR+NMUL(IBIN)
13618   150   SIGCOR=SIGCOR+SIGM(IBIN)
13619         SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1.-XTS)/(XTS+VINT(149))
13620         VINT(150)=EXP(-MIN(100.,VINT(146)*VINT(148)*SIGABV/VINT(106)))
13621
13622 C...Generate additional multiple semihard interactions.
13623       ELSEIF(MMUL.EQ.6) THEN
13624
13625 C...Reconstruct strings in hard scattering.
13626         ISUB=MINT(1)
13627         NMAX=MINT(84)+4
13628         IF(ISET(ISUB).EQ.1) NMAX=MINT(84)+2
13629         NSTR=0
13630         DO 170 I=MINT(84)+1,NMAX
13631         KCS=KCHG(LUCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
13632         IF(KCS.EQ.0) GOTO 170
13633         DO 160 J=1,4
13634         IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 160
13635         IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 160
13636         IF(J.LE.2) THEN
13637           IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
13638         ELSE
13639           IST=MOD(K(I,J+1),MSTU(5))
13640         ENDIF
13641         IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 160
13642         IF(KCHG(LUCOMP(K(IST,2)),2).EQ.0) GOTO 160
13643         NSTR=NSTR+1
13644         IF(J.EQ.1.OR.J.EQ.4) THEN
13645           KSTR(NSTR,1)=I
13646           KSTR(NSTR,2)=IST
13647         ELSE
13648           KSTR(NSTR,1)=IST
13649           KSTR(NSTR,2)=I
13650         ENDIF
13651   160   CONTINUE
13652   170   CONTINUE
13653
13654 C...Set up starting values for iteration in xT2.
13655         XT2=VINT(25)
13656         IF(ISET(ISUB).EQ.1) XT2=VINT(21)
13657         IF(ISET(ISUB).EQ.2) XT2=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
13658      &  VINT(2)
13659         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XT2=VINT(26)
13660         ISUB=96
13661         MINT(1)=96
13662         IF(MSTP(82).LE.1) THEN
13663           XT2FAC=XSEC(ISUB,1)*VINT(149)/((1.-VINT(149))*VINT(106))
13664         ELSE
13665           XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/VINT(106)*
13666      &    VINT(149)*(1.+VINT(149))
13667         ENDIF
13668         VINT(63)=0.
13669         VINT(64)=0.
13670         VINT(151)=0.
13671         VINT(152)=0.
13672         VINT(143)=1.-VINT(141)
13673         VINT(144)=1.-VINT(142)
13674
13675 C...Iterate downwards in xT2.
13676   180   IF(MSTP(82).LE.1) THEN
13677           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
13678           IF(XT2.LT.VINT(149)) GOTO 220
13679         ELSE
13680           IF(XT2.LE.0.01*VINT(149)) GOTO 220
13681           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
13682      &    LOG(RLU(0)))-VINT(149)
13683           IF(XT2.LE.0.) GOTO 220
13684           XT2=MAX(0.01*VINT(149),XT2)
13685         ENDIF
13686         VINT(25)=XT2
13687
13688 C...Choose tau and y*. Calculate cos(theta-hat).
13689         IF(RLU(0).LE.COEF(ISUB,1)) THEN
13690           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
13691           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
13692         ELSE
13693           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
13694         ENDIF
13695         VINT(21)=TAU
13696         CALL PYKLIM(2)
13697         RYST=RLU(0)
13698         MYST=1
13699         IF(RYST.GT.COEF(ISUB,7)) MYST=2
13700         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
13701         CALL PYKMAP(2,MYST,RLU(0))
13702         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
13703
13704 C...Check that x not used up. Accept or reject kinematical variables.
13705         X1M=SQRT(TAU)*EXP(VINT(22))
13706         X2M=SQRT(TAU)*EXP(-VINT(22))
13707         IF(VINT(143)-X1M.LT.0.01.OR.VINT(144)-X2M.LT.0.01) GOTO 180
13708         VINT(71)=0.5*VINT(1)*SQRT(XT2)
13709         CALL PYSIGH(NCHN,SIGS)
13710         IF(SIGS.LT.XSEC(ISUB,1)*RLU(0)) GOTO 180
13711
13712 C...Reset K, P and V vectors. Select some variables.
13713         DO 190 I=N+1,N+2
13714         DO 190 J=1,5
13715         K(I,J)=0
13716         P(I,J)=0.
13717   190   V(I,J)=0.
13718         RFLAV=RLU(0)
13719         PT=0.5*VINT(1)*SQRT(XT2)
13720         PHI=PARU(2)*RLU(0)
13721         CTH=VINT(23)
13722
13723 C...Add first parton to event record.
13724         K(N+1,1)=3
13725         K(N+1,2)=21
13726         IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
13727      &  1+INT((2.+PARJ(2))*RLU(0))
13728         P(N+1,1)=PT*COS(PHI)
13729         P(N+1,2)=PT*SIN(PHI)
13730         P(N+1,3)=0.25*VINT(1)*(VINT(41)*(1.+CTH)-VINT(42)*(1.-CTH))
13731         P(N+1,4)=0.25*VINT(1)*(VINT(41)*(1.+CTH)+VINT(42)*(1.-CTH))
13732         P(N+1,5)=0.
13733
13734 C...Add second parton to event record.
13735         K(N+2,1)=3
13736         K(N+2,2)=21
13737         IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
13738         P(N+2,1)=-P(N+1,1)
13739         P(N+2,2)=-P(N+1,2)
13740         P(N+2,3)=0.25*VINT(1)*(VINT(41)*(1.-CTH)-VINT(42)*(1.+CTH))
13741         P(N+2,4)=0.25*VINT(1)*(VINT(41)*(1.-CTH)+VINT(42)*(1.+CTH))
13742         P(N+2,5)=0.
13743
13744         IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
13745 C....Choose relevant string pieces to place gluons on.
13746           DO 210 I=N+1,N+2
13747           DMIN=1E8
13748           DO 200 ISTR=1,NSTR
13749           I1=KSTR(ISTR,1)
13750           I2=KSTR(ISTR,2)
13751           DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
13752      &    P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
13753      &    P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1.,P(I1,4)*P(I2,4)-
13754      &    P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
13755           IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
13756             DMIN=DIST
13757             IST1=I1
13758             IST2=I2
13759             ISTM=ISTR
13760           ENDIF
13761   200     CONTINUE
13762
13763 C....Colour flow adjustments, new string pieces.
13764           IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
13765      &    MOD(K(IST1,4),MSTU(5))
13766           IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
13767      &    MSTU(5)*(K(IST1,5)/MSTU(5))+I
13768           K(I,5)=MSTU(5)*IST1
13769           K(I,4)=MSTU(5)*IST2
13770           IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
13771      &    MOD(K(IST2,5),MSTU(5))
13772           IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
13773      &    MSTU(5)*(K(IST2,4)/MSTU(5))+I
13774           KSTR(ISTM,2)=I
13775           KSTR(NSTR+1,1)=I
13776           KSTR(NSTR+1,2)=IST2
13777   210     NSTR=NSTR+1
13778
13779 C...String drawing and colour flow for gluon loop.
13780         ELSEIF(K(N+1,2).EQ.21) THEN
13781           K(N+1,4)=MSTU(5)*(N+2)
13782           K(N+1,5)=MSTU(5)*(N+2)
13783           K(N+2,4)=MSTU(5)*(N+1)
13784           K(N+2,5)=MSTU(5)*(N+1)
13785           KSTR(NSTR+1,1)=N+1
13786           KSTR(NSTR+1,2)=N+2
13787           KSTR(NSTR+2,1)=N+2
13788           KSTR(NSTR+2,2)=N+1
13789           NSTR=NSTR+2
13790
13791 C...String drawing and colour flow for q-qbar pair.
13792         ELSE
13793           K(N+1,4)=MSTU(5)*(N+2)
13794           K(N+2,5)=MSTU(5)*(N+1)
13795           KSTR(NSTR+1,1)=N+1
13796           KSTR(NSTR+1,2)=N+2
13797           NSTR=NSTR+1
13798         ENDIF
13799
13800 C...Update remaining energy; iterate.
13801         N=N+2
13802         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13803           CALL LUERRM(11,'(PYMULT:) no more memory left in LUJETS')
13804           IF(MSTU(21).GE.1) RETURN
13805         ENDIF
13806         MINT(31)=MINT(31)+1
13807         VINT(151)=VINT(151)+VINT(41)
13808         VINT(152)=VINT(152)+VINT(42)
13809         VINT(143)=VINT(143)-VINT(41)
13810         VINT(144)=VINT(144)-VINT(42)
13811         IF(MINT(31).LT.240) GOTO 180
13812   220   CONTINUE
13813       ENDIF
13814
13815 C...Format statements for printout.
13816  1000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
13817      &'actions for MSTP(82) =',I2,' ******')
13818  1100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
13819      &E9.2,' mb: rejected')
13820  1200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
13821      &E9.2,' mb: accepted')
13822
13823       RETURN
13824       END
13825
13826 C*********************************************************************
13827
13828       SUBROUTINE PYREMN(IPU1,IPU2)
13829
13830 C...Adds on target remnants (one or two from each side) and
13831 C...includes primordial kT.
13832       COMMON/HIPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
13833       COMMON/HISTRNG/NFP(300,15),PPHI(300,15),NFT(300,15),PTHI(300,15)
13834 C...COMMON BLOCK FROM HIJING
13835       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
13836       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13837       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
13838       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13839       COMMON/PYINT1/MINT(400),VINT(400)
13840       DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)
13841       SAVE
13842 C...Special case for lepton-lepton interaction.
13843       IF(MINT(43).EQ.1) THEN
13844         DO 100 JT=1,2
13845         I=MINT(83)+JT+2
13846         K(I,1)=21
13847         K(I,2)=K(I-2,2)
13848         K(I,3)=I-2
13849         DO 100 J=1,5
13850   100   P(I,J)=P(I-2,J)
13851       ENDIF
13852
13853 C...Find event type, set pointers.
13854       IF(IPU1.EQ.0.AND.IPU2.EQ.0) RETURN
13855       ISUB=MINT(1)
13856       ILEP=0
13857       IF(IPU1.EQ.0) ILEP=1
13858       IF(IPU2.EQ.0) ILEP=2
13859       IF(ISUB.EQ.95) ILEP=-1
13860       IF(ILEP.EQ.1) IQ=MINT(84)+1
13861       IF(ILEP.EQ.2) IQ=MINT(84)+2
13862       IP=MAX(IPU1,IPU2)
13863       ILEPR=MINT(83)+5-ILEP
13864       NS=N
13865
13866 C...Define initial partons, including primordial kT.
13867   110 DO 130 JT=1,2
13868       I=MINT(83)+JT+2
13869       IF(JT.EQ.1) IPU=IPU1
13870       IF(JT.EQ.2) IPU=IPU2
13871       K(I,1)=21
13872       K(I,3)=I-2
13873       IF(ISUB.EQ.95) THEN
13874         K(I,2)=21
13875         SHS=0.
13876       ELSEIF(MINT(40+JT).EQ.1.AND.IPU.NE.0) THEN
13877         K(I,2)=K(IPU,2)
13878         P(I,5)=P(IPU,5)
13879         P(I,1)=0.
13880         P(I,2)=0.
13881         PMS(JT)=P(I,5)**2
13882       ELSEIF(IPU.NE.0) THEN
13883         K(I,2)=K(IPU,2)
13884         P(I,5)=P(IPU,5)
13885 C...No primordial kT or chosen according to truncated Gaussian or
13886 C...exponential.
13887 C
13888 c     X.N. Wang (7.22.97)
13889 c
13890         RPT1=0.0
13891         RPT2=0.0
13892         SS_W2=(PPHI(IHNT2(11),4)+PTHI(IHNT2(12),4))**2
13893      &       -(PPHI(IHNT2(11),1)+PTHI(IHNT2(12),1))**2
13894      &       -(PPHI(IHNT2(11),2)+PTHI(IHNT2(12),2))**2
13895      &       -(PPHI(IHNT2(11),3)+PTHI(IHNT2(12),3))**2
13896 C
13897 C********this is s of the current NN collision
13898         IF(SS_W2.LE.4.0*PARP(93)**2) GOTO 1211
13899 c
13900         IF(IHPR2(5).LE.0) THEN
13901 120          IF(MSTP(91).LE.0) THEN
13902                PT=0.
13903              ELSEIF(MSTP(91).EQ.1) THEN
13904                PT=PARP(91)*SQRT(-LOG(RLU(0)))
13905              ELSE
13906                RPT1=RLU(0)
13907                RPT2=RLU(0)
13908                PT=-PARP(92)*LOG(RPT1*RPT2)
13909              ENDIF
13910              IF(PT.GT.PARP(93)) GOTO 120
13911              PHI=PARU(2)*RLU(0)
13912              RPT1=PT*COS(PHI)
13913              RPT2=PT*SIN(PHI)
13914         ELSE IF(IHPR2(5).EQ.1) THEN
13915              IF(JT.EQ.1) JPT=NFP(IHNT2(11),11)
13916              IF(JT.EQ.2) JPT=NFT(IHNT2(12),11)
13917 1205         PTGS=PARP(91)*SQRT(-LOG(RLU(0)))
13918              IF(PTGS.GT.PARP(93)) GO TO 1205
13919              PHI=2.0*HIPR1(40)*RLU(0)
13920              RPT1=PTGS*COS(PHI)
13921              RPT2=PTGS*SIN(PHI)
13922              DO 1210 I_INT=1,JPT-1
13923                 PKCSQ=PARP(91)*SQRT(-LOG(RLU(0)))
13924                 PHI=2.0*HIPR1(40)*RLU(0)
13925                 RPT1=RPT1+PKCSQ*COS(PHI)
13926                 RPT2=RPT2+PKCSQ*SIN(PHI)
13927 1210         CONTINUE
13928              IF(RPT1**2+RPT2**2.GE.SS_W2/4.0) GO TO 1205
13929         ENDIF
13930 C     X.N. Wang
13931 C                       ********When initial interaction among soft partons is
13932 C                               assumed the primordial pt comes from the sum of
13933 C                               pt of JPT-1 number of initial interaction, JPT
13934 C                               is the number of interaction including present
13935 C                               one that nucleon hassuffered
13936 1211    P(I,1)=RPT1
13937         P(I,2)=RPT2
13938         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
13939       ELSE
13940         K(I,2)=K(IQ,2)
13941         Q2=VINT(52)
13942         P(I,5)=-SQRT(Q2)
13943         PMS(JT)=-Q2
13944         SHS=(1.-VINT(43-JT))*Q2/VINT(43-JT)+VINT(5-JT)**2
13945       ENDIF
13946   130 CONTINUE
13947
13948 C...Kinematics construction for initial partons.
13949       I1=MINT(83)+3
13950       I2=MINT(83)+4
13951       IF(ILEP.EQ.0) SHS=VINT(141)*VINT(142)*VINT(2)+
13952      &(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2
13953       SHR=SQRT(MAX(0.,SHS))
13954       IF(ILEP.EQ.0) THEN
13955         IF((SHS-PMS(1)-PMS(2))**2-4.*PMS(1)*PMS(2).LE.0.) GOTO 110
13956         P(I1,4)=0.5*(SHR+(PMS(1)-PMS(2))/SHR)
13957         P(I1,3)=SQRT(MAX(0.,P(I1,4)**2-PMS(1)))
13958         P(I2,4)=SHR-P(I1,4)
13959         P(I2,3)=-P(I1,3)
13960       ELSEIF(ILEP.EQ.1) THEN
13961         P(I1,4)=P(IQ,4)
13962         P(I1,3)=P(IQ,3)
13963         P(I2,4)=P(IP,4)
13964         P(I2,3)=P(IP,3)
13965       ELSEIF(ILEP.EQ.2) THEN
13966         P(I1,4)=P(IP,4)
13967         P(I1,3)=P(IP,3)
13968         P(I2,4)=P(IQ,4)
13969         P(I2,3)=P(IQ,3)
13970       ENDIF
13971       IF(MINT(43).EQ.1) RETURN
13972
13973 C...Transform partons to overall CM-frame (not for leptoproduction).
13974       IF(ILEP.EQ.0) THEN
13975         ROBO(3)=(P(I1,1)+P(I2,1))/SHR
13976         ROBO(4)=(P(I1,2)+P(I2,2))/SHR
13977         CALL LUDBRB(I1,I2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),0D0)
13978         ROBO(2)=ULANGL(P(I1,1),P(I1,2))
13979         CALL LUDBRB(I1,I2,0.,-ROBO(2),0D0,0D0,0D0)
13980         ROBO(1)=ULANGL(P(I1,3),P(I1,1))
13981         CALL LUDBRB(I1,I2,-ROBO(1),0.,0D0,0D0,0D0)
13982         NMAX=MAX(MINT(52),IPU1,IPU2)
13983         CALL LUDBRB(I1,NMAX,ROBO(1),ROBO(2),DBLE(ROBO(3)),DBLE(ROBO(4)),
13984      &  0D0)
13985         ROBO(5)=MAX(-0.999999,MIN(0.999999,(VINT(141)-VINT(142))/
13986      &  (VINT(141)+VINT(142))))
13987         CALL LUDBRB(I1,NMAX,0.,0.,0D0,0D0,DBLE(ROBO(5)))
13988       ENDIF
13989
13990 C...Check invariant mass of remnant system:
13991 C...hadronic events or leptoproduction.
13992       IF(ILEP.LE.0) THEN
13993         IF(MSTP(81).LE.0.OR.MSTP(82).LE.0.OR.ISUB.EQ.95) THEN
13994           VINT(151)=0.
13995           VINT(152)=0.
13996         ENDIF
13997         PEH=P(I1,4)+P(I2,4)+0.5*VINT(1)*(VINT(151)+VINT(152))
13998         PZH=P(I1,3)+P(I2,3)+0.5*VINT(1)*(VINT(151)-VINT(152))
13999         SHH=(VINT(1)-PEH)**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+P(I2,2))**2-
14000      &  PZH**2
14001         PMMIN=P(MINT(83)+1,5)+P(MINT(83)+2,5)+ULMASS(K(I1,2))+
14002      &  ULMASS(K(I2,2))
14003         IF(SHR.GE.VINT(1).OR.SHH.LE.(PMMIN+PARP(111))**2) THEN
14004           MINT(51)=1
14005           RETURN
14006         ENDIF
14007         SHR=SQRT(SHH+(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2)
14008       ELSE
14009         PEI=P(IQ,4)+P(IP,4)
14010         PZI=P(IQ,3)+P(IP,3)
14011         PMS(ILEP)=MAX(0.,PEI**2-PZI**2)
14012         PMMIN=P(ILEPR-2,5)+ULMASS(K(ILEPR,2))+SQRT(PMS(ILEP))
14013         IF(SHR.LE.PMMIN+PARP(111)) THEN
14014           MINT(51)=1
14015           RETURN
14016         ENDIF
14017       ENDIF
14018
14019 C...Subdivide remnant if necessary, store first parton.
14020   140 I=NS
14021       DO 190 JT=1,2
14022       IF(JT.EQ.ILEP) GOTO 190
14023       IF(JT.EQ.1) IPU=IPU1
14024       IF(JT.EQ.2) IPU=IPU2
14025       CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14026       I=I+1
14027       IS(JT)=I
14028       DO 150 J=1,5
14029       K(I,J)=0
14030       P(I,J)=0.
14031   150 V(I,J)=0.
14032       K(I,1)=3
14033       K(I,2)=KFLSP(JT)
14034       K(I,3)=MINT(83)+JT
14035       P(I,5)=ULMASS(K(I,2))
14036
14037 C...First parton colour connections and transverse mass.
14038       KFLS=(3-KCHG(LUCOMP(KFLSP(JT)),2)*ISIGN(1,KFLSP(JT)))/2
14039       K(I,KFLS+3)=IPU
14040       K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14041       IF(KFLCH(JT).EQ.0) THEN
14042         P(I,1)=-P(MINT(83)+JT+2,1)
14043         P(I,2)=-P(MINT(83)+JT+2,2)
14044         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14045
14046 C...When extra remnant parton or hadron: find relative pT, store.
14047       ELSE
14048         CALL LUPTDI(1,P(I,1),P(I,2))
14049         PMS(JT+2)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14050         I=I+1
14051         DO 160 J=1,5
14052         K(I,J)=0
14053         P(I,J)=0.
14054   160   V(I,J)=0.
14055         K(I,1)=1
14056         K(I,2)=KFLCH(JT)
14057         K(I,3)=MINT(83)+JT
14058         P(I,5)=ULMASS(K(I,2))
14059         P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14060         P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14061         PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14062 C...Relative distribution of energy for particle into two jets.
14063         IMB=1
14064         IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14065         IF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14066           CHIK=PARP(92+2*IMB)
14067           IF(MSTP(92).LE.1) THEN
14068             IF(IMB.EQ.1) CHI(JT)=RLU(0)
14069             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
14070           ELSEIF(MSTP(92).EQ.2) THEN
14071             CHI(JT)=1.-RLU(0)**(1./(1.+CHIK))
14072           ELSEIF(MSTP(92).EQ.3) THEN
14073             CUT=2.*0.3/VINT(1)
14074   170       CHI(JT)=RLU(0)**2
14075             IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25*(1.-CHI(JT))**CHIK
14076      &      .LT.RLU(0)) GOTO 170
14077           ELSE
14078             CUT=2.*0.3/VINT(1)
14079             CUTR=(1.+SQRT(1.+CUT**2))/CUT
14080   180       CHIR=CUT*CUTR**RLU(0)
14081             CHI(JT)=(CHIR**2-CUT**2)/(2.*CHIR)
14082             IF((1.-CHI(JT))**CHIK.LT.RLU(0)) GOTO 180
14083           ENDIF
14084 C...Relative distribution of energy for particle into jet plus particle.
14085         ELSE
14086           IF(MSTP(92).LE.1) THEN
14087             IF(IMB.EQ.1) CHI(JT)=RLU(0)
14088             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
14089           ELSE
14090             CHI(JT)=1.-RLU(0)**(1./(1.+PARP(93+2*IMB)))
14091           ENDIF
14092           IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1.-CHI(JT)
14093         ENDIF
14094         PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1.-CHI(JT))
14095         KFLS=KCHG(LUCOMP(KFLCH(JT)),2)*ISIGN(1,KFLCH(JT))
14096         IF(KFLS.NE.0) THEN
14097           K(I,1)=3
14098           KFLS=(3-KFLS)/2
14099           K(I,KFLS+3)=IPU
14100           K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14101         ENDIF
14102       ENDIF
14103   190 CONTINUE
14104       IF(SHR.LE.SQRT(PMS(1))+SQRT(PMS(2))) GOTO 140
14105       N=I
14106
14107 C...Reconstruct kinematics of remnants.
14108       DO 200 JT=1,2
14109       IF(JT.EQ.ILEP) GOTO 200
14110       PE=0.5*(SHR+(PMS(JT)-PMS(3-JT))/SHR)
14111       PZ=SQRT(PE**2-PMS(JT))
14112       IF(KFLCH(JT).EQ.0) THEN
14113         P(IS(JT),4)=PE
14114         P(IS(JT),3)=PZ*(-1)**(JT-1)
14115       ELSE
14116         PW1=CHI(JT)*(PE+PZ)
14117         P(IS(JT)+1,4)=0.5*(PW1+PMS(JT+4)/PW1)
14118         P(IS(JT)+1,3)=0.5*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
14119         P(IS(JT),4)=PE-P(IS(JT)+1,4)
14120         P(IS(JT),3)=PZ*(-1)**(JT-1)-P(IS(JT)+1,3)
14121       ENDIF
14122   200 CONTINUE
14123
14124 C...Hadronic events: boost remnants to correct longitudinal frame.
14125       IF(ILEP.LE.0) THEN
14126         CALL LUDBRB(NS+1,N,0.,0.,0D0,0D0,-DBLE(PZH/(VINT(1)-PEH)))
14127 C...Leptoproduction events: boost colliding subsystem.
14128       ELSE
14129         NMAX=MAX(IP,MINT(52))
14130         PEF=SHR-PE
14131         PZF=PZ*(-1)**(ILEP-1)
14132         PT2=P(ILEPR,1)**2+P(ILEPR,2)**2
14133         PHIPT=ULANGL(P(ILEPR,1),P(ILEPR,2))
14134         CALL LUDBRB(MINT(84)+1,NMAX,0.,-PHIPT,0D0,0D0,0D0)
14135         RQP=P(IQ,3)*(PT2+PEI**2)-P(IQ,4)*PEI*PZI
14136         SINTH=P(IQ,4)*SQRT(PT2*(PT2+PEI**2)/(RQP**2+PT2*
14137      &  P(IQ,4)**2*PZI**2))*SIGN(1.,-RQP)
14138         CALL LUDBRB(MINT(84)+1,NMAX,ASIN(SINTH),0.,0D0,0D0,0D0)
14139         BETAX=(-PEI*PZI*SINTH+SQRT(PT2*(PT2+PEI**2-(PZI*SINTH)**2)))/
14140      &  (PT2+PEI**2)
14141         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,DBLE(BETAX),0D0,0D0)
14142         CALL LUDBRB(MINT(84)+1,NMAX,0.,PHIPT,0D0,0D0,0D0)
14143         PEM=P(IQ,4)+P(IP,4)
14144         PZM=P(IQ,3)+P(IP,3)
14145         BETAZ=(-PEM*PZM+PZF*SQRT(PZF**2+PEM**2-PZM**2))/(PZF**2+PEM**2)
14146         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,0D0,0D0,DBLE(BETAZ))
14147         CALL LUDBRB(I1,I2,ASIN(SINTH),0.,DBLE(BETAX),0D0,0D0)
14148         CALL LUDBRB(I1,I2,0.,PHIPT,0D0,0D0,DBLE(BETAZ))
14149       ENDIF
14150
14151       RETURN
14152       END
14153
14154 C*********************************************************************
14155
14156       SUBROUTINE PYRESD
14157
14158 C...Allows resonances to decay (including parton showers for hadronic
14159 C...channels).
14160       IMPLICIT DOUBLE PRECISION(D)
14161       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
14162       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14163       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
14164       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
14165       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
14166       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14167       COMMON/PYINT1/MINT(400),VINT(400)
14168       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
14169       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
14170       DIMENSION IREF(10,6),KDCY(2),KFL1(2),KFL2(2),NSD(2),ILIN(6),
14171      &COUP(6,4),PK(6,4),PKK(6,6),CTHE(2),PHI(2),WDTP(0:40),
14172      &WDTE(0:40,0:5)
14173       COMPLEX FGK,HA(6,6),HC(6,6)
14174       SAVE
14175
14176 C...The F, Xi and Xj functions of Gunion and Kunszt
14177 C...(Phys. Rev. D33, 665, plus errata from the authors).
14178       FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
14179      &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
14180       DIGK(DT,DU)=-4.*D34*D56+DT*(3.*DT+4.*DU)+DT**2*(DT*DU/(D34*D56)-
14181      &2.*(1./D34+1./D56)*(DT+DU)+2.*(D34/D56+D56/D34))
14182       DJGK(DT,DU)=8.*(D34+D56)**2-8.*(D34+D56)*(DT+DU)-6.*DT*DU-
14183      &2.*DT*DU*(DT*DU/(D34*D56)-2.*(1./D34+1./D56)*(DT+DU)+
14184      &2.*(D34/D56+D56/D34))
14185
14186 C...Define initial two objects, initialize loop.
14187       ISUB=MINT(1)
14188       SH=VINT(44)
14189       IREF(1,5)=0
14190       IREF(1,6)=0
14191       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
14192         IREF(1,1)=MINT(84)+2+ISET(ISUB)
14193         IREF(1,2)=0
14194         IREF(1,3)=MINT(83)+6+ISET(ISUB)
14195         IREF(1,4)=0
14196       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
14197         IREF(1,1)=MINT(84)+1+ISET(ISUB)
14198         IREF(1,2)=MINT(84)+2+ISET(ISUB)
14199         IREF(1,3)=MINT(83)+5+ISET(ISUB)
14200         IREF(1,4)=MINT(83)+6+ISET(ISUB)
14201       ENDIF
14202       NP=1
14203       IP=0
14204   100 IP=IP+1
14205       NINH=0
14206
14207 C...Loop over one/two resonances; reset decay rates.
14208       JTMAX=2
14209       IF(IP.EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3)) JTMAX=1
14210       DO 140 JT=1,JTMAX
14211       KDCY(JT)=0
14212       KFL1(JT)=0
14213       KFL2(JT)=0
14214       NSD(JT)=IREF(IP,JT)
14215       ID=IREF(IP,JT)
14216       IF(ID.EQ.0) GOTO 140
14217       KFA=IABS(K(ID,2))
14218       IF(KFA.LT.23.OR.KFA.GT.40) GOTO 140
14219       IF(MDCY(KFA,1).NE.0) THEN
14220         IF(ISUB.EQ.1.OR.ISUB.EQ.141) MINT(61)=1
14221         CALL PYWIDT(KFA,P(ID,5),WDTP,WDTE)
14222         IF(KCHG(KFA,3).EQ.0) THEN
14223           IPM=2
14224         ELSE
14225           IPM=(5+ISIGN(1,K(ID,2)))/2
14226         ENDIF
14227         IF(JTMAX.EQ.1.OR.IABS(K(IREF(IP,1),2)).NE.IABS(K(IREF(IP,2),2)))
14228      &  THEN
14229           I12=4
14230         ELSE
14231           IF(JT.EQ.1) I12=INT(4.5+RLU(0))
14232           I12=9-I12
14233         ENDIF
14234         RKFL=(WDTE(0,1)+WDTE(0,IPM)+WDTE(0,I12))*RLU(0)
14235         DO 120 I=1,MDCY(KFA,3)
14236         IDC=I+MDCY(KFA,2)-1
14237         KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
14238         KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
14239         RKFL=RKFL-(WDTE(I,1)+WDTE(I,IPM)+WDTE(I,I12))
14240         IF(RKFL.LE.0.) GOTO 130
14241   120   CONTINUE
14242   130   CONTINUE
14243       ENDIF
14244
14245 C...Summarize result on decay channel chosen.
14246       IF((KFA.EQ.23.OR.KFA.EQ.24).AND.KFL1(JT).EQ.0) NINH=NINH+1
14247       IF(KFL1(JT).EQ.0) GOTO 140
14248       KDCY(JT)=2
14249       IF(IABS(KFL1(JT)).LE.10.OR.KFL1(JT).EQ.21) KDCY(JT)=1
14250       IF((IABS(KFL1(JT)).GE.23.AND.IABS(KFL1(JT)).LE.25).OR.
14251      &(IABS(KFL1(JT)).EQ.37)) KDCY(JT)=3
14252       NSD(JT)=N
14253
14254 C...Fill decay products, prepared for parton showers for quarks.
14255       IF(KDCY(JT).EQ.1) THEN
14256         CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),P(ID,5))
14257       ELSE
14258         CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
14259       ENDIF
14260       IF(JTMAX.EQ.1) THEN
14261         CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*RLU(0)
14262         IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
14263         PHI(JT)=VINT(24)
14264       ELSE
14265         CTHE(JT)=2.*RLU(0)-1.
14266         PHI(JT)=PARU(2)*RLU(0)
14267       ENDIF
14268   140 CONTINUE
14269       IF(MINT(3).EQ.1.AND.IP.EQ.1) THEN
14270         MINT(25)=KFL1(1)
14271         MINT(26)=KFL2(1)
14272       ENDIF
14273       IF(JTMAX.EQ.1.AND.KDCY(1).EQ.0) GOTO 530
14274       IF(JTMAX.EQ.2.AND.KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 530
14275       IF(MSTP(45).LE.0.OR.IREF(IP,2).EQ.0.OR.NINH.GE.1) GOTO 500
14276       IF(K(IREF(1,1),2).EQ.25.AND.IP.EQ.1) GOTO 500
14277       IF(K(IREF(1,1),2).EQ.25.AND.KDCY(1)*KDCY(2).EQ.0) GOTO 500
14278
14279 C...Order incoming partons and outgoing resonances.
14280       ILIN(1)=MINT(84)+1
14281       IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
14282       IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
14283       ILIN(2)=2*MINT(84)+3-ILIN(1)
14284       IMIN=1
14285       IF(IREF(IP,5).EQ.25) IMIN=3
14286       IMAX=2
14287       IORD=1
14288       IF(K(IREF(IP,1),2).EQ.23) IORD=2
14289       IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
14290       IF(IABS(K(IREF(IP,IORD),2)).EQ.25) IORD=3-IORD
14291       IF(KDCY(IORD).EQ.0) IORD=3-IORD
14292
14293 C...Order decay products of resonances.
14294       DO 390 JT=IORD,3-IORD,3-2*IORD
14295       IF(KDCY(JT).EQ.0) THEN
14296         ILIN(IMAX+1)=NSD(JT)
14297         IMAX=IMAX+1
14298       ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
14299         ILIN(IMAX+1)=N+2*JT-1
14300         ILIN(IMAX+2)=N+2*JT
14301         IMAX=IMAX+2
14302         K(N+2*JT-1,2)=K(NSD(JT)+1,2)
14303         K(N+2*JT,2)=K(NSD(JT)+2,2)
14304       ELSE
14305         ILIN(IMAX+1)=N+2*JT
14306         ILIN(IMAX+2)=N+2*JT-1
14307         IMAX=IMAX+2
14308         K(N+2*JT-1,2)=K(NSD(JT)+1,2)
14309         K(N+2*JT,2)=K(NSD(JT)+2,2)
14310       ENDIF
14311   390 CONTINUE
14312
14313 C...Find charge, isospin, left- and righthanded couplings.
14314       XW=PARU(102)
14315       DO 410 I=IMIN,IMAX
14316       DO 400 J=1,4
14317   400 COUP(I,J)=0.
14318       KFA=IABS(K(ILIN(I),2))
14319       IF(KFA.GT.20) GOTO 410
14320       COUP(I,1)=LUCHGE(KFA)/3.
14321       COUP(I,2)=(-1)**MOD(KFA,2)
14322       COUP(I,4)=-2.*COUP(I,1)*XW
14323       COUP(I,3)=COUP(I,2)+COUP(I,4)
14324   410 CONTINUE
14325       SQMZ=PMAS(23,1)**2
14326       GZMZ=PMAS(23,1)*PMAS(23,2)
14327       SQMW=PMAS(24,1)**2
14328       GZMW=PMAS(24,1)*PMAS(24,2)
14329       SQMZP=PMAS(32,1)**2
14330       GZMZP=PMAS(32,1)*PMAS(32,2)
14331
14332 C...Select random angles; construct massless four-vectors.
14333   420 DO 430 I=N+1,N+4
14334       K(I,1)=1
14335       DO 430 J=1,5
14336   430 P(I,J)=0.
14337       DO 440 JT=1,JTMAX
14338       IF(KDCY(JT).EQ.0) GOTO 440
14339       ID=IREF(IP,JT)
14340       P(N+2*JT-1,3)=0.5*P(ID,5)
14341       P(N+2*JT-1,4)=0.5*P(ID,5)
14342       P(N+2*JT,3)=-0.5*P(ID,5)
14343       P(N+2*JT,4)=0.5*P(ID,5)
14344       CTHE(JT)=2.*RLU(0)-1.
14345       PHI(JT)=PARU(2)*RLU(0)
14346       CALL LUDBRB(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
14347      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
14348   440 CONTINUE
14349
14350 C...Store incoming and outgoing momenta, with random rotation to
14351 C...avoid accidental zeroes in HA expressions.
14352       DO 450 I=1,IMAX
14353       K(N+4+I,1)=1
14354       P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+
14355      &P(ILIN(I),5)**2)
14356       P(N+4+I,5)=P(ILIN(I),5)
14357       DO 450 J=1,3
14358   450 P(N+4+I,J)=P(ILIN(I),J)
14359       THERR=ACOS(2.*RLU(0)-1.)
14360       PHIRR=PARU(2)*RLU(0)
14361       CALL LUDBRB(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
14362       DO 460 I=1,IMAX
14363       DO 460 J=1,4
14364   460 PK(I,J)=P(N+4+I,J)
14365
14366 C...Calculate internal products.
14367       IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25) THEN
14368         DO 470 I1=IMIN,IMAX-1
14369         DO 470 I2=I1+1,IMAX
14370         HA(I1,I2)=SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+PK(I2,3))/
14371      &  (1E-20+PK(I1,1)**2+PK(I1,2)**2))*CMPLX(PK(I1,1),PK(I1,2))-
14372      &  SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
14373      &  (1E-20+PK(I2,1)**2+PK(I2,2)**2))*CMPLX(PK(I2,1),PK(I2,2))
14374         HC(I1,I2)=CONJG(HA(I1,I2))
14375         IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
14376         IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
14377         HA(I2,I1)=-HA(I1,I2)
14378   470   HC(I2,I1)=-HC(I1,I2)
14379       ENDIF
14380       DO 480 I=1,2
14381       DO 480 J=1,4
14382   480 PK(I,J)=-PK(I,J)
14383       DO 490 I1=IMIN,IMAX-1
14384       DO 490 I2=I1+1,IMAX
14385       PKK(I1,I2)=2.*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
14386      &PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
14387   490 PKK(I2,I1)=PKK(I1,I2)
14388
14389       IF(IREF(IP,5).EQ.25) THEN
14390 C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons
14391         WT=16.*PKK(3,5)*PKK(4,6)
14392         IF(IP.EQ.1) WTMAX=SH**2
14393         IF(IP.GE.2) WTMAX=P(IREF(IP,6),5)**4
14394
14395       ELSEIF(ISUB.EQ.1) THEN
14396         IF(KFA.NE.37) THEN
14397 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons
14398           EI=KCHG(IABS(MINT(15)),1)/3.
14399           AI=SIGN(1.,EI+0.1)
14400           VI=AI-4.*EI*XW
14401           EF=KCHG(KFA,1)/3.
14402           AF=SIGN(1.,EF+0.1)
14403           VF=AF-4.*EF*XW
14404           GG=1.
14405           GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
14406           ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
14407           IF(MSTP(43).EQ.1) THEN
14408 C...Only gamma* production included
14409             GZ=0.
14410             ZZ=0.
14411           ELSEIF(MSTP(43).EQ.2) THEN
14412 C...Only Z0 production included
14413             GG=0.
14414             GZ=0.
14415           ENDIF
14416           ASYM=2.*(EI*AI*GZ*EF*AF+4.*VI*AI*ZZ*VF*AF)/(EI**2*GG*EF**2+
14417      &    EI*VI*GZ*EF*VF+(VI**2+AI**2)*ZZ*(VF**2+AF**2))
14418           WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
14419           WTMAX=2.+ABS(ASYM)
14420         ELSE
14421 C...Angular weight for gamma*/Z0 -> H+ + H-
14422           WT=1.-CTHE(JT)**2
14423           WTMAX=1.
14424         ENDIF
14425
14426       ELSEIF(ISUB.EQ.2) THEN
14427 C...Angular weight for W+/- -> 2 quarks/leptons
14428         WT=(1.+CTHE(JT))**2
14429         WTMAX=4.
14430
14431       ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
14432 C...Angular weight for f + fb -> gluon/gamma + Z0 ->
14433 C...-> gluon/gamma + 2 quarks/leptons
14434         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
14435      &  (PKK(1,3)**2+PKK(2,4)**2)+((COUP(1,3)*COUP(3,4))**2+
14436      &  (COUP(1,4)*COUP(3,3))**2)*(PKK(1,4)**2+PKK(2,3)**2)
14437         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
14438      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
14439
14440       ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
14441 C...Angular weight for f + fb' -> gluon/gamma + W+/- ->
14442 C...-> gluon/gamma + 2 quarks/leptons
14443         WT=PKK(1,3)**2+PKK(2,4)**2
14444         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
14445
14446       ELSEIF(ISUB.EQ.22) THEN
14447 C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons
14448         S34=P(IREF(IP,IORD),5)**2
14449         S56=P(IREF(IP,3-IORD),5)**2
14450         TI=PKK(1,3)+PKK(1,4)+S34
14451         UI=PKK(1,5)+PKK(1,6)+S56
14452         WT=COUP(1,3)**4*((COUP(3,3)*COUP(5,3)*ABS(FGK(1,2,3,4,5,6)/
14453      &  TI+FGK(1,2,5,6,3,4)/UI))**2+(COUP(3,4)*COUP(5,3)*ABS(
14454      &  FGK(1,2,4,3,5,6)/TI+FGK(1,2,5,6,4,3)/UI))**2+(COUP(3,3)*
14455      &  COUP(5,4)*ABS(FGK(1,2,3,4,6,5)/TI+FGK(1,2,6,5,3,4)/UI))**2+
14456      &  (COUP(3,4)*COUP(5,4)*ABS(FGK(1,2,4,3,6,5)/TI+FGK(1,2,6,5,4,3)/
14457      &  UI))**2)+COUP(1,4)**4*((COUP(3,3)*COUP(5,3)*ABS(
14458      &  FGK(2,1,5,6,3,4)/TI+FGK(2,1,3,4,5,6)/UI))**2+(COUP(3,4)*
14459      &  COUP(5,3)*ABS(FGK(2,1,6,5,3,4)/TI+FGK(2,1,3,4,6,5)/UI))**2+
14460      &  (COUP(3,3)*COUP(5,4)*ABS(FGK(2,1,5,6,4,3)/TI+FGK(2,1,4,3,5,6)/
14461      &  UI))**2+(COUP(3,4)*COUP(5,4)*ABS(FGK(2,1,6,5,4,3)/TI+
14462      &  FGK(2,1,4,3,6,5)/UI))**2)
14463         WTMAX=4.*S34*S56*(COUP(1,3)**4+COUP(1,4)**4)*(COUP(3,3)**2+
14464      &  COUP(3,4)**2)*(COUP(5,3)**2+COUP(5,4)**2)*4.*(TI/UI+UI/TI+
14465      &  2.*SH*(S34+S56)/(TI*UI)-S34*S56*(1./TI**2+1./UI**2))
14466
14467       ELSEIF(ISUB.EQ.23) THEN
14468 C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons
14469         D34=P(IREF(IP,IORD),5)**2
14470         D56=P(IREF(IP,3-IORD),5)**2
14471         DT=PKK(1,3)+PKK(1,4)+D34
14472         DU=PKK(1,5)+PKK(1,6)+D56
14473         CAWZ=COUP(2,3)/SNGL(DT)-2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
14474         CBWZ=COUP(1,3)/SNGL(DU)+2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
14475         WT=COUP(5,3)**2*ABS(CAWZ*FGK(1,2,3,4,5,6)+CBWZ*
14476      &  FGK(1,2,5,6,3,4))**2+COUP(5,4)**2*ABS(CAWZ*
14477      &  FGK(1,2,3,4,6,5)+CBWZ*FGK(1,2,6,5,3,4))**2
14478         WTMAX=4.*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
14479      &  DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
14480
14481       ELSEIF(ISUB.EQ.24) THEN
14482 C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0
14483         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
14484      &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
14485      &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
14486         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
14487      &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
14488
14489       ELSEIF(ISUB.EQ.25) THEN
14490 C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons
14491         D34=P(IREF(IP,IORD),5)**2
14492         D56=P(IREF(IP,3-IORD),5)**2
14493         DT=PKK(1,3)+PKK(1,4)+D34
14494         DU=PKK(1,5)+PKK(1,6)+D56
14495         CDWW=(COUP(1,3)*SQMZ/(SH-SQMZ)+COUP(1,2))/SH
14496         CAWW=CDWW+0.5*(COUP(1,2)+1.)/SNGL(DT)
14497         CBWW=CDWW+0.5*(COUP(1,2)-1.)/SNGL(DU)
14498         CCWW=COUP(1,4)*SQMZ/(SH-SQMZ)/SH
14499         WT=ABS(CAWW*FGK(1,2,3,4,5,6)-CBWW*FGK(1,2,5,6,3,4))**2+
14500      &  CCWW**2*ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))**2
14501         WTMAX=4.*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
14502      &  CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
14503
14504       ELSEIF(ISUB.EQ.26) THEN
14505 C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0
14506         WT=PKK(1,3)*PKK(2,4)
14507         WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
14508
14509       ELSEIF(ISUB.EQ.30) THEN
14510 C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons
14511         IF(K(ILIN(1),2).GT.0) WT=((COUP(1,3)*COUP(3,3))**2+
14512      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,4)**2+PKK(3,5)**2)+
14513      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
14514      &  (PKK(1,3)**2+PKK(4,5)**2)
14515         IF(K(ILIN(1),2).LT.0) WT=((COUP(1,3)*COUP(3,3))**2+
14516      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,3)**2+PKK(4,5)**2)+
14517      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
14518      &  (PKK(1,4)**2+PKK(3,5)**2)
14519         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
14520      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
14521
14522       ELSEIF(ISUB.EQ.31) THEN
14523 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons
14524         IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
14525         IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
14526         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
14527
14528       ELSEIF(ISUB.EQ.141) THEN
14529 C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons
14530         EI=KCHG(IABS(MINT(15)),1)/3.
14531         AI=SIGN(1.,EI+0.1)
14532         VI=AI-4.*EI*XW
14533         API=SIGN(1.,EI+0.1)
14534         VPI=API-4.*EI*XW
14535         EF=KCHG(KFA,1)/3.
14536         AF=SIGN(1.,EF+0.1)
14537         VF=AF-4.*EF*XW
14538         APF=SIGN(1.,EF+0.1)
14539         VPF=APF-4.*EF*XW
14540         GG=1.
14541         GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
14542         GZP=1./(8.*XW*(1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GZMZP**2)
14543         ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
14544         ZZP=2./(16.*XW*(1.-XW))**2*
14545      &  SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/
14546      &  (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))
14547         ZPZP=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZP)**2+GZMZP**2)
14548         IF(MSTP(44).EQ.1) THEN
14549 C...Only gamma* production included
14550           GZ=0.
14551           GZP=0.
14552           ZZ=0.
14553           ZZP=0.
14554           ZPZP=0.
14555         ELSEIF(MSTP(44).EQ.2) THEN
14556 C...Only Z0 production included
14557           GG=0.
14558           GZ=0.
14559           GZP=0.
14560           ZZP=0.
14561           ZPZP=0.
14562         ELSEIF(MSTP(44).EQ.3) THEN
14563 C...Only Z'0 production included
14564           GG=0.
14565           GZ=0.
14566           GZP=0.
14567           ZZ=0.
14568           ZZP=0.
14569         ELSEIF(MSTP(44).EQ.4) THEN
14570 C...Only gamma*/Z0 production included
14571           GZP=0.
14572           ZZP=0.
14573           ZPZP=0.
14574         ELSEIF(MSTP(44).EQ.5) THEN
14575 C...Only gamma*/Z'0 production included
14576           GZ=0.
14577           ZZ=0.
14578           ZZP=0.
14579         ELSEIF(MSTP(44).EQ.6) THEN
14580 C...Only Z0/Z'0 production included
14581           GG=0.
14582           GZ=0.
14583           GZP=0.
14584         ENDIF
14585         ASYM=2.*(EI*AI*GZ*EF*AF+EI*API*GZP*EF*APF+4.*VI*AI*ZZ*VF*AF+
14586      &  (VI*API+VPI*AI)*ZZP*(VF*APF+VPF*AF)+4.*VPI*API*ZPZP*VPF*APF)/
14587      &  (EI**2*GG*EF**2+EI*VI*GZ*EF*VF+EI*VPI*GZP*EF*VPF+
14588      &  (VI**2+AI**2)*ZZ*(VF**2+AF**2)+(VI*VPI+AI*API)*ZZP*
14589      &  (VF*VPF+AF*APF)+(VPI**2+API**2)*ZPZP*(VPF**2+APF**2))
14590         WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
14591         WTMAX=2.+ABS(ASYM)
14592
14593       ELSE
14594         WT=1.
14595         WTMAX=1.
14596       ENDIF
14597 C...Obtain correct angular distribution by rejection techniques.
14598       IF(WT.LT.RLU(0)*WTMAX) GOTO 420
14599
14600 C...Construct massive four-vectors using angles chosen. Mark decayed
14601 C...resonances, add documentation lines. Shower evolution.
14602   500 DO 520 JT=1,JTMAX
14603       IF(KDCY(JT).EQ.0) GOTO 520
14604       ID=IREF(IP,JT)
14605       CALL LUDBRB(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
14606      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
14607       K(ID,1)=K(ID,1)+10
14608       K(ID,4)=NSD(JT)+1
14609       K(ID,5)=NSD(JT)+2
14610       IDOC=MINT(83)+MINT(4)
14611       DO 510 I=NSD(JT)+1,NSD(JT)+2
14612       MINT(4)=MINT(4)+1
14613       I1=MINT(83)+MINT(4)
14614       K(I,3)=I1
14615       K(I1,1)=21
14616       K(I1,2)=K(I,2)
14617       K(I1,3)=IREF(IP,JT+2)
14618       DO 510 J=1,5
14619   510 P(I1,J)=P(I,J)
14620       IF(JTMAX.EQ.1) THEN
14621         MINT(7)=MINT(83)+6+2*ISET(ISUB)
14622         MINT(8)=MINT(83)+7+2*ISET(ISUB)
14623       ENDIF
14624       IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,
14625      &NSD(JT)+2,P(ID,5))
14626
14627 C...Check if new resonances were produced, loop back if needed.
14628       IF(KDCY(JT).NE.3) GOTO 520
14629       NP=NP+1
14630       IREF(NP,1)=NSD(JT)+1
14631       IREF(NP,2)=NSD(JT)+2
14632       IREF(NP,3)=IDOC+1
14633       IREF(NP,4)=IDOC+2
14634       IREF(NP,5)=K(IREF(IP,JT),2)
14635       IREF(NP,6)=IREF(IP,JT)
14636   520 CONTINUE
14637   530 IF(IP.LT.NP) GOTO 100
14638
14639       RETURN
14640       END
14641
14642 C*********************************************************************
14643
14644       SUBROUTINE PYDIFF
14645
14646 C...Handles diffractive and elastic scattering.
14647       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
14648       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14649       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14650       COMMON/PYINT1/MINT(400),VINT(400)
14651       SAVE
14652
14653 C...Reset K, P and V vectors. Store incoming particles.
14654       DO 100 JT=1,MSTP(126)+10
14655       I=MINT(83)+JT
14656       DO 100 J=1,5
14657       K(I,J)=0
14658       P(I,J)=0.
14659   100 V(I,J)=0.
14660       N=MINT(84)
14661       MINT(3)=0
14662       MINT(21)=0
14663       MINT(22)=0
14664       MINT(23)=0
14665       MINT(24)=0
14666       MINT(4)=4
14667       DO 110 JT=1,2
14668       I=MINT(83)+JT
14669       K(I,1)=21
14670       K(I,2)=MINT(10+JT)
14671       P(I,5)=VINT(2+JT)
14672       P(I,3)=VINT(5)*(-1)**(JT+1)
14673   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
14674       MINT(6)=2
14675
14676 C...Subprocess; kinematics.
14677       ISUB=MINT(1)
14678       SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4.*VINT(63)*VINT(64)
14679       PZ=SQRT(SQLAM)/(2.*VINT(1))
14680       DO 150 JT=1,2
14681       I=MINT(83)+JT
14682       PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2.*VINT(1))
14683
14684 C...Elastically scattered particle.
14685       IF(MINT(16+JT).LE.0) THEN
14686         N=N+1
14687         K(N,1)=1
14688         K(N,2)=K(I,2)
14689         K(N,3)=I+2
14690         P(N,3)=PZ*(-1)**(JT+1)
14691         P(N,4)=PE
14692         P(N,5)=P(I,5)
14693
14694 C...Diffracted particle: valence quark kicked out.
14695       ELSEIF(MSTP(101).EQ.1) THEN
14696         N=N+2
14697         K(N-1,1)=2
14698         K(N,1)=1
14699         K(N-1,3)=I+2
14700         K(N,3)=I+2
14701         CALL PYSPLI(K(I,2),21,K(N,2),K(N-1,2))
14702         P(N-1,5)=ULMASS(K(N-1,2))
14703         P(N,5)=ULMASS(K(N,2))
14704         SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
14705      &  4.*P(N-1,5)**2*P(N,5)**2
14706         P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
14707      &  P(N,5)**2))/(2.*VINT(62+JT))*(-1)**(JT+1)
14708         P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
14709         P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
14710         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
14711
14712 C...Diffracted particle: gluon kicked out.
14713       ELSE
14714         N=N+3
14715         K(N-2,1)=2
14716         K(N-1,1)=2
14717         K(N,1)=1
14718         K(N-2,3)=I+2
14719         K(N-1,3)=I+2
14720         K(N,3)=I+2
14721         CALL PYSPLI(K(I,2),21,K(N,2),K(N-2,2))
14722         K(N-1,2)=21
14723         P(N-2,5)=ULMASS(K(N-2,2))
14724         P(N-1,5)=0.
14725         P(N,5)=ULMASS(K(N,2))
14726 C...Energy distribution for particle into two jets.
14727   120   IMB=1
14728         IF(MOD(K(I,2)/1000,10).NE.0) IMB=2
14729         CHIK=PARP(92+2*IMB)
14730         IF(MSTP(92).LE.1) THEN
14731           IF(IMB.EQ.1) CHI=RLU(0)
14732           IF(IMB.EQ.2) CHI=1.-SQRT(RLU(0))
14733         ELSEIF(MSTP(92).EQ.2) THEN
14734           CHI=1.-RLU(0)**(1./(1.+CHIK))
14735         ELSEIF(MSTP(92).EQ.3) THEN
14736           CUT=2.*0.3/VINT(1)
14737   130     CHI=RLU(0)**2
14738           IF((CHI**2/(CHI**2+CUT**2))**0.25*(1.-CHI)**CHIK.LT.
14739      &    RLU(0)) GOTO 130
14740         ELSE
14741           CUT=2.*0.3/VINT(1)
14742           CUTR=(1.+SQRT(1.+CUT**2))/CUT
14743   140     CHIR=CUT*CUTR**RLU(0)
14744           CHI=(CHIR**2-CUT**2)/(2.*CHIR)
14745           IF((1.-CHI)**CHIK.LT.RLU(0)) GOTO 140
14746         ENDIF
14747         IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1.-P(N-2,5)**2/
14748      &  VINT(62+JT)) GOTO 120
14749         SQM=P(N-2,5)**2/(1.-CHI)+P(N,5)**2/CHI
14750         IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 120
14751         PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
14752      &  (2.*VINT(62+JT))
14753         PEI=SQRT(PZI**2+SQM)
14754         PQQP=(1.-CHI)*(PEI+PZI)
14755         P(N-2,3)=0.5*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
14756         P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
14757         P(N-1,3)=(PZ-PZI)*(-1)**(JT+1)
14758         P(N-1,4)=ABS(P(N-1,3))
14759         P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
14760         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
14761       ENDIF
14762
14763 C...Documentation lines.
14764       K(I+2,1)=21
14765       IF(MINT(16+JT).EQ.0) K(I+2,2)=MINT(10+JT)
14766       IF(MINT(16+JT).NE.0) K(I+2,2)=10*(MINT(10+JT)/10)
14767       K(I+2,3)=I
14768       P(I+2,3)=PZ*(-1)**(JT+1)
14769       P(I+2,4)=PE
14770       P(I+2,5)=SQRT(VINT(62+JT))
14771   150 CONTINUE
14772
14773 C...Rotate outgoing partons/particles using cos(theta).
14774       CALL LUDBRB(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
14775
14776       RETURN
14777       END
14778
14779 C*********************************************************************
14780
14781       SUBROUTINE PYFRAM(IFRAME)
14782
14783 C...Performs transformations between different coordinate frames.
14784       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14785       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14786       COMMON/PYINT1/MINT(400),VINT(400)
14787       SAVE
14788
14789       IF(IFRAME.LT.1.OR.IFRAME.GT.2) THEN
14790         WRITE(MSTU(11),1000) IFRAME,MINT(6)
14791         RETURN
14792       ENDIF
14793       IF(IFRAME.EQ.MINT(6)) RETURN
14794
14795       IF(MINT(6).EQ.1) THEN
14796 C...Transform from fixed target or user specified frame to
14797 C...CM-frame of incoming particles.
14798         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
14799         CALL LUROBO(0.,-VINT(7),0.,0.,0.)
14800         CALL LUROBO(-VINT(6),0.,0.,0.,0.)
14801         MINT(6)=2
14802
14803       ELSE
14804 C...Transform from particle CM-frame to fixed target or user specified
14805 C...frame.
14806         CALL LUROBO(VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
14807         MINT(6)=1
14808       ENDIF
14809       MSTI(6)=MINT(6)
14810
14811  1000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
14812      &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
14813      &1X,I5)
14814
14815       RETURN
14816       END
14817
14818 C*********************************************************************
14819
14820       SUBROUTINE PYWIDT(KFLR,RMAS,WDTP,WDTE)
14821
14822 C...Calculates full and partial widths of resonances.
14823       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14824       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
14825       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
14826       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14827       COMMON/PYINT1/MINT(400),VINT(400)
14828       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
14829       DIMENSION WDTP(0:40),WDTE(0:40,0:5)
14830       SAVE
14831
14832 C...Some common constants.
14833       KFLA=IABS(KFLR)
14834       SQM=RMAS**2
14835       AS=ULALPS(SQM)
14836       AEM=PARU(101)
14837       XW=PARU(102)
14838       RADC=1.+AS/PARU(1)
14839
14840 C...Reset width information.
14841       DO 100 I=0,40
14842       WDTP(I)=0.
14843       DO 100 J=0,5
14844   100 WDTE(I,J)=0.
14845
14846       IF(KFLA.EQ.21) THEN
14847 C...QCD:
14848         DO 110 I=1,MDCY(21,3)
14849         IDC=I+MDCY(21,2)-1
14850         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
14851         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
14852         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 110
14853         IF(I.LE.8) THEN
14854 C...QCD -> q + qb
14855           WDTP(I)=(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
14856           WID2=1.
14857         ENDIF
14858         WDTP(0)=WDTP(0)+WDTP(I)
14859         IF(MDME(IDC,1).GT.0) THEN
14860           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14861           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14862           WDTE(I,0)=WDTE(I,MDME(IDC,1))
14863           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14864         ENDIF
14865   110   CONTINUE
14866
14867       ELSEIF(KFLA.EQ.23) THEN
14868 C...Z0:
14869         IF(MINT(61).EQ.1) THEN
14870           EI=KCHG(IABS(MINT(15)),1)/3.
14871           AI=SIGN(1.,EI)
14872           VI=AI-4.*EI*XW
14873           SQMZ=PMAS(23,1)**2
14874           GZMZ=PMAS(23,2)*PMAS(23,1)
14875           GGI=EI**2
14876           GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
14877      &    ((SQM-SQMZ)**2+GZMZ**2)
14878           ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
14879      &    ((SQM-SQMZ)**2+GZMZ**2)
14880           IF(MSTP(43).EQ.1) THEN
14881 C...Only gamma* production included
14882             GZI=0.
14883             ZZI=0.
14884           ELSEIF(MSTP(43).EQ.2) THEN
14885 C...Only Z0 production included
14886             GGI=0.
14887             GZI=0.
14888           ENDIF
14889         ELSEIF(MINT(61).EQ.2) THEN
14890           VINT(111)=0.
14891           VINT(112)=0.
14892           VINT(114)=0.
14893         ENDIF
14894         DO 120 I=1,MDCY(23,3)
14895         IDC=I+MDCY(23,2)-1
14896         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
14897         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
14898         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 120
14899         IF(I.LE.8) THEN
14900 C...Z0 -> q + qb
14901           EF=KCHG(I,1)/3.
14902           AF=SIGN(1.,EF+0.1)
14903           VF=AF-4.*EF*XW
14904           IF(MINT(61).EQ.0) THEN
14905             WDTP(I)=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
14906      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
14907           ELSEIF(MINT(61).EQ.1) THEN
14908             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
14909      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
14910      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
14911           ELSEIF(MINT(61).EQ.2) THEN
14912             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
14913             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
14914             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
14915      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
14916           ENDIF
14917           WID2=1.
14918         ELSEIF(I.LE.16) THEN
14919 C...Z0 -> l+ + l-, nu + nub
14920           EF=KCHG(I+2,1)/3.
14921           AF=SIGN(1.,EF+0.1)
14922           VF=AF-4.*EF*XW
14923           WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
14924      &    SQRT(MAX(0.,1.-4.*RM1))
14925           IF(MINT(61).EQ.0) THEN
14926             WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
14927      &      SQRT(MAX(0.,1.-4.*RM1))
14928           ELSEIF(MINT(61).EQ.1) THEN
14929             WDTP(I)=((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
14930      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
14931      &      SQRT(MAX(0.,1.-4.*RM1))
14932           ELSEIF(MINT(61).EQ.2) THEN
14933             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
14934             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
14935             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
14936      &      SQRT(MAX(0.,1.-4.*RM1))
14937           ENDIF
14938           WID2=1.
14939         ELSE
14940 C...Z0 -> H+ + H-
14941           CF=2.*(1.-2.*XW)
14942           IF(MINT(61).EQ.0) THEN
14943             WDTP(I)=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
14944           ELSEIF(MINT(61).EQ.1) THEN
14945             WDTP(I)=0.25*(GGI+GZI*CF+ZZI*CF**2)*(1.-4.*RM1)*
14946      &      SQRT(MAX(0.,1.-4.*RM1))
14947           ELSEIF(MINT(61).EQ.2) THEN
14948             GGF=0.25*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
14949             GZF=0.25*CF*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
14950             ZZF=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
14951           ENDIF
14952           WID2=WIDS(37,1)
14953         ENDIF
14954         WDTP(0)=WDTP(0)+WDTP(I)
14955         IF(MDME(IDC,1).GT.0) THEN
14956           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14957           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14958           WDTE(I,0)=WDTE(I,MDME(IDC,1))
14959           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14960           VINT(111)=VINT(111)+GGF*WID2
14961           VINT(112)=VINT(112)+GZF*WID2
14962           VINT(114)=VINT(114)+ZZF*WID2
14963         ENDIF
14964   120   CONTINUE
14965         IF(MSTP(43).EQ.1) THEN
14966 C...Only gamma* production included
14967           VINT(112)=0.
14968           VINT(114)=0.
14969         ELSEIF(MSTP(43).EQ.2) THEN
14970 C...Only Z0 production included
14971           VINT(111)=0.
14972           VINT(112)=0.
14973         ENDIF
14974
14975       ELSEIF(KFLA.EQ.24) THEN
14976 C...W+/-:
14977         DO 130 I=1,MDCY(24,3)
14978         IDC=I+MDCY(24,2)-1
14979         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
14980         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
14981         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 130
14982         IF(I.LE.16) THEN
14983 C...W+/- -> q + qb'
14984           WDTP(I)=3.*(2.-RM1-RM2-(RM1-RM2)**2)*
14985      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*
14986      &    VCKM((I-1)/4+1,MOD(I-1,4)+1)*RADC
14987           WID2=1.
14988         ELSE
14989 C...W+/- -> l+/- + nu
14990           WDTP(I)=(2.-RM1-RM2-(RM1-RM2)**2)*
14991      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
14992           WID2=1.
14993         ENDIF
14994         WDTP(0)=WDTP(0)+WDTP(I)
14995         IF(MDME(IDC,1).GT.0) THEN
14996           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14997           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14998           WDTE(I,0)=WDTE(I,MDME(IDC,1))
14999           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15000         ENDIF
15001   130   CONTINUE
15002
15003       ELSEIF(KFLA.EQ.25) THEN
15004 C...H0:
15005         DO 170 I=1,MDCY(25,3)
15006         IDC=I+MDCY(25,2)-1
15007         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15008         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15009         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 170
15010         IF(I.LE.8) THEN
15011 C...H0 -> q + qb
15012           WDTP(I)=3.*RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15013           WID2=1.
15014         ELSEIF(I.LE.12) THEN
15015 C...H0 -> l+ + l-
15016           WDTP(I)=RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15017           WID2=1.
15018         ELSEIF(I.EQ.13) THEN
15019 C...H0 -> g + g; quark loop contribution only
15020           ETARE=0.
15021           ETAIM=0.
15022           DO 140 J=1,2*MSTP(1)
15023           EPS=(2.*PMAS(J,1)/RMAS)**2
15024           IF(EPS.LE.1.) THEN
15025             IF(EPS.GT.1.E-4) THEN
15026               ROOT=SQRT(1.-EPS)
15027               RLN=LOG((1.+ROOT)/(1.-ROOT))
15028             ELSE
15029               RLN=LOG(4./EPS-2.)
15030             ENDIF
15031             PHIRE=0.25*(RLN**2-PARU(1)**2)
15032             PHIIM=0.5*PARU(1)*RLN
15033           ELSE
15034             PHIRE=-(ASIN(1./SQRT(EPS)))**2
15035             PHIIM=0.
15036           ENDIF
15037           ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
15038           ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
15039   140     CONTINUE
15040           ETA2=ETARE**2+ETAIM**2
15041           WDTP(I)=(AS/PARU(1))**2*ETA2
15042           WID2=1.
15043         ELSEIF(I.EQ.14) THEN
15044 C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions
15045           ETARE=0.
15046           ETAIM=0.
15047           DO 150 J=1,3*MSTP(1)+1
15048           IF(J.LE.2*MSTP(1)) THEN
15049             EJ=KCHG(J,1)/3.
15050             EPS=(2.*PMAS(J,1)/RMAS)**2
15051           ELSEIF(J.LE.3*MSTP(1)) THEN
15052             JL=2*(J-2*MSTP(1))-1
15053             EJ=KCHG(10+JL,1)/3.
15054             EPS=(2.*PMAS(10+JL,1)/RMAS)**2
15055           ELSE
15056             EPS=(2.*PMAS(24,1)/RMAS)**2
15057           ENDIF
15058           IF(EPS.LE.1.) THEN
15059             IF(EPS.GT.1.E-4) THEN
15060               ROOT=SQRT(1.-EPS)
15061               RLN=LOG((1.+ROOT)/(1.-ROOT))
15062             ELSE
15063               RLN=LOG(4./EPS-2.)
15064             ENDIF
15065             PHIRE=0.25*(RLN**2-PARU(1)**2)
15066             PHIIM=0.5*PARU(1)*RLN
15067           ELSE
15068             PHIRE=-(ASIN(1./SQRT(EPS)))**2
15069             PHIIM=0.
15070           ENDIF
15071           IF(J.LE.2*MSTP(1)) THEN
15072             ETARE=ETARE+0.5*3.*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
15073             ETAIM=ETAIM+0.5*3.*EJ**2*EPS*(EPS-1.)*PHIIM
15074           ELSEIF(J.LE.3*MSTP(1)) THEN
15075             ETARE=ETARE+0.5*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
15076             ETAIM=ETAIM+0.5*EJ**2*EPS*(EPS-1.)*PHIIM
15077           ELSE
15078             ETARE=ETARE-0.5-0.75*EPS*(1.+(EPS-2.)*PHIRE)
15079             ETAIM=ETAIM+0.75*EPS*(EPS-2.)*PHIIM
15080           ENDIF
15081   150     CONTINUE
15082           ETA2=ETARE**2+ETAIM**2
15083           WDTP(I)=(AEM/PARU(1))**2*0.5*ETA2
15084           WID2=1.
15085         ELSEIF(I.EQ.15) THEN
15086 C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions
15087           ETARE=0.
15088           ETAIM=0.
15089           DO 160 J=1,3*MSTP(1)+1
15090           IF(J.LE.2*MSTP(1)) THEN
15091             EJ=KCHG(J,1)/3.
15092             AJ=SIGN(1.,EJ+0.1)
15093             VJ=AJ-4.*EJ*XW
15094             EPS=(2.*PMAS(J,1)/RMAS)**2
15095             EPSP=(2.*PMAS(J,1)/PMAS(23,1))**2
15096           ELSEIF(J.LE.3*MSTP(1)) THEN
15097             JL=2*(J-2*MSTP(1))-1
15098             EJ=KCHG(10+JL,1)/3.
15099             AJ=SIGN(1.,EJ+0.1)
15100             VJ=AI-4.*EJ*XW
15101             EPS=(2.*PMAS(10+JL,1)/RMAS)**2
15102             EPSP=(2.*PMAS(10+JL,1)/PMAS(23,1))**2
15103           ELSE
15104             EPS=(2.*PMAS(24,1)/RMAS)**2
15105             EPSP=(2.*PMAS(24,1)/PMAS(23,1))**2
15106           ENDIF
15107           IF(EPS.LE.1.) THEN
15108             ROOT=SQRT(1.-EPS)
15109             IF(EPS.GT.1.E-4) THEN
15110               RLN=LOG((1.+ROOT)/(1.-ROOT))
15111             ELSE
15112               RLN=LOG(4./EPS-2.)
15113             ENDIF
15114             PHIRE=0.25*(RLN**2-PARU(1)**2)
15115             PHIIM=0.5*PARU(1)*RLN
15116             PSIRE=-(1.+0.5*ROOT*RLN)
15117             PSIIM=0.5*PARU(1)*ROOT
15118           ELSE
15119             PHIRE=-(ASIN(1./SQRT(EPS)))**2
15120             PHIIM=0.
15121             PSIRE=-(1.+SQRT(EPS-1.)*ASIN(1./SQRT(EPS)))
15122             PSIIM=0.
15123           ENDIF
15124           IF(EPSP.LE.1.) THEN
15125             ROOT=SQRT(1.-EPSP)
15126             IF(EPSP.GT.1.E-4) THEN
15127               RLN=LOG((1.+ROOT)/(1.-ROOT))
15128             ELSE
15129               RLN=LOG(4./EPSP-2.)
15130             ENDIF
15131             PHIREP=0.25*(RLN**2-PARU(1)**2)
15132             PHIIMP=0.5*PARU(1)*RLN
15133             PSIREP=-(1.+0.5*ROOT*RLN)
15134             PSIIMP=0.5*PARU(1)*ROOT
15135           ELSE
15136             PHIREP=-(ASIN(1./SQRT(EPSP)))**2
15137             PHIIMP=0.
15138             PSIREP=-(1.+SQRT(EPSP-1.)*ASIN(1./SQRT(EPSP)))
15139             PSIIMP=0.
15140           ENDIF
15141           FXYRE=EPS*EPSP/(8.*(EPS-EPSP))*(1.-EPS*EPSP/(EPS-EPSP)*(PHIRE-
15142      &    PHIREP)+2.*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
15143           FXYIM=EPS*EPSP/(8.*(EPS-EPSP))*(-EPS*EPSP/(EPS-EPSP)*(PHIIM-
15144      &    PHIIMP)+2.*EPS/(EPS-EPSP)*(PSIIM-PSIIMP))
15145           F1RE=EPS*EPSP/(2.*(EPS-EPSP))*(PHIRE-PHIREP)
15146           F1IM=EPS*EPSP/(2.*(EPS-EPSP))*(PHIIM-PHIIMP)
15147           IF(J.LE.2*MSTP(1)) THEN
15148             ETARE=ETARE-3.*EJ*VJ*(FXYRE-0.25*F1RE)
15149             ETAIM=ETAIM-3.*EJ*VJ*(FXYIM-0.25*F1IM)
15150           ELSEIF(J.LE.3*MSTP(1)) THEN
15151             ETARE=ETARE-EJ*VJ*(FXYRE-0.25*F1RE)
15152             ETAIM=ETAIM-EJ*VJ*(FXYIM-0.25*F1IM)
15153           ELSE
15154             ETARE=ETARE-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
15155      &      (5.+2./EPS))*FXYRE+(3.-XW/SQRT(1.-XW))*F1RE)
15156             ETAIM=ETAIM-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
15157      &      (5.+2./EPS))*FXYIM+(3.-XW/SQRT(1.-XW))*F1IM)
15158           ENDIF
15159   160     CONTINUE
15160           ETA2=ETARE**2+ETAIM**2
15161           WDTP(I)=(AEM/PARU(1))**2*(1.-(PMAS(23,1)/RMAS)**2)**3/XW*ETA2
15162           WID2=WIDS(23,2)
15163         ELSE
15164 C...H0 -> Z0 + Z0, W+ + W-
15165           WDTP(I)=(1.-4.*RM1+12.*RM1**2)*SQRT(MAX(0.,1.-4.*RM1))/
15166      &    (2.*(18-I))
15167           WID2=WIDS(7+I,1)
15168         ENDIF
15169         WDTP(0)=WDTP(0)+WDTP(I)
15170         IF(MDME(IDC,1).GT.0) THEN
15171           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15172           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15173           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15174           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15175         ENDIF
15176   170   CONTINUE
15177
15178       ELSEIF(KFLA.EQ.32) THEN
15179 C...Z'0:
15180         IF(MINT(61).EQ.1) THEN
15181           EI=KCHG(IABS(MINT(15)),1)/3.
15182           AI=SIGN(1.,EI)
15183           VI=AI-4.*EI*XW
15184           SQMZ=PMAS(23,1)**2
15185           GZMZ=PMAS(23,2)*PMAS(23,1)
15186           API=SIGN(1.,EI)
15187           VPI=API-4.*EI*XW
15188           SQMZP=PMAS(32,1)**2
15189           GZPMZP=PMAS(32,2)*PMAS(32,1)
15190           GGI=EI**2
15191           GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
15192      &    ((SQM-SQMZ)**2+GZMZ**2)
15193           GZPI=EI*VPI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZP)/
15194      &    ((SQM-SQMZP)**2+GZPMZP**2)
15195           ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
15196      &    ((SQM-SQMZ)**2+GZMZ**2)
15197           ZZPI=2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*
15198      &    SQM**2*((SQM-SQMZ)*(SQM-SQMZP)+GZMZ*GZPMZP)/
15199      &    (((SQM-SQMZ)**2+GZMZ**2)*((SQM-SQMZP)**2+GZPMZP**2))
15200           ZPZPI=(VPI**2+API**2)/(16.*XW*(1.-XW))**2*SQM**2/
15201      &    ((SQM-SQMZP)**2+GZPMZP**2)
15202           IF(MSTP(44).EQ.1) THEN
15203 C...Only gamma* production included
15204             GZI=0.
15205             GZPI=0.
15206             ZZI=0.
15207             ZZPI=0.
15208             ZPZPI=0.
15209           ELSEIF(MSTP(44).EQ.2) THEN
15210 C...Only Z0 production included
15211             GGI=0.
15212             GZI=0.
15213             GZPI=0.
15214             ZZPI=0.
15215             ZPZPI=0.
15216           ELSEIF(MSTP(44).EQ.3) THEN
15217 C...Only Z'0 production included
15218             GGI=0.
15219             GZI=0.
15220             GZPI=0.
15221             ZZI=0.
15222             ZZPI=0.
15223           ELSEIF(MSTP(44).EQ.4) THEN
15224 C...Only gamma*/Z0 production included
15225             GZPI=0.
15226             ZZPI=0.
15227             ZPZPI=0.
15228           ELSEIF(MSTP(44).EQ.5) THEN
15229 C...Only gamma*/Z'0 production included
15230             GZI=0.
15231             ZZI=0.
15232             ZZPI=0.
15233           ELSEIF(MSTP(44).EQ.6) THEN
15234 C...Only Z0/Z'0 production included
15235             GGI=0.
15236             GZI=0.
15237             GZPI=0.
15238           ENDIF
15239         ELSEIF(MINT(61).EQ.2) THEN
15240           VINT(111)=0.
15241           VINT(112)=0.
15242           VINT(113)=0.
15243           VINT(114)=0.
15244           VINT(115)=0.
15245           VINT(116)=0.
15246         ENDIF
15247         DO 180 I=1,MDCY(32,3)
15248         IDC=I+MDCY(32,2)-1
15249         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15250         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15251         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 180
15252         IF(I.LE.8) THEN
15253 C...Z'0 -> q + qb
15254           EF=KCHG(I,1)/3.
15255           AF=SIGN(1.,EF+0.1)
15256           VF=AF-4.*EF*XW
15257           APF=SIGN(1.,EF+0.1)
15258           VPF=APF-4.*EF*XW
15259           IF(MINT(61).EQ.0) THEN
15260             WDTP(I)=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15261      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15262           ELSEIF(MINT(61).EQ.1) THEN
15263             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
15264      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
15265      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
15266      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15267           ELSEIF(MINT(61).EQ.2) THEN
15268             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15269             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15270             GZPF=3.*EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
15271             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15272      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15273             ZZPF=3.*(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
15274      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15275             ZPZPF=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15276      &      SQRT(MAX(0.,1.-4.*RM1))*RADC
15277           ENDIF
15278           WID2=1.
15279         ELSE
15280 C...Z'0 -> l+ + l-, nu + nub
15281           EF=KCHG(I+2,1)/3.
15282           AF=SIGN(1.,EF+0.1)
15283           VF=AF-4.*EF*XW
15284           APF=SIGN(1.,EF+0.1)
15285           VPF=APF-4.*EF*XW
15286           IF(MINT(61).EQ.0) THEN
15287             WDTP(I)=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15288      &      SQRT(MAX(0.,1.-4.*RM1))
15289           ELSEIF(MINT(61).EQ.1) THEN
15290             WDTP(I)=((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
15291      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
15292      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
15293      &      SQRT(MAX(0.,1.-4.*RM1))
15294           ELSEIF(MINT(61).EQ.2) THEN
15295             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15296             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15297             GZPF=EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
15298             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
15299      &      SQRT(MAX(0.,1.-4.*RM1))
15300             ZZPF=(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
15301      &      SQRT(MAX(0.,1.-4.*RM1))
15302             ZPZPF=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
15303      &      SQRT(MAX(0.,1.-4.*RM1))
15304           ENDIF
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           VINT(111)=VINT(111)+GGF
15314           VINT(112)=VINT(112)+GZF
15315           VINT(113)=VINT(113)+GZPF
15316           VINT(114)=VINT(114)+ZZF
15317           VINT(115)=VINT(115)+ZZPF
15318           VINT(116)=VINT(116)+ZPZPF
15319         ENDIF
15320   180   CONTINUE
15321         IF(MSTP(44).EQ.1) THEN
15322 C...Only gamma* production included
15323           VINT(112)=0.
15324           VINT(113)=0.
15325           VINT(114)=0.
15326           VINT(115)=0.
15327           VINT(116)=0.
15328         ELSEIF(MSTP(44).EQ.2) THEN
15329 C...Only Z0 production included
15330           VINT(111)=0.
15331           VINT(112)=0.
15332           VINT(113)=0.
15333           VINT(115)=0.
15334           VINT(116)=0.
15335         ELSEIF(MSTP(44).EQ.3) THEN
15336 C...Only Z'0 production included
15337           VINT(111)=0.
15338           VINT(112)=0.
15339           VINT(113)=0.
15340           VINT(114)=0.
15341           VINT(115)=0.
15342         ELSEIF(MSTP(44).EQ.4) THEN
15343 C...Only gamma*/Z0 production included
15344           VINT(113)=0.
15345           VINT(115)=0.
15346           VINT(116)=0.
15347         ELSEIF(MSTP(44).EQ.5) THEN
15348 C...Only gamma*/Z'0 production included
15349           VINT(112)=0.
15350           VINT(114)=0.
15351           VINT(115)=0.
15352         ELSEIF(MSTP(44).EQ.6) THEN
15353 C...Only Z0/Z'0 production included
15354           VINT(111)=0.
15355           VINT(112)=0.
15356           VINT(113)=0.
15357         ENDIF
15358
15359       ELSEIF(KFLA.EQ.37) THEN
15360 C...H+/-:
15361         DO 190 I=1,MDCY(37,3)
15362         IDC=I+MDCY(37,2)-1
15363         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15364         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15365         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 190
15366         IF(I.LE.4) THEN
15367 C...H+/- -> q + qb'
15368           WDTP(I)=3.*((RM1*PARU(121)+RM2/PARU(121))*
15369      &    (1.-RM1-RM2)-4.*RM1*RM2)*
15370      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*RADC
15371           WID2=1.
15372         ELSE
15373 C...H+/- -> l+/- + nu
15374           WDTP(I)=((RM1*PARU(121)+RM2/PARU(121))*
15375      &    (1.-RM1-RM2)-4.*RM1*RM2)*
15376      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
15377           WID2=1.
15378         ENDIF
15379         WDTP(0)=WDTP(0)+WDTP(I)
15380         IF(MDME(IDC,1).GT.0) THEN
15381           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15382           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15383           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15384           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15385         ENDIF
15386   190   CONTINUE
15387
15388       ELSEIF(KFLA.EQ.40) THEN
15389 C...R:
15390         DO 200 I=1,MDCY(40,3)
15391         IDC=I+MDCY(40,2)-1
15392         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
15393         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
15394         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 200
15395         IF(I.LE.4) THEN
15396 C...R -> q + qb'
15397           WDTP(I)=3.*RADC
15398           WID2=1.
15399         ELSE
15400 C...R -> l+ + l'-
15401           WDTP(I)=1.
15402           WID2=1.
15403         ENDIF
15404         WDTP(0)=WDTP(0)+WDTP(I)
15405         IF(MDME(IDC,1).GT.0) THEN
15406           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15407           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15408           WDTE(I,0)=WDTE(I,MDME(IDC,1))
15409           WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15410         ENDIF
15411   200   CONTINUE
15412
15413       ENDIF
15414       MINT(61)=0
15415
15416       RETURN
15417       END
15418
15419 C***********************************************************************
15420
15421       SUBROUTINE PYKLIM(ILIM)
15422
15423 C...Checks generated variables against pre-set kinematical limits;
15424 C...also calculates limits on variables used in generation.
15425       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15426       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
15427       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
15428       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15429       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
15430       COMMON/PYINT1/MINT(400),VINT(400)
15431       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
15432       SAVE
15433
15434 C...Common kinematical expressions.
15435       ISUB=MINT(1)
15436       IF(ISUB.EQ.96) GOTO 110
15437       SQM3=VINT(63)
15438       SQM4=VINT(64)
15439       IF(ILIM.NE.1) THEN
15440         TAU=VINT(21)
15441         RM3=SQM3/(TAU*VINT(2))
15442         RM4=SQM4/(TAU*VINT(2))
15443         BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
15444       ENDIF
15445       PTHMIN=CKIN(3)
15446       IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) PTHMIN=MAX(CKIN(3),CKIN(5))
15447
15448       IF(ILIM.EQ.0) THEN
15449 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15450 C...pre-set kinematical limits.
15451         YST=VINT(22)
15452         CTH=VINT(23)
15453         TAUP=VINT(26)
15454         IF(ISET(ISUB).LE.2) THEN
15455           X1=SQRT(TAU)*EXP(YST)
15456           X2=SQRT(TAU)*EXP(-YST)
15457         ELSE
15458           X1=SQRT(TAUP)*EXP(YST)
15459           X2=SQRT(TAUP)*EXP(-YST)
15460         ENDIF
15461         XF=X1-X2
15462         IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
15463         IF(CKIN(2).GE.0..AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
15464         IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
15465         IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
15466         IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
15467         IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
15468         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
15469           PTH=0.5*BE34*SQRT(TAU*VINT(2)*(1.-CTH**2))
15470           Y3=YST+0.5*LOG((1.+RM3-RM4+BE34*CTH)/(1.+RM3-RM4-BE34*CTH))
15471           Y4=YST+0.5*LOG((1.+RM4-RM3-BE34*CTH)/(1.+RM4-RM3+BE34*CTH))
15472           YLARGE=MAX(Y3,Y4)
15473           YSMALL=MIN(Y3,Y4)
15474           ETALAR=10.
15475           ETASMA=-10.
15476           STH=SQRT(1.-CTH**2)
15477           IF(STH.LT.1.E-6) GOTO 100
15478           EXPET3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+
15479      &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3))/
15480      &    (BE34*STH)
15481           EXPET4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+
15482      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4))/
15483      &    (BE34*STH)
15484           ETA3=LOG(MIN(1.E10,MAX(1.E-10,EXPET3)))
15485           ETA4=LOG(MIN(1.E10,MAX(1.E-10,EXPET4)))
15486           ETALAR=MAX(ETA3,ETA4)
15487           ETASMA=MIN(ETA3,ETA4)
15488 C...temporary variables to avoid compiler warning
15489           CTSTM1=(1.+RM3-RM4)*COSH(YST)
15490           CTSTM2=BE34*SINH(YST)*CTH
15491   100     CTS3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/
15492 C     &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3)
15493      &    SQRT((CTSTM1+CTSTM2)**2-4.*RM3)
15494           CTS4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/
15495      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4)
15496           CTSLAR=MAX(CTS3,CTS4)
15497           CTSSMA=MIN(CTS3,CTS4)
15498           IF(PTH.LT.PTHMIN) MINT(51)=1
15499           IF(CKIN(4).GE.0..AND.PTH.GT.CKIN(4)) MINT(51)=1
15500           IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
15501           IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
15502           IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
15503           IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
15504           IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
15505           IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
15506           IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
15507         ENDIF
15508         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
15509           IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
15510           IF(CKIN(32).GE.0..AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
15511         ENDIF
15512
15513       ELSEIF(ILIM.EQ.1) THEN
15514 C...Calculate limits on tau
15515 C...0) due to definition
15516         TAUMN0=0.
15517         TAUMX0=1.
15518 C...1) due to limits on subsystem mass
15519         TAUMN1=CKIN(1)**2/VINT(2)
15520         TAUMX1=1.
15521         IF(CKIN(2).GE.0.) TAUMX1=CKIN(2)**2/VINT(2)
15522 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15523         TM3=SQRT(SQM3+PTHMIN**2)
15524         TM4=SQRT(SQM4+PTHMIN**2)
15525         YDCOSH=1.
15526         IF(CKIN(9).GT.CKIN(12)) YDCOSH=COSH(CKIN(9)-CKIN(12))
15527         TAUMN2=(TM3**2+2.*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
15528         TAUMX2=1.
15529 C...3) due to limits on pT-hat and cos(theta-hat)
15530         CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
15531         CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
15532         TAUMN3=0.
15533         IF(CKIN(27)*CKIN(28).GT.0.) TAUMN3=
15534      &  (SQRT(SQM3+PTHMIN**2/(1.-CTH2MN))+
15535      &  SQRT(SQM4+PTHMIN**2/(1.-CTH2MN)))**2/VINT(2)
15536         TAUMX3=1.
15537         IF(CKIN(4).GE.0..AND.CTH2MX.LT.1.) TAUMX3=
15538      &  (SQRT(SQM3+CKIN(4)**2/(1.-CTH2MX))+
15539      &  SQRT(SQM4+CKIN(4)**2/(1.-CTH2MX)))**2/VINT(2)
15540 C...4) due to limits on x1 and x2
15541         TAUMN4=CKIN(21)*CKIN(23)
15542         TAUMX4=CKIN(22)*CKIN(24)
15543 C...5) due to limits on xF
15544         TAUMN5=0.
15545         TAUMX5=MAX(1.-CKIN(25),1.+CKIN(26))
15546         VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5)
15547         VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5)
15548         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
15549           VINT(11)=0.99999
15550           VINT(31)=1.00001
15551         ENDIF
15552         IF(VINT(31).LE.VINT(11)) MINT(51)=1
15553
15554       ELSEIF(ILIM.EQ.2) THEN
15555 C...Calculate limits on y*
15556         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) TAU=VINT(26)
15557         TAURT=SQRT(TAU)
15558 C...0) due to kinematics
15559         YSTMN0=LOG(TAURT)
15560         YSTMX0=-YSTMN0
15561 C...1) due to explicit limits
15562         YSTMN1=CKIN(7)
15563         YSTMX1=CKIN(8)
15564 C...2) due to limits on x1
15565         YSTMN2=LOG(MAX(TAU,CKIN(21))/TAURT)
15566         YSTMX2=LOG(MAX(TAU,CKIN(22))/TAURT)
15567 C...3) due to limits on x2
15568         YSTMN3=-LOG(MAX(TAU,CKIN(24))/TAURT)
15569         YSTMX3=-LOG(MAX(TAU,CKIN(23))/TAURT)
15570 C...4) due to limits on xF
15571         YEPMN4=0.5*ABS(CKIN(25))/TAURT
15572         YSTMN4=SIGN(LOG(SQRT(1.+YEPMN4**2)+YEPMN4),CKIN(25))
15573         YEPMX4=0.5*ABS(CKIN(26))/TAURT
15574         YSTMX4=SIGN(LOG(SQRT(1.+YEPMX4**2)+YEPMX4),CKIN(26))
15575 C...5) due to simultaneous limits on y-large and y-small
15576         YEPSMN=(RM3-RM4)*SINH(CKIN(9)-CKIN(11))
15577         YEPSMX=(RM3-RM4)*SINH(CKIN(10)-CKIN(12))
15578         YDIFMN=ABS(LOG(SQRT(1.+YEPSMN**2)-YEPSMN))
15579         YDIFMX=ABS(LOG(SQRT(1.+YEPSMX**2)-YEPSMX))
15580         YSTMN5=0.5*(CKIN(9)+CKIN(11)-YDIFMN)
15581         YSTMX5=0.5*(CKIN(10)+CKIN(12)+YDIFMX)
15582 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15583 C...   y-small
15584         CTHLIM=SQRT(1.-4.*PTHMIN**2/(BE34*TAU*VINT(2)))
15585         RZMN=BE34*MAX(CKIN(27),-CTHLIM)
15586         RZMX=BE34*MIN(CKIN(28),CTHLIM)
15587         YEX3MX=(1.+RM3-RM4+RZMX)/MAX(1E-10,1.+RM3-RM4-RZMX)
15588         YEX4MX=(1.+RM4-RM3-RZMN)/MAX(1E-10,1.+RM4-RM3+RZMN)
15589         YEX3MN=MAX(1E-10,1.+RM3-RM4+RZMN)/(1.+RM3-RM4-RZMN)
15590         YEX4MN=MAX(1E-10,1.+RM4-RM3-RZMX)/(1.+RM4-RM3+RZMX)
15591         YSTMN6=CKIN(9)-0.5*LOG(MAX(YEX3MX,YEX4MX))
15592         YSTMX6=CKIN(12)-0.5*LOG(MIN(YEX3MN,YEX4MN))
15593         VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
15594         VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
15595         IF(MINT(43).EQ.1) THEN
15596           VINT(12)=-0.00001
15597           VINT(32)=0.00001
15598         ELSEIF(MINT(43).EQ.2) THEN
15599           VINT(12)=0.99999*YSTMX0
15600           VINT(32)=1.00001*YSTMX0
15601         ELSEIF(MINT(43).EQ.3) THEN
15602           VINT(12)=-1.00001*YSTMX0
15603           VINT(32)=-0.99999*YSTMX0
15604         ENDIF
15605         IF(VINT(32).LE.VINT(12)) MINT(51)=1
15606
15607       ELSEIF(ILIM.EQ.3) THEN
15608 C...Calculate limits on cos(theta-hat)
15609         YST=VINT(22)
15610 C...0) due to definition
15611         CTNMN0=-1.
15612         CTNMX0=0.
15613         CTPMN0=0.
15614         CTPMX0=1.
15615 C...1) due to explicit limits
15616         CTNMN1=MIN(0.,CKIN(27))
15617         CTNMX1=MIN(0.,CKIN(28))
15618         CTPMN1=MAX(0.,CKIN(27))
15619         CTPMX1=MAX(0.,CKIN(28))
15620 C...2) due to limits on pT-hat
15621         CTNMN2=-SQRT(1.-4.*PTHMIN**2/(BE34**2*TAU*VINT(2)))
15622         CTPMX2=-CTNMN2
15623         CTNMX2=0.
15624         CTPMN2=0.
15625         IF(CKIN(4).GE.0.) THEN
15626           CTNMX2=-SQRT(MAX(0.,1.-4.*CKIN(4)**2/(BE34**2*TAU*VINT(2))))
15627           CTPMN2=-CTNMX2
15628         ENDIF
15629 C...3) due to limits on y-large and y-small
15630         CTNMN3=MIN(0.,MAX((1.+RM3-RM4)/BE34*TANH(CKIN(11)-YST),
15631      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(10)-YST)))
15632         CTNMX3=MIN(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(12)-YST),
15633      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(9)-YST))
15634         CTPMN3=MAX(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(9)-YST),
15635      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(12)-YST))
15636         CTPMX3=MAX(0.,MIN((1.+RM3-RM4)/BE34*TANH(CKIN(10)-YST),
15637      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(11)-YST)))
15638         VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3)
15639         VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3)
15640         VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3)
15641         VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3)
15642         IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
15643
15644       ELSEIF(ILIM.EQ.4) THEN
15645 C...Calculate limits on tau'
15646 C...0) due to kinematics
15647         TAPMN0=TAU
15648         TAPMX0=1.
15649 C...1) due to explicit limits
15650         TAPMN1=CKIN(31)**2/VINT(2)
15651         TAPMX1=1.
15652         IF(CKIN(32).GE.0.) TAPMX1=CKIN(32)**2/VINT(2)
15653         VINT(16)=MAX(TAPMN0,TAPMN1)
15654         VINT(36)=MIN(TAPMX0,TAPMX1)
15655         IF(MINT(43).EQ.1) THEN
15656           VINT(16)=0.99999
15657           VINT(36)=1.00001
15658         ENDIF
15659         IF(VINT(36).LE.VINT(16)) MINT(51)=1
15660
15661       ENDIF
15662       RETURN
15663
15664 C...Special case for low-pT and multiple interactions:
15665 C...effective kinematical limits for tau, y*, cos(theta-hat).
15666   110 IF(ILIM.EQ.0) THEN
15667       ELSEIF(ILIM.EQ.1) THEN
15668         IF(MSTP(82).LE.1) VINT(11)=4.*PARP(81)**2/VINT(2)
15669         IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
15670         VINT(31)=1.
15671       ELSEIF(ILIM.EQ.2) THEN
15672         VINT(12)=0.5*LOG(VINT(21))
15673         VINT(32)=-VINT(12)
15674       ELSEIF(ILIM.EQ.3) THEN
15675         IF(MSTP(82).LE.1) ST2EFF=4.*PARP(81)**2/(VINT(21)*VINT(2))
15676         IF(MSTP(82).GE.2) ST2EFF=0.01*PARP(82)**2/(VINT(21)*VINT(2))
15677         VINT(13)=-SQRT(MAX(0.,1.-ST2EFF))
15678         VINT(33)=0.
15679         VINT(14)=0.
15680         VINT(34)=-VINT(13)
15681       ENDIF
15682
15683       RETURN
15684       END
15685
15686 C*********************************************************************
15687
15688       SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
15689
15690 C...Maps a uniform distribution into a distribution of a kinematical
15691 C...variable according to one of the possibilities allowed. It is
15692 C...assumed that kinematical limits have been set by a PYKLIM call.
15693       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
15694       COMMON/PYINT1/MINT(400),VINT(400)
15695       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
15696       SAVE
15697
15698 C...Convert VVAR to tau variable.
15699       ISUB=MINT(1)
15700       IF(IVAR.EQ.1) THEN
15701         TAUMIN=VINT(11)
15702         TAUMAX=VINT(31)
15703         IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
15704           TAURE=VINT(73)
15705           GAMRE=VINT(74)
15706         ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
15707           TAURE=VINT(75)
15708           GAMRE=VINT(76)
15709         ENDIF
15710         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
15711           TAU=1.
15712         ELSEIF(MVAR.EQ.1) THEN
15713           TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
15714         ELSEIF(MVAR.EQ.2) THEN
15715           TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
15716         ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
15717           RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
15718           TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
15719         ELSE
15720           AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
15721           ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
15722           TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
15723         ENDIF
15724         VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
15725
15726 C...Convert VVAR to y* variable.
15727       ELSEIF(IVAR.EQ.2) THEN
15728         YSTMIN=VINT(12)
15729         YSTMAX=VINT(32)
15730         IF(MINT(43).EQ.1) THEN
15731           YST=0.
15732         ELSEIF(MINT(43).EQ.2) THEN
15733           IF(ISET(ISUB).LE.2) YST=-0.5*LOG(VINT(21))
15734           IF(ISET(ISUB).GE.3) YST=-0.5*LOG(VINT(26))
15735         ELSEIF(MINT(43).EQ.3) THEN
15736           IF(ISET(ISUB).LE.2) YST=0.5*LOG(VINT(21))
15737           IF(ISET(ISUB).GE.3) YST=0.5*LOG(VINT(26))
15738         ELSEIF(MVAR.EQ.1) THEN
15739           YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
15740         ELSEIF(MVAR.EQ.2) THEN
15741           YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1.-VVAR)
15742         ELSE
15743           AUPP=ATAN(EXP(YSTMAX))
15744           ALOW=ATAN(EXP(YSTMIN))
15745           YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
15746         ENDIF
15747         VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
15748
15749 C...Convert VVAR to cos(theta-hat) variable.
15750       ELSEIF(IVAR.EQ.3) THEN
15751         RM34=2.*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2
15752         RSQM=1.+RM34
15753         IF(2.*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001) RM34=MAX(RM34,
15754      &  2.*VINT(71)**2/(VINT(21)*VINT(2)))
15755         CTNMIN=VINT(13)
15756         CTNMAX=VINT(33)
15757         CTPMIN=VINT(14)
15758         CTPMAX=VINT(34)
15759         IF(MVAR.EQ.1) THEN
15760           ANEG=CTNMAX-CTNMIN
15761           APOS=CTPMAX-CTPMIN
15762           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15763             VCTN=VVAR*(ANEG+APOS)/ANEG
15764             CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
15765           ELSE
15766             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15767             CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
15768           ENDIF
15769         ELSEIF(MVAR.EQ.2) THEN
15770           RMNMIN=MAX(RM34,RSQM-CTNMIN)
15771           RMNMAX=MAX(RM34,RSQM-CTNMAX)
15772           RMPMIN=MAX(RM34,RSQM-CTPMIN)
15773           RMPMAX=MAX(RM34,RSQM-CTPMAX)
15774           ANEG=LOG(RMNMIN/RMNMAX)
15775           APOS=LOG(RMPMIN/RMPMAX)
15776           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15777             VCTN=VVAR*(ANEG+APOS)/ANEG
15778             CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
15779           ELSE
15780             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15781             CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
15782           ENDIF
15783         ELSEIF(MVAR.EQ.3) THEN
15784           RMNMIN=MAX(RM34,RSQM+CTNMIN)
15785           RMNMAX=MAX(RM34,RSQM+CTNMAX)
15786           RMPMIN=MAX(RM34,RSQM+CTPMIN)
15787           RMPMAX=MAX(RM34,RSQM+CTPMAX)
15788           ANEG=LOG(RMNMAX/RMNMIN)
15789           APOS=LOG(RMPMAX/RMPMIN)
15790           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15791             VCTN=VVAR*(ANEG+APOS)/ANEG
15792             CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
15793           ELSE
15794             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15795             CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
15796           ENDIF
15797         ELSEIF(MVAR.EQ.4) THEN
15798           RMNMIN=MAX(RM34,RSQM-CTNMIN)
15799           RMNMAX=MAX(RM34,RSQM-CTNMAX)
15800           RMPMIN=MAX(RM34,RSQM-CTPMIN)
15801           RMPMAX=MAX(RM34,RSQM-CTPMAX)
15802           ANEG=1./RMNMAX-1./RMNMIN
15803           APOS=1./RMPMAX-1./RMPMIN
15804           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15805             VCTN=VVAR*(ANEG+APOS)/ANEG
15806             CTH=RSQM-1./(1./RMNMIN+ANEG*VCTN)
15807           ELSE
15808             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15809             CTH=RSQM-1./(1./RMPMIN+APOS*VCTP)
15810           ENDIF
15811         ELSEIF(MVAR.EQ.5) THEN
15812           RMNMIN=MAX(RM34,RSQM+CTNMIN)
15813           RMNMAX=MAX(RM34,RSQM+CTNMAX)
15814           RMPMIN=MAX(RM34,RSQM+CTPMIN)
15815           RMPMAX=MAX(RM34,RSQM+CTPMAX)
15816           ANEG=1./RMNMIN-1./RMNMAX
15817           APOS=1./RMPMIN-1./RMPMAX
15818           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15819             VCTN=VVAR*(ANEG+APOS)/ANEG
15820             CTH=1./(1./RMNMIN-ANEG*VCTN)-RSQM
15821           ELSE
15822             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15823             CTH=1./(1./RMPMIN-APOS*VCTP)-RSQM
15824           ENDIF
15825         ENDIF
15826         IF(CTH.LT.0.) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
15827         IF(CTH.GT.0.) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
15828         VINT(23)=CTH
15829
15830 C...Convert VVAR to tau' variable.
15831       ELSEIF(IVAR.EQ.4) THEN
15832         TAU=VINT(11)
15833         TAUPMN=VINT(16)
15834         TAUPMX=VINT(36)
15835         IF(MINT(43).EQ.1) THEN
15836           TAUP=1.
15837         ELSEIF(MVAR.EQ.1) THEN
15838           TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
15839         ELSE
15840           AUPP=(1.-TAU/TAUPMX)**4
15841           ALOW=(1.-TAU/TAUPMN)**4
15842           TAUP=TAU/(1.-(ALOW+(AUPP-ALOW)*VVAR)**0.25)
15843         ENDIF
15844         VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
15845       ENDIF
15846
15847       RETURN
15848       END
15849
15850 C***********************************************************************
15851
15852       SUBROUTINE PYSIGH(NCHN,SIGS)
15853
15854 C...Differential matrix elements for all included subprocesses.
15855 C...Note that what is coded is (disregarding the COMFAC factor)
15856 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
15857 C...when d(sigma-hat) is given in the zero-width limit, the delta
15858 C...function in tau is replaced by a Breit-Wigner:
15859 C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);
15860 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
15861 C...i.e., dimensionless quantities. COMFAC contains the factor
15862 C...pi/s and the conversion factor from GeV^-2 to mb.
15863       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15864       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
15865       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
15866       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
15867       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15868       COMMON/PYINT1/MINT(400),VINT(400)
15869       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
15870       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15871       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
15872       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
15873       DIMENSION X(2),XPQ(-6:6),KFAC(2,-40:40),WDTP(0:40),WDTE(0:40,0:5)
15874       SAVE
15875
15876 C...Reset number of channels and cross-section.
15877       NCHN=0
15878       SIGS=0.
15879
15880 C...Read kinematical variables and limits.
15881       ISUB=MINT(1)
15882       TAUMIN=VINT(11)
15883       YSTMIN=VINT(12)
15884       CTNMIN=VINT(13)
15885       CTPMIN=VINT(14)
15886       XT2MIN=VINT(15)
15887       TAUPMN=VINT(16)
15888       TAU=VINT(21)
15889       YST=VINT(22)
15890       CTH=VINT(23)
15891       XT2=VINT(25)
15892       TAUP=VINT(26)
15893       TAUMAX=VINT(31)
15894       YSTMAX=VINT(32)
15895       CTNMAX=VINT(33)
15896       CTPMAX=VINT(34)
15897       XT2MAX=VINT(35)
15898       TAUPMX=VINT(36)
15899
15900 C...Derive kinematical quantities.
15901       IF(ISET(ISUB).LE.2.OR.ISET(ISUB).EQ.5) THEN
15902         X(1)=SQRT(TAU)*EXP(YST)
15903         X(2)=SQRT(TAU)*EXP(-YST)
15904       ELSE
15905         X(1)=SQRT(TAUP)*EXP(YST)
15906         X(2)=SQRT(TAUP)*EXP(-YST)
15907       ENDIF
15908       IF(MINT(43).EQ.4.AND.ISET(ISUB).GE.1.AND.
15909      &(X(1).GT.0.999.OR.X(2).GT.0.999)) RETURN
15910       SH=TAU*VINT(2)
15911       SQM3=VINT(63)
15912       SQM4=VINT(64)
15913       RM3=SQM3/SH
15914       RM4=SQM4/SH
15915       BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
15916       RPTS=4.*VINT(71)**2/SH
15917       BE34L=SQRT(MAX(0.,(1.-RM3-RM4)**2-4.*RM3*RM4-RPTS))
15918       RM34=2.*RM3*RM4
15919       RSQM=1.+RM34
15920       RTHM=(4.*RM3*RM4+RPTS)/(1.-RM3-RM4+BE34L)
15921       TH=-0.5*SH*MAX(RTHM,1.-RM3-RM4-BE34*CTH)
15922       UH=-0.5*SH*MAX(RTHM,1.-RM3-RM4+BE34*CTH)
15923       SQPTH=0.25*SH*BE34**2*(1.-CTH**2)
15924       SH2=SH**2
15925       TH2=TH**2
15926       UH2=UH**2
15927
15928 C...Choice of Q2 scale.
15929       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15930         Q2=SH
15931       ELSEIF(MOD(ISET(ISUB),2).EQ.0.OR.ISET(ISUB).EQ.5) THEN
15932         IF(MSTP(32).EQ.1) THEN
15933           Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
15934         ELSEIF(MSTP(32).EQ.2) THEN
15935           Q2=SQPTH+0.5*(SQM3+SQM4)
15936         ELSEIF(MSTP(32).EQ.3) THEN
15937           Q2=MIN(-TH,-UH)
15938         ELSEIF(MSTP(32).EQ.4) THEN
15939           Q2=SH
15940         ENDIF
15941         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2=Q2+PARP(82)**2
15942       ENDIF
15943
15944 C...Store derived kinematical quantities.
15945       VINT(41)=X(1)
15946       VINT(42)=X(2)
15947       VINT(44)=SH
15948       VINT(43)=SQRT(SH)
15949       VINT(45)=TH
15950       VINT(46)=UH
15951       VINT(48)=SQPTH
15952       VINT(47)=SQRT(SQPTH)
15953       VINT(50)=TAUP*VINT(2)
15954       VINT(49)=SQRT(MAX(0.,VINT(50)))
15955       VINT(52)=Q2
15956       VINT(51)=SQRT(Q2)
15957
15958 C...Calculate parton structure functions.
15959       IF(ISET(ISUB).LE.0) GOTO 145
15960       IF(MINT(43).GE.2) THEN
15961         Q2SF=Q2
15962         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
15963           Q2SF=PMAS(23,1)**2
15964           IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2SF=PMAS(24,1)**2
15965         ENDIF
15966         DO 100 I=3-MINT(41),MINT(42)
15967         XSF=X(I)
15968         IF(ISET(ISUB).EQ.5) XSF=X(I)/VINT(142+I)
15969         CALL PYSTFU(MINT(10+I),XSF,Q2SF,XPQ,I)
15970         DO 100 KFL=-6,6
15971   100   XSFX(I,KFL)=XPQ(KFL)
15972       ENDIF
15973
15974 C...Calculate alpha_strong and K-factor.
15975       IF(MSTP(33).NE.3) AS=ULALPS(Q2)
15976       FACK=1.
15977       FACA=1.
15978       IF(MSTP(33).EQ.1) THEN
15979         FACK=PARP(31)
15980       ELSEIF(MSTP(33).EQ.2) THEN
15981         FACK=PARP(31)
15982         FACA=PARP(32)/PARP(31)
15983       ELSEIF(MSTP(33).EQ.3) THEN
15984         Q2AS=PARP(33)*Q2
15985         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2AS=Q2AS+
15986      &  PARU(112)*PARP(82)
15987         AS=ULALPS(Q2AS)
15988       ENDIF
15989       RADC=1.+AS/PARU(1)
15990
15991 C...Set flags for allowed reacting partons/leptons.
15992       DO 130 I=1,2
15993       DO 110 J=-40,40
15994   110 KFAC(I,J)=0
15995       IF(MINT(40+I).EQ.1) THEN
15996         KFAC(I,MINT(10+I))=1
15997       ELSE
15998         DO 120 J=-40,40
15999         KFAC(I,J)=KFIN(I,J)
16000         IF(ABS(J).GT.MSTP(54).AND.J.NE.21) KFAC(I,J)=0
16001         IF(ABS(J).LE.6) THEN
16002           IF(XSFX(I,J).LT.1.E-10) KFAC(I,J)=0
16003         ELSEIF(J.EQ.21) THEN
16004           IF(XSFX(I,0).LT.1.E-10) KFAC(I,21)=0
16005         ENDIF
16006   120   CONTINUE
16007       ENDIF
16008   130 CONTINUE
16009
16010 C...Lower and upper limit for flavour loops.
16011       MIN1=0
16012       MAX1=0
16013       MIN2=0
16014       MAX2=0
16015       DO 140 J=-20,20
16016       IF(KFAC(1,-J).EQ.1) MIN1=-J
16017       IF(KFAC(1,J).EQ.1) MAX1=J
16018       IF(KFAC(2,-J).EQ.1) MIN2=-J
16019       IF(KFAC(2,J).EQ.1) MAX2=J
16020   140 CONTINUE
16021       MINA=MIN(MIN1,MIN2)
16022       MAXA=MAX(MAX1,MAX2)
16023
16024 C...Common conversion factors (including Jacobian) for subprocesses.
16025       SQMZ=PMAS(23,1)**2
16026       GMMZ=PMAS(23,1)*PMAS(23,2)
16027       SQMW=PMAS(24,1)**2
16028       GMMW=PMAS(24,1)*PMAS(24,2)
16029       SQMH=PMAS(25,1)**2
16030       GMMH=PMAS(25,1)*PMAS(25,2)
16031       SQMZP=PMAS(32,1)**2
16032       GMMZP=PMAS(32,1)*PMAS(32,2)
16033       SQMHC=PMAS(37,1)**2
16034       GMMHC=PMAS(37,1)*PMAS(37,2)
16035       SQMR=PMAS(40,1)**2
16036       GMMR=PMAS(40,1)*PMAS(40,2)
16037       AEM=PARU(101)
16038       XW=PARU(102)
16039
16040 C...Phase space integral in tau and y*.
16041       COMFAC=PARU(1)*PARU(5)/VINT(2)
16042       IF(MINT(43).EQ.4) COMFAC=COMFAC*FACK
16043       IF((MINT(43).GE.2.OR.ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4).AND.
16044      &ISET(ISUB).NE.5) THEN
16045         ATAU0=LOG(TAUMAX/TAUMIN)
16046         ATAU1=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
16047         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/TAU
16048         IF(MINT(72).GE.1) THEN
16049           TAUR1=VINT(73)
16050           GAMR1=VINT(74)
16051           ATAU2=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
16052           ATAU3=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
16053      &    GAMR1
16054           H1=H1+(ATAU0/ATAU2)*COEF(ISUB,3)/(TAU+TAUR1)+
16055      &    (ATAU0/ATAU3)*COEF(ISUB,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
16056         ENDIF
16057         IF(MINT(72).EQ.2) THEN
16058           TAUR2=VINT(75)
16059           GAMR2=VINT(76)
16060           ATAU4=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
16061           ATAU5=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
16062      &    GAMR2
16063           H1=H1+(ATAU0/ATAU4)*COEF(ISUB,5)/(TAU+TAUR2)+
16064      &    (ATAU0/ATAU5)*COEF(ISUB,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
16065         ENDIF
16066         COMFAC=COMFAC*ATAU0/(TAU*H1)
16067       ENDIF
16068       IF(MINT(43).EQ.4.AND.ISET(ISUB).NE.5) THEN
16069         AYST0=YSTMAX-YSTMIN
16070         AYST1=0.5*(YSTMAX-YSTMIN)**2
16071         AYST2=AYST1
16072         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16073         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST2)*
16074      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
16075         COMFAC=COMFAC*AYST0/H2
16076       ENDIF
16077
16078 C...2 -> 1 processes: reduction in angular part of phase space integral
16079 C...for case of decaying resonance.
16080       ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
16081       IF((ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3).AND.
16082      &MDCY(KFPR(ISUB,1),1).EQ.1) THEN
16083         IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN
16084           COMFAC=COMFAC*0.5*ACTH0
16085         ELSE
16086           COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+
16087      &    CTPMAX**3-CTPMIN**3)
16088         ENDIF
16089
16090 C...2 -> 2 processes: angular part of phase space integral.
16091       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
16092         ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
16093      &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
16094         ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
16095      &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
16096         ACTH3=1./MAX(RM34,RSQM-CTNMAX)-1./MAX(RM34,RSQM-CTNMIN)+
16097      &  1./MAX(RM34,RSQM-CTPMAX)-1./MAX(RM34,RSQM-CTPMIN)
16098         ACTH4=1./MAX(RM34,RSQM+CTNMIN)-1./MAX(RM34,RSQM+CTNMAX)+
16099      &  1./MAX(RM34,RSQM+CTPMIN)-1./MAX(RM34,RSQM+CTPMAX)
16100         H3=COEF(ISUB,10)+
16101      &  (ACTH0/ACTH1)*COEF(ISUB,11)/MAX(RM34,RSQM-CTH)+
16102      &  (ACTH0/ACTH2)*COEF(ISUB,12)/MAX(RM34,RSQM+CTH)+
16103      &  (ACTH0/ACTH3)*COEF(ISUB,13)/MAX(RM34,RSQM-CTH)**2+
16104      &  (ACTH0/ACTH4)*COEF(ISUB,14)/MAX(RM34,RSQM+CTH)**2
16105         COMFAC=COMFAC*ACTH0*0.5*BE34/H3
16106       ENDIF
16107
16108 C...2 -> 3, 4 processes: phace space integral in tau'.
16109       IF(MINT(43).GE.2.AND.(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4)) THEN
16110         ATAUP0=LOG(TAUPMX/TAUPMN)
16111         ATAUP1=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
16112         H4=COEF(ISUB,15)+
16113      &  ATAUP0/ATAUP1*COEF(ISUB,16)/TAUP*(1.-TAU/TAUP)**3
16114         IF(1.-TAU/TAUP.GT.1.E-4) THEN
16115           FZW=(1.+TAU/TAUP)*LOG(TAUP/TAU)-2.*(1.-TAU/TAUP)
16116         ELSE
16117           FZW=1./6.*(1.-TAU/TAUP)**3*TAU/TAUP
16118         ENDIF
16119         COMFAC=COMFAC*ATAUP0*FZW/H4
16120       ENDIF
16121
16122 C...Phase space integral for low-pT and multiple interactions.
16123       IF(ISET(ISUB).EQ.5) THEN
16124         COMFAC=PARU(1)*PARU(5)*FACK*0.5*VINT(2)/SH2
16125         ATAU0=LOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)
16126         ATAU1=2.*ATAN(1./XT2-1.)/SQRT(XT2)
16127         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/SQRT(TAU)
16128         COMFAC=COMFAC*ATAU0/H1
16129         AYST0=YSTMAX-YSTMIN
16130         AYST1=0.5*(YSTMAX-YSTMIN)**2
16131         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16132         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST1)*
16133      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
16134         COMFAC=COMFAC*AYST0/H2
16135         IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1./VINT(149)-1.)
16136 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16137 C...introduced to make cross-section finite for xT2 -> 0.
16138         IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
16139      &  (1.+VINT(149)))
16140       ENDIF
16141
16142 C...A: 2 -> 1, tree diagrams.
16143
16144   145 IF(ISUB.LE.10) THEN
16145       IF(ISUB.EQ.1) THEN
16146 C...f + fb -> gamma*/Z0.
16147         MINT(61)=2
16148         CALL PYWIDT(23,SQRT(SH),WDTP,WDTE)
16149         FACZ=COMFAC*AEM**2*4./3.
16150         DO 150 I=MINA,MAXA
16151         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
16152         EI=KCHG(IABS(I),1)/3.
16153         AI=SIGN(1.,EI)
16154         VI=AI-4.*EI*XW
16155         FACF=1.
16156         IF(IABS(I).LE.10) FACF=FACA/3.
16157         NCHN=NCHN+1
16158         ISIG(NCHN,1)=I
16159         ISIG(NCHN,2)=-I
16160         ISIG(NCHN,3)=1
16161         SIGH(NCHN)=FACF*FACZ*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
16162      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+(VI**2+AI**2)/
16163      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*VINT(114))
16164   150   CONTINUE
16165
16166       ELSEIF(ISUB.EQ.2) THEN
16167 C...f + fb' -> W+/-.
16168         CALL PYWIDT(24,SQRT(SH),WDTP,WDTE)
16169         FACW=COMFAC*(AEM/XW)**2*1./24*SH2/((SH-SQMW)**2+GMMW**2)
16170         DO 170 I=MIN1,MAX1
16171         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 170
16172         IA=IABS(I)
16173         DO 160 J=MIN2,MAX2
16174         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 160
16175         JA=IABS(J)
16176         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
16177         IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) GOTO 160
16178         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16179         FACF=1.
16180         IF(IA.LE.10) FACF=VCKM((IA+1)/2,(JA+1)/2)*FACA/3.
16181         NCHN=NCHN+1
16182         ISIG(NCHN,1)=I
16183         ISIG(NCHN,2)=J
16184         ISIG(NCHN,3)=1
16185         SIGH(NCHN)=FACF*FACW*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
16186   160   CONTINUE
16187   170   CONTINUE
16188
16189       ELSEIF(ISUB.EQ.3) THEN
16190 C...f + fb -> H0.
16191         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
16192         FACH=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*
16193      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16194         DO 180 I=MINA,MAXA
16195         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
16196         RMQ=PMAS(IABS(I),1)**2/SH
16197         NCHN=NCHN+1
16198         ISIG(NCHN,1)=I
16199         ISIG(NCHN,2)=-I
16200         ISIG(NCHN,3)=1
16201         SIGH(NCHN)=FACH*RMQ*SQRT(MAX(0.,1.-4.*RMQ))
16202   180   CONTINUE
16203
16204       ELSEIF(ISUB.EQ.4) THEN
16205 C...gamma + W+/- -> W+/-.
16206
16207       ELSEIF(ISUB.EQ.5) THEN
16208 C...Z0 + Z0 -> H0.
16209         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
16210         FACH=COMFAC*1./(128.*PARU(1)**2*16.*(1.-XW)**3)*(AEM/XW)**4*
16211      &  (SH/SQMW)**2*SH2/((SH-SQMH)**2+GMMH**2)*
16212      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16213         DO 200 I=MIN1,MAX1
16214         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
16215         DO 190 J=MIN2,MAX2
16216         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
16217         EI=KCHG(IABS(I),1)/3.
16218         AI=SIGN(1.,EI)
16219         VI=AI-4.*EI*XW
16220         EJ=KCHG(IABS(J),1)/3.
16221         AJ=SIGN(1.,EJ)
16222         VJ=AJ-4.*EJ*XW
16223         NCHN=NCHN+1
16224         ISIG(NCHN,1)=I
16225         ISIG(NCHN,2)=J
16226         ISIG(NCHN,3)=1
16227         SIGH(NCHN)=FACH*(VI**2+AI**2)*(VJ**2+AJ**2)
16228   190   CONTINUE
16229   200   CONTINUE
16230
16231       ELSEIF(ISUB.EQ.6) THEN
16232 C...Z0 + W+/- -> W+/-.
16233
16234       ELSEIF(ISUB.EQ.7) THEN
16235 C...W+ + W- -> Z0.
16236
16237       ELSEIF(ISUB.EQ.8) THEN
16238 C...W+ + W- -> H0.
16239         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
16240         FACH=COMFAC*1./(128*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
16241      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16242         DO 220 I=MIN1,MAX1
16243         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 220
16244         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
16245         DO 210 J=MIN2,MAX2
16246         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 210
16247         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
16248         IF(EI*EJ.GT.0.) GOTO 210
16249         NCHN=NCHN+1
16250         ISIG(NCHN,1)=I
16251         ISIG(NCHN,2)=J
16252         ISIG(NCHN,3)=1
16253         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
16254   210   CONTINUE
16255   220   CONTINUE
16256       ENDIF
16257
16258 C...B: 2 -> 2, tree diagrams.
16259
16260       ELSEIF(ISUB.LE.20) THEN
16261       IF(ISUB.EQ.11) THEN
16262 C...f + f' -> f + f'.
16263         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
16264         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
16265      &  MSTP(34)*2./3.*UH2/(SH*TH))
16266         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
16267      &  MSTP(34)*2./3.*SH2/(TH*UH))
16268         DO 240 I=MIN1,MAX1
16269         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
16270         DO 230 J=MIN2,MAX2
16271         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
16272         NCHN=NCHN+1
16273         ISIG(NCHN,1)=I
16274         ISIG(NCHN,2)=J
16275         ISIG(NCHN,3)=1
16276         SIGH(NCHN)=FACQQ1
16277         IF(I.EQ.-J) SIGH(NCHN)=FACQQB
16278         IF(I.EQ.J) THEN
16279           SIGH(NCHN)=0.5*SIGH(NCHN)
16280           NCHN=NCHN+1
16281           ISIG(NCHN,1)=I
16282           ISIG(NCHN,2)=J
16283           ISIG(NCHN,3)=2
16284           SIGH(NCHN)=0.5*FACQQ2
16285         ENDIF
16286   230   CONTINUE
16287   240   CONTINUE
16288
16289       ELSEIF(ISUB.EQ.12) THEN
16290 C...f + fb -> f' + fb' (q + qb -> q' + qb' only).
16291         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)
16292         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
16293      &  WDTE(0,3)+WDTE(0,4))
16294         DO 250 I=MINA,MAXA
16295         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 250
16296         NCHN=NCHN+1
16297         ISIG(NCHN,1)=I
16298         ISIG(NCHN,2)=-I
16299         ISIG(NCHN,3)=1
16300         SIGH(NCHN)=FACQQB
16301   250   CONTINUE
16302
16303       ELSEIF(ISUB.EQ.13) THEN
16304 C...f + fb -> g + g (q + qb -> g + g only).
16305         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
16306         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
16307         DO 260 I=MINA,MAXA
16308         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
16309         NCHN=NCHN+1
16310         ISIG(NCHN,1)=I
16311         ISIG(NCHN,2)=-I
16312         ISIG(NCHN,3)=1
16313         SIGH(NCHN)=0.5*FACGG1
16314         NCHN=NCHN+1
16315         ISIG(NCHN,1)=I
16316         ISIG(NCHN,2)=-I
16317         ISIG(NCHN,3)=2
16318         SIGH(NCHN)=0.5*FACGG2
16319   260   CONTINUE
16320
16321       ELSEIF(ISUB.EQ.14) THEN
16322 C...f + fb -> g + gamma (q + qb -> g + gamma only).
16323         FACGG=COMFAC*AS*AEM*8./9.*(TH2+UH2)/(TH*UH)
16324         DO 270 I=MINA,MAXA
16325         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
16326         EI=KCHG(IABS(I),1)/3.
16327         NCHN=NCHN+1
16328         ISIG(NCHN,1)=I
16329         ISIG(NCHN,2)=-I
16330         ISIG(NCHN,3)=1
16331         SIGH(NCHN)=FACGG*EI**2
16332   270   CONTINUE
16333
16334       ELSEIF(ISUB.EQ.15) THEN
16335 C...f + fb -> g + Z0 (q + qb -> g + Z0 only).
16336         FACZG=COMFAC*AS*AEM/(XW*(1.-XW))*1./18.*
16337      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)
16338         FACZG=FACZG*WIDS(23,2)
16339         DO 280 I=MINA,MAXA
16340         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
16341         EI=KCHG(IABS(I),1)/3.
16342         AI=SIGN(1.,EI)
16343         VI=AI-4.*EI*XW
16344         NCHN=NCHN+1
16345         ISIG(NCHN,1)=I
16346         ISIG(NCHN,2)=-I
16347         ISIG(NCHN,3)=1
16348         SIGH(NCHN)=FACZG*(VI**2+AI**2)
16349   280   CONTINUE
16350
16351       ELSEIF(ISUB.EQ.16) THEN
16352 C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only).
16353         FACWG=COMFAC*AS*AEM/XW*2./9.*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
16354         DO 300 I=MIN1,MAX1
16355         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
16356         IA=IABS(I)
16357         DO 290 J=MIN2,MAX2
16358         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
16359         JA=IABS(J)
16360         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
16361         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16362         FCKM=1.
16363         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16364         NCHN=NCHN+1
16365         ISIG(NCHN,1)=I
16366         ISIG(NCHN,2)=J
16367         ISIG(NCHN,3)=1
16368         SIGH(NCHN)=FACWG*FCKM*WIDS(24,(5-KCHW)/2)
16369   290   CONTINUE
16370   300   CONTINUE
16371
16372       ELSEIF(ISUB.EQ.17) THEN
16373 C...f + fb -> g + H0 (q + qb -> g + H0 only).
16374
16375       ELSEIF(ISUB.EQ.18) THEN
16376 C...f + fb -> gamma + gamma.
16377         FACGG=COMFAC*FACA*AEM**2*1./3.*(TH2+UH2)/(TH*UH)
16378         DO 310 I=MINA,MAXA
16379         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
16380         EI=KCHG(IABS(I),1)/3.
16381         NCHN=NCHN+1
16382         ISIG(NCHN,1)=I
16383         ISIG(NCHN,2)=-I
16384         ISIG(NCHN,3)=1
16385         SIGH(NCHN)=FACGG*EI**4
16386   310   CONTINUE
16387
16388       ELSEIF(ISUB.EQ.19) THEN
16389 C...f + fb -> gamma + Z0.
16390         FACGZ=COMFAC*FACA*AEM**2/(XW*(1.-XW))*1./24.*
16391      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)
16392         FACGZ=FACGZ*WIDS(23,2)
16393         DO 320 I=MINA,MAXA
16394         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
16395         EI=KCHG(IABS(I),1)/3.
16396         AI=SIGN(1.,EI)
16397         VI=AI-4.*EI*XW
16398         NCHN=NCHN+1
16399         ISIG(NCHN,1)=I
16400         ISIG(NCHN,2)=-I
16401         ISIG(NCHN,3)=1
16402         SIGH(NCHN)=FACGZ*EI**2*(VI**2+AI**2)
16403   320   CONTINUE
16404
16405       ELSEIF(ISUB.EQ.20) THEN
16406 C...f + fb' -> gamma + W+/-.
16407         FACGW=COMFAC*FACA*AEM**2/XW*1./6.*
16408      &  ((2.*UH-TH)/(3.*(SH-SQM4)))**2*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
16409         DO 340 I=MIN1,MAX1
16410         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
16411         IA=IABS(I)
16412         DO 330 J=MIN2,MAX2
16413         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
16414         JA=IABS(J)
16415         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 330
16416         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16417         FCKM=1.
16418         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16419         NCHN=NCHN+1
16420         ISIG(NCHN,1)=I
16421         ISIG(NCHN,2)=J
16422         ISIG(NCHN,3)=1
16423         SIGH(NCHN)=FACGW*FCKM*WIDS(24,(5-KCHW)/2)
16424   330   CONTINUE
16425   340   CONTINUE
16426       ENDIF
16427
16428       ELSEIF(ISUB.LE.30) THEN
16429       IF(ISUB.EQ.21) THEN
16430 C...f + fb -> gamma + H0.
16431
16432       ELSEIF(ISUB.EQ.22) THEN
16433 C...f + fb -> Z0 + Z0.
16434         FACZZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./768.*
16435      &  (UH/TH+TH/UH+2.*(SQM3+SQM4)*SH/(TH*UH)-
16436      &  SQM3*SQM4*(1./TH2+1./UH2))
16437         FACZZ=FACZZ*WIDS(23,1)
16438         DO 350 I=MINA,MAXA
16439         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
16440         EI=KCHG(IABS(I),1)/3.
16441         AI=SIGN(1.,EI)
16442         VI=AI-4.*EI*XW
16443         NCHN=NCHN+1
16444         ISIG(NCHN,1)=I
16445         ISIG(NCHN,2)=-I
16446         ISIG(NCHN,3)=1
16447         SIGH(NCHN)=FACZZ*(VI**4+6.*VI**2*AI**2+AI**4)
16448   350   CONTINUE
16449
16450       ELSEIF(ISUB.EQ.23) THEN
16451 C...f + fb' -> Z0 + W+/-.
16452         FACZW=COMFAC*FACA*(AEM/XW)**2*1./6.
16453         FACZW=FACZW*WIDS(23,2)
16454         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16455         DO 370 I=MIN1,MAX1
16456         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
16457         IA=IABS(I)
16458         DO 360 J=MIN2,MAX2
16459         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
16460         JA=IABS(J)
16461         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
16462         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16463         EI=KCHG(IA,1)/3.
16464         AI=SIGN(1.,EI)
16465         VI=AI-4.*EI*XW
16466         EJ=KCHG(JA,1)/3.
16467         AJ=SIGN(1.,EJ)
16468         VJ=AJ-4.*EJ*XW
16469         IF(VI+AI.GT.0) THEN
16470           VISAV=VI
16471           AISAV=AI
16472           VI=VJ
16473           AI=AJ
16474           VJ=VISAV
16475           AJ=AISAV
16476         ENDIF
16477         FCKM=1.
16478         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16479         NCHN=NCHN+1
16480         ISIG(NCHN,1)=I
16481         ISIG(NCHN,2)=J
16482         ISIG(NCHN,3)=1
16483         SIGH(NCHN)=FACZW*FCKM*(1./(SH-SQMW)**2*
16484      &  ((9.-8.*XW)/4.*THUH+(8.*XW-6.)/4.*SH*(SQM3+SQM4))+
16485      &  (THUH-SH*(SQM3+SQM4))/(2.*(SH-SQMW))*((VJ+AJ)/TH-(VI+AI)/UH)+
16486      &  THUH/(16.*(1.-XW))*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
16487      &  SH*(SQM3+SQM4)/(8.*(1.-XW))*(VI+AI)*(VJ+AJ)/(TH*UH))*
16488      &  WIDS(24,(5-KCHW)/2)
16489   360   CONTINUE
16490   370   CONTINUE
16491
16492       ELSEIF(ISUB.EQ.24) THEN
16493 C...f + fb -> Z0 + H0.
16494         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16495         FACHZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./96.*
16496      &  (THUH+2.*SH*SQMZ)/(SH-SQMZ)**2
16497         FACHZ=FACHZ*WIDS(23,2)*WIDS(25,2)
16498         DO 380 I=MINA,MAXA
16499         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
16500         EI=KCHG(IABS(I),1)/3.
16501         AI=SIGN(1.,EI)
16502         VI=AI-4.*EI*XW
16503         NCHN=NCHN+1
16504         ISIG(NCHN,1)=I
16505         ISIG(NCHN,2)=-I
16506         ISIG(NCHN,3)=1
16507         SIGH(NCHN)=FACHZ*(VI**2+AI**2)
16508   380   CONTINUE
16509
16510       ELSEIF(ISUB.EQ.25) THEN
16511 C...f + fb -> W+ + W-.
16512         FACWW=COMFAC*FACA*(AEM/XW)**2*1./12.
16513         FACWW=FACWW*WIDS(24,1)
16514         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16515         DO 390 I=MINA,MAXA
16516         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
16517         EI=KCHG(IABS(I),1)/3.
16518         AI=SIGN(1.,EI)
16519         VI=AI-4.*EI*XW
16520         DSIGWW=THUH/SH2*(3.-(SH-3.*(SQM3+SQM4))/(SH-SQMZ)*
16521      &  (VI+AI)/(2.*AI*(1.-XW))+(SH/(SH-SQMZ))**2*
16522      &  (1.-2.*(SQM3+SQM4)/SH+12.*SQM3*SQM4/SH2)*(VI**2+AI**2)/
16523      &  (8.*(1.-XW)**2))-2.*SQMZ/(SH-SQMZ)*(VI+AI)/AI+
16524      &  SQMZ*SH/(SH-SQMZ)**2*(1.-2.*(SQM3+SQM4)/SH)*(VI**2+AI**2)/
16525      &  (2.*(1.-XW))
16526         IF(KCHG(IABS(I),1).LT.0) THEN
16527           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
16528      &    (THUH/(SH*TH)-(SQM3+SQM4)/TH)+THUH/TH2
16529         ELSE
16530           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
16531      &    (THUH/(SH*UH)-(SQM3+SQM4)/UH)+THUH/UH2
16532         ENDIF
16533         NCHN=NCHN+1
16534         ISIG(NCHN,1)=I
16535         ISIG(NCHN,2)=-I
16536         ISIG(NCHN,3)=1
16537         SIGH(NCHN)=FACWW*DSIGWW
16538   390   CONTINUE
16539
16540       ELSEIF(ISUB.EQ.26) THEN
16541 C...f + fb' -> W+/- + H0.
16542         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
16543         FACHW=COMFAC*FACA*(AEM/XW)**2*1./24.*(THUH+2.*SH*SQMW)/
16544      &  (SH-SQMW)**2
16545         FACHW=FACHW*WIDS(25,2)
16546         DO 410 I=MIN1,MAX1
16547         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
16548         IA=IABS(I)
16549         DO 400 J=MIN2,MAX2
16550         IF(J.EQ.0.OR.KFAC(1,J).EQ.0) GOTO 400
16551         JA=IABS(J)
16552         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
16553         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16554         FCKM=1.
16555         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
16556         NCHN=NCHN+1
16557         ISIG(NCHN,1)=I
16558         ISIG(NCHN,2)=J
16559         ISIG(NCHN,3)=1
16560         SIGH(NCHN)=FACHW*FCKM*WIDS(24,(5-KCHW)/2)
16561   400   CONTINUE
16562   410   CONTINUE
16563
16564       ELSEIF(ISUB.EQ.27) THEN
16565 C...f + fb -> H0 + H0.
16566
16567       ELSEIF(ISUB.EQ.28) THEN
16568 C...f + g -> f + g (q + g -> q + g only).
16569         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
16570      &  FACA
16571         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
16572         DO 430 I=MINA,MAXA
16573         IF(I.EQ.0) GOTO 430
16574         DO 420 ISDE=1,2
16575         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
16576         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
16577         NCHN=NCHN+1
16578         ISIG(NCHN,ISDE)=I
16579         ISIG(NCHN,3-ISDE)=21
16580         ISIG(NCHN,3)=1
16581         SIGH(NCHN)=FACQG1
16582         NCHN=NCHN+1
16583         ISIG(NCHN,ISDE)=I
16584         ISIG(NCHN,3-ISDE)=21
16585         ISIG(NCHN,3)=2
16586         SIGH(NCHN)=FACQG2
16587   420   CONTINUE
16588   430   CONTINUE
16589
16590       ELSEIF(ISUB.EQ.29) THEN
16591 C...f + g -> f + gamma (q + g -> q + gamma only).
16592         FGQ=COMFAC*FACA*AS*AEM*1./3.*(SH2+UH2)/(-SH*UH)
16593         DO 450 I=MINA,MAXA
16594         IF(I.EQ.0) GOTO 450
16595         EI=KCHG(IABS(I),1)/3.
16596         FACGQ=FGQ*EI**2
16597         DO 440 ISDE=1,2
16598         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 440
16599         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 440
16600         NCHN=NCHN+1
16601         ISIG(NCHN,ISDE)=I
16602         ISIG(NCHN,3-ISDE)=21
16603         ISIG(NCHN,3)=1
16604         SIGH(NCHN)=FACGQ
16605   440   CONTINUE
16606   450   CONTINUE
16607
16608       ELSEIF(ISUB.EQ.30) THEN
16609 C...f + g -> f + Z0 (q + g -> q + Z0 only).
16610         FZQ=COMFAC*FACA*AS*AEM/(XW*(1.-XW))*1./48.*
16611      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
16612         FZQ=FZQ*WIDS(23,2)
16613         DO 470 I=MINA,MAXA
16614         IF(I.EQ.0) GOTO 470
16615         EI=KCHG(IABS(I),1)/3.
16616         AI=SIGN(1.,EI)
16617         VI=AI-4.*EI*XW
16618         FACZQ=FZQ*(VI**2+AI**2)
16619         DO 460 ISDE=1,2
16620         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 460
16621         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 460
16622         NCHN=NCHN+1
16623         ISIG(NCHN,ISDE)=I
16624         ISIG(NCHN,3-ISDE)=21
16625         ISIG(NCHN,3)=1
16626         SIGH(NCHN)=FACZQ
16627   460   CONTINUE
16628   470   CONTINUE
16629       ENDIF
16630
16631       ELSEIF(ISUB.LE.40) THEN
16632       IF(ISUB.EQ.31) THEN
16633 C...f + g -> f' + W+/- (q + g -> q' + W+/- only).
16634         FACWQ=COMFAC*FACA*AS*AEM/XW*1./12.*
16635      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
16636         DO 490 I=MINA,MAXA
16637         IF(I.EQ.0) GOTO 490
16638         IA=IABS(I)
16639         KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
16640         DO 480 ISDE=1,2
16641         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 480
16642         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 480
16643         NCHN=NCHN+1
16644         ISIG(NCHN,ISDE)=I
16645         ISIG(NCHN,3-ISDE)=21
16646         ISIG(NCHN,3)=1
16647         SIGH(NCHN)=FACWQ*VINT(180+I)*WIDS(24,(5-KCHW)/2)
16648   480   CONTINUE
16649   490   CONTINUE
16650
16651       ELSEIF(ISUB.EQ.32) THEN
16652 C...f + g -> f + H0 (q + g -> q + H0 only).
16653
16654       ELSEIF(ISUB.EQ.33) THEN
16655 C...f + gamma -> f + g (q + gamma -> q + g only).
16656
16657       ELSEIF(ISUB.EQ.34) THEN
16658 C...f + gamma -> f + gamma.
16659
16660       ELSEIF(ISUB.EQ.35) THEN
16661 C...f + gamma -> f + Z0.
16662
16663       ELSEIF(ISUB.EQ.36) THEN
16664 C...f + gamma -> f' + W+/-.
16665
16666       ELSEIF(ISUB.EQ.37) THEN
16667 C...f + gamma -> f + H0.
16668
16669       ELSEIF(ISUB.EQ.38) THEN
16670 C...f + Z0 -> f + g (q + Z0 -> q + g only).
16671
16672       ELSEIF(ISUB.EQ.39) THEN
16673 C...f + Z0 -> f + gamma.
16674
16675       ELSEIF(ISUB.EQ.40) THEN
16676 C...f + Z0 -> f + Z0.
16677       ENDIF
16678
16679       ELSEIF(ISUB.LE.50) THEN
16680       IF(ISUB.EQ.41) THEN
16681 C...f + Z0 -> f' + W+/-.
16682
16683       ELSEIF(ISUB.EQ.42) THEN
16684 C...f + Z0 -> f + H0.
16685
16686       ELSEIF(ISUB.EQ.43) THEN
16687 C...f + W+/- -> f' + g (q + W+/- -> q' + g only).
16688
16689       ELSEIF(ISUB.EQ.44) THEN
16690 C...f + W+/- -> f' + gamma.
16691
16692       ELSEIF(ISUB.EQ.45) THEN
16693 C...f + W+/- -> f' + Z0.
16694
16695       ELSEIF(ISUB.EQ.46) THEN
16696 C...f + W+/- -> f' + W+/-.
16697
16698       ELSEIF(ISUB.EQ.47) THEN
16699 C...f + W+/- -> f' + H0.
16700
16701       ELSEIF(ISUB.EQ.48) THEN
16702 C...f + H0 -> f + g (q + H0 -> q + g only).
16703
16704       ELSEIF(ISUB.EQ.49) THEN
16705 C...f + H0 -> f + gamma.
16706
16707       ELSEIF(ISUB.EQ.50) THEN
16708 C...f + H0 -> f + Z0.
16709       ENDIF
16710
16711       ELSEIF(ISUB.LE.60) THEN
16712       IF(ISUB.EQ.51) THEN
16713 C...f + H0 -> f' + W+/-.
16714
16715       ELSEIF(ISUB.EQ.52) THEN
16716 C...f + H0 -> f + H0.
16717
16718       ELSEIF(ISUB.EQ.53) THEN
16719 C...g + g -> f + fb (g + g -> q + qb only).
16720         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)
16721         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
16722      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
16723         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
16724      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
16725         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
16726         NCHN=NCHN+1
16727         ISIG(NCHN,1)=21
16728         ISIG(NCHN,2)=21
16729         ISIG(NCHN,3)=1
16730         SIGH(NCHN)=FACQQ1
16731         NCHN=NCHN+1
16732         ISIG(NCHN,1)=21
16733         ISIG(NCHN,2)=21
16734         ISIG(NCHN,3)=2
16735         SIGH(NCHN)=FACQQ2
16736   500   CONTINUE
16737
16738       ELSEIF(ISUB.EQ.54) THEN
16739 C...g + gamma -> f + fb (g + gamma -> q + qb only).
16740
16741       ELSEIF(ISUB.EQ.55) THEN
16742 C...g + gamma -> f + fb (g + gamma -> q + qb only).
16743
16744       ELSEIF(ISUB.EQ.56) THEN
16745 C...g + gamma -> f + fb (g + gamma -> q + qb only).
16746
16747       ELSEIF(ISUB.EQ.57) THEN
16748 C...g + gamma -> f + fb (g + gamma -> q + qb only).
16749
16750       ELSEIF(ISUB.EQ.58) THEN
16751 C...gamma + gamma -> f + fb.
16752
16753       ELSEIF(ISUB.EQ.59) THEN
16754 C...gamma + Z0 -> f + fb.
16755
16756       ELSEIF(ISUB.EQ.60) THEN
16757 C...gamma + W+/- -> f + fb'.
16758       ENDIF
16759
16760       ELSEIF(ISUB.LE.70) THEN
16761       IF(ISUB.EQ.61) THEN
16762 C...gamma + H0 -> f + fb.
16763
16764       ELSEIF(ISUB.EQ.62) THEN
16765 C...Z0 + Z0 -> f + fb.
16766
16767       ELSEIF(ISUB.EQ.63) THEN
16768 C...Z0 + W+/- -> f + fb'.
16769
16770       ELSEIF(ISUB.EQ.64) THEN
16771 C...Z0 + H0 -> f + fb.
16772
16773       ELSEIF(ISUB.EQ.65) THEN
16774 C...W+ + W- -> f + fb.
16775
16776       ELSEIF(ISUB.EQ.66) THEN
16777 C...W+/- + H0 -> f + fb'.
16778
16779       ELSEIF(ISUB.EQ.67) THEN
16780 C...H0 + H0 -> f + fb.
16781
16782       ELSEIF(ISUB.EQ.68) THEN
16783 C...g + g -> g + g.
16784         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
16785      &  TH2/SH2)*FACA
16786         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
16787      &  SH2/UH2)*FACA
16788         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
16789         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
16790         NCHN=NCHN+1
16791         ISIG(NCHN,1)=21
16792         ISIG(NCHN,2)=21
16793         ISIG(NCHN,3)=1
16794         SIGH(NCHN)=0.5*FACGG1
16795         NCHN=NCHN+1
16796         ISIG(NCHN,1)=21
16797         ISIG(NCHN,2)=21
16798         ISIG(NCHN,3)=2
16799         SIGH(NCHN)=0.5*FACGG2
16800         NCHN=NCHN+1
16801         ISIG(NCHN,1)=21
16802         ISIG(NCHN,2)=21
16803         ISIG(NCHN,3)=3
16804         SIGH(NCHN)=0.5*FACGG3
16805   510   CONTINUE
16806
16807       ELSEIF(ISUB.EQ.69) THEN
16808 C...gamma + gamma -> W+ + W-.
16809
16810       ELSEIF(ISUB.EQ.70) THEN
16811 C...gamma + W+/- -> gamma + W+/-.
16812       ENDIF
16813
16814       ELSEIF(ISUB.LE.80) THEN
16815       IF(ISUB.EQ.71) THEN
16816 C...Z0 + Z0 -> Z0 + Z0.
16817         BE2=1.-4.*SQMZ/SH
16818         TH=-0.5*SH*BE2*(1.-CTH)
16819         UH=-0.5*SH*BE2*(1.+CTH)
16820         SHANG=1./(1.-XW)*SQMW/SQMZ*(1.+BE2)**2
16821         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
16822         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
16823         THANG=1./(1.-XW)*SQMW/SQMZ*(BE2-CTH)**2
16824         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
16825         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
16826         UHANG=1./(1.-XW)*SQMW/SQMZ*(BE2+CTH)**2
16827         AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
16828         AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
16829         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*
16830      &  (AEM/XW)**4*(SH/SQMW)**2*((ASHRE+ATHRE+AUHRE)**2+
16831      &  (ASHIM+ATHIM+AUHIM)**2)*SQMZ/SQMW
16832         DO 530 I=MIN1,MAX1
16833         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
16834         EI=KCHG(IABS(I),1)/3.
16835         AI=SIGN(1.,EI)
16836         VI=AI-4.*EI*XW
16837         AVI=AI**2+VI**2
16838         DO 520 J=MIN2,MAX2
16839         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
16840         EJ=KCHG(IABS(J),1)/3.
16841         AJ=SIGN(1.,EJ)
16842         VJ=AJ-4.*EJ*XW
16843         AVJ=AJ**2+VJ**2
16844         NCHN=NCHN+1
16845         ISIG(NCHN,1)=I
16846         ISIG(NCHN,2)=J
16847         ISIG(NCHN,3)=1
16848         SIGH(NCHN)=FACH*AVI*AVJ
16849   520   CONTINUE
16850   530   CONTINUE
16851
16852       ELSEIF(ISUB.EQ.72) THEN
16853 C...Z0 + Z0 -> W+ + W-.
16854         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
16855         CTH2=CTH**2
16856         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
16857         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
16858         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
16859      &  (1.-2.*SQMZ/SH)
16860         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
16861         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
16862         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
16863      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
16864      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
16865      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
16866         ATWIM=0.
16867         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
16868      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
16869      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
16870      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
16871         AUWIM=0.
16872         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
16873         A4IM=0.
16874         FACH=COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*(AEM/XW)**4*
16875      &  (SH/SQMW)**2*((ASHRE+ATWRE+AUWRE+A4RE)**2+
16876      &  (ASHIM+ATWIM+AUWIM+A4IM)**2)*SQMZ/SQMW
16877         DO 550 I=MIN1,MAX1
16878         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 550
16879         EI=KCHG(IABS(I),1)/3.
16880         AI=SIGN(1.,EI)
16881         VI=AI-4.*EI*XW
16882         AVI=AI**2+VI**2
16883         DO 540 J=MIN2,MAX2
16884         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 540
16885         EJ=KCHG(IABS(J),1)/3.
16886         AJ=SIGN(1.,EJ)
16887         VJ=AJ-4.*EJ*XW
16888         AVJ=AJ**2+VJ**2
16889         NCHN=NCHN+1
16890         ISIG(NCHN,1)=I
16891         ISIG(NCHN,2)=J
16892         ISIG(NCHN,3)=1
16893         SIGH(NCHN)=FACH*AVI*AVJ
16894   540   CONTINUE
16895   550   CONTINUE
16896
16897       ELSEIF(ISUB.EQ.73) THEN
16898 C...Z0 + W+/- -> Z0 + W+/-.
16899         BE2=1.-2.*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
16900         EP1=1.+(SQMZ-SQMW)/SH
16901         EP2=1.-(SQMZ-SQMW)/SH
16902         TH=-0.5*SH*BE2*(1.-CTH)
16903         UH=(SQMZ-SQMW)**2/SH-0.5*SH*BE2*(1.+CTH)
16904         THANG=SQRT(SQMW/(SQMZ*(1.-XW)))*(BE2-EP1*CTH)*(BE2-EP2*CTH)
16905         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
16906         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
16907         ASWRE=(1.-XW)/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
16908      &  1./4.*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4.*BE2*CTH)+
16909      &  2.*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
16910      &  1./16.*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
16911         ASWIM=0.
16912         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
16913      &  (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
16914      &  (BE2+EP1*EP2*CTH)*(2.*EP2-EP2*CTH+EP1)-BE2*(EP2+EP1*CTH)**2*
16915      &  (BE2-EP2**2*CTH)-1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+
16916      &  2.*BE2*(1.-CTH))+1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
16917      &  (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
16918      &  (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
16919      &  (2.*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*(BE2-EP1**2*CTH)-
16920      &  1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2.*BE2*(1.-CTH))+
16921      &  1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
16922         AUWIM=0.
16923         A4RE=(1.-XW)/SQMZ*(EP1**2*EP2**2*(CTH**2-1.)-
16924      &  2.*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2.*BE2*EP1*EP2)
16925         A4IM=0.
16926         FACH=COMFAC*1./(4096.*PARU(1)**2*4.*(1.-XW))*(AEM/XW)**4*
16927      &  (SH/SQMW)**2*((ATHRE+ASWRE+AUWRE+A4RE)**2+
16928      &  (ATHIM+ASWIM+AUWIM+A4IM)**2)*SQRT(SQMZ/SQMW)
16929         DO 570 I=MIN1,MAX1
16930         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 570
16931         EI=KCHG(IABS(I),1)/3.
16932         AI=SIGN(1.,EI)
16933         VI=AI-4.*EI*XW
16934         AVI=AI**2+VI**2
16935         DO 560 J=MIN2,MAX2
16936         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 560
16937         EJ=KCHG(IABS(J),1)/3.
16938         AJ=SIGN(1.,EJ)
16939         VJ=AI-4.*EJ*XW
16940         AVJ=AJ**2+VJ**2
16941         NCHN=NCHN+1
16942         ISIG(NCHN,1)=I
16943         ISIG(NCHN,2)=J
16944         ISIG(NCHN,3)=1
16945         SIGH(NCHN)=FACH*(AVI*VINT(180+J)+VINT(180+I)*AVJ)
16946   560   CONTINUE
16947   570   CONTINUE
16948
16949       ELSEIF(ISUB.EQ.75) THEN
16950 C...W+ + W- -> gamma + gamma.
16951
16952       ELSEIF(ISUB.EQ.76) THEN
16953 C...W+ + W- -> Z0 + Z0.
16954         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
16955         CTH2=CTH**2
16956         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
16957         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
16958         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
16959      &  (1.-2.*SQMZ/SH)
16960         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
16961         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
16962         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
16963      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
16964      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
16965      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
16966         ATWIM=0.
16967         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
16968      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
16969      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
16970      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
16971         AUWIM=0.
16972         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
16973         A4IM=0.
16974         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
16975      &  ((ASHRE+ATWRE+AUWRE+A4RE)**2+(ASHIM+ATWIM+AUWIM+A4IM)**2)
16976         DO 590 I=MIN1,MAX1
16977         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 590
16978         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
16979         DO 580 J=MIN2,MAX2
16980         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 580
16981         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
16982         IF(EI*EJ.GT.0.) GOTO 580
16983         NCHN=NCHN+1
16984         ISIG(NCHN,1)=I
16985         ISIG(NCHN,2)=J
16986         ISIG(NCHN,3)=1
16987         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
16988   580   CONTINUE
16989   590   CONTINUE
16990
16991       ELSEIF(ISUB.EQ.77) THEN
16992 C...W+/- + W+/- -> W+/- + W+/-.
16993         BE2=1.-4.*SQMW/SH
16994         BE4=BE2**2
16995         CTH2=CTH**2
16996         CTH3=CTH**3
16997         TH=-0.5*SH*BE2*(1.-CTH)
16998         UH=-0.5*SH*BE2*(1.+CTH)
16999         SHANG=(1.+BE2)**2
17000         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17001         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17002         THANG=(BE2-CTH)**2
17003         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17004         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17005         SGZANG=1./SQMW*BE2*(3.-BE2)**2*CTH
17006         ASGRE=XW*SGZANG
17007         ASGIM=0.
17008         ASZRE=(1.-XW)*SH/(SH-SQMZ)*SGZANG
17009         ASZIM=0.
17010         TGZANG=1./SQMW*(BE2*(4.-2.*BE2+BE4)+BE2*(4.-10.*BE2+BE4)*CTH+
17011      &  (2.-11.*BE2+10.*BE4)*CTH2+BE2*CTH3)
17012         ATGRE=0.5*XW*SH/TH*TGZANG
17013         ATGIM=0.
17014         ATZRE=0.5*(1.-XW)*SH/(TH-SQMZ)*TGZANG
17015         ATZIM=0.
17016         A4RE=1./SQMW*(1.+2.*BE2-6.*BE2*CTH-CTH2)
17017         A4IM=0.
17018         FACH=COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
17019      &  ((ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4RE)**2+
17020      &  (ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4IM)**2)
17021         DO 610 I=MIN1,MAX1
17022         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 610
17023         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
17024         DO 600 J=MIN2,MAX2
17025         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 600
17026         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
17027         IF(EI*EJ.GT.0.) GOTO 600
17028         NCHN=NCHN+1
17029         ISIG(NCHN,1)=I
17030         ISIG(NCHN,2)=J
17031         ISIG(NCHN,3)=1
17032         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
17033   600   CONTINUE
17034   610   CONTINUE
17035
17036       ELSEIF(ISUB.EQ.78) THEN
17037 C...W+/- + H0 -> W+/- + H0.
17038
17039       ELSEIF(ISUB.EQ.79) THEN
17040 C...H0 + H0 -> H0 + H0.
17041
17042       ENDIF
17043
17044 C...C: 2 -> 2, tree diagrams with masses.
17045
17046       ELSEIF(ISUB.LE.90) THEN
17047       IF(ISUB.EQ.81) THEN
17048 C...q + qb -> Q + QB.
17049         FACQQB=COMFAC*AS**2*4./9.*(((TH-SQM3)**2+
17050      &  (UH-SQM3)**2)/SH2+2.*SQM3/SH)
17051         IF(MSTP(35).GE.1) THEN
17052           IF(MSTP(35).EQ.1) THEN
17053             ALSSG=PARP(35)
17054           ELSE
17055             MST115=MSTU(115)
17056             MSTU(115)=MSTP(36)
17057             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
17058             ALSSG=ULALPS(Q2BN)
17059             MSTU(115)=MST115
17060           ENDIF
17061           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
17062           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
17063           PARI(81)=FREPU
17064           FACQQB=FACQQB*FREPU
17065         ENDIF
17066         DO 620 I=MINA,MAXA
17067         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 620
17068         NCHN=NCHN+1
17069         ISIG(NCHN,1)=I
17070         ISIG(NCHN,2)=-I
17071         ISIG(NCHN,3)=1
17072         SIGH(NCHN)=FACQQB
17073   620   CONTINUE
17074
17075       ELSEIF(ISUB.EQ.82) THEN
17076 C...g + g -> Q + QB.
17077         FACQQ1=COMFAC*FACA*AS**2*1./6.*((UH-SQM3)/(TH-SQM3)-
17078      &  2.*(UH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(TH-SQM3)**2)
17079         FACQQ2=COMFAC*FACA*AS**2*1./6.*((TH-SQM3)/(UH-SQM3)-
17080      &  2.*(TH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(UH-SQM3)**2)
17081         IF(MSTP(35).GE.1) THEN
17082           IF(MSTP(35).EQ.1) THEN
17083             ALSSG=PARP(35)
17084           ELSE
17085             MST115=MSTU(115)
17086             MSTU(115)=MSTP(36)
17087             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
17088             ALSSG=ULALPS(Q2BN)
17089             MSTU(115)=MST115
17090           ENDIF
17091           XATTR=4.*PARU(1)*ALSSG/(3.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
17092           FATTR=XATTR/(1.-EXP(-MIN(100.,XATTR)))
17093           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
17094           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
17095           FATRE=(2.*FATTR+5.*FREPU)/7.
17096           PARI(81)=FATRE
17097           FACQQ1=FACQQ1*FATRE
17098           FACQQ2=FACQQ2*FATRE
17099         ENDIF
17100         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 630
17101         NCHN=NCHN+1
17102         ISIG(NCHN,1)=21
17103         ISIG(NCHN,2)=21
17104         ISIG(NCHN,3)=1
17105         SIGH(NCHN)=FACQQ1
17106         NCHN=NCHN+1
17107         ISIG(NCHN,1)=21
17108         ISIG(NCHN,2)=21
17109         ISIG(NCHN,3)=2
17110         SIGH(NCHN)=FACQQ2
17111   630   CONTINUE
17112
17113       ENDIF
17114
17115 C...D: Mimimum bias processes.
17116
17117       ELSEIF(ISUB.LE.100) THEN
17118       IF(ISUB.EQ.91) THEN
17119 C...Elastic scattering.
17120         SIGS=XSEC(ISUB,1)
17121
17122       ELSEIF(ISUB.EQ.92) THEN
17123 C...Single diffractive scattering.
17124         SIGS=XSEC(ISUB,1)
17125
17126       ELSEIF(ISUB.EQ.93) THEN
17127 C...Double diffractive scattering.
17128         SIGS=XSEC(ISUB,1)
17129
17130       ELSEIF(ISUB.EQ.94) THEN
17131 C...Central diffractive scattering.
17132         SIGS=XSEC(ISUB,1)
17133
17134       ELSEIF(ISUB.EQ.95) THEN
17135 C...Low-pT scattering.
17136         SIGS=XSEC(ISUB,1)
17137
17138       ELSEIF(ISUB.EQ.96) THEN
17139 C...Multiple interactions: sum of QCD processes.
17140         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)
17141
17142 C...q + q' -> q + q'.
17143         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
17144         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
17145      &  MSTP(34)*2./3.*UH2/(SH*TH))
17146         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
17147      &  MSTP(34)*2./3.*SH2/(TH*UH))
17148         DO 650 I=-3,3
17149         IF(I.EQ.0) GOTO 650
17150         DO 640 J=-3,3
17151         IF(J.EQ.0) GOTO 640
17152         NCHN=NCHN+1
17153         ISIG(NCHN,1)=I
17154         ISIG(NCHN,2)=J
17155         ISIG(NCHN,3)=111
17156         SIGH(NCHN)=FACQQ1
17157         IF(I.EQ.-J) SIGH(NCHN)=FACQQB
17158         IF(I.EQ.J) THEN
17159           SIGH(NCHN)=0.5*SIGH(NCHN)
17160           NCHN=NCHN+1
17161           ISIG(NCHN,1)=I
17162           ISIG(NCHN,2)=J
17163           ISIG(NCHN,3)=112
17164           SIGH(NCHN)=0.5*FACQQ2
17165         ENDIF
17166   640   CONTINUE
17167   650   CONTINUE
17168
17169 C...q + qb -> q' + qb' or g + g.
17170         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
17171      &  WDTE(0,3)+WDTE(0,4))
17172         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
17173         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
17174         DO 660 I=-3,3
17175         IF(I.EQ.0) GOTO 660
17176         NCHN=NCHN+1
17177         ISIG(NCHN,1)=I
17178         ISIG(NCHN,2)=-I
17179         ISIG(NCHN,3)=121
17180         SIGH(NCHN)=FACQQB
17181         NCHN=NCHN+1
17182         ISIG(NCHN,1)=I
17183         ISIG(NCHN,2)=-I
17184         ISIG(NCHN,3)=131
17185         SIGH(NCHN)=0.5*FACGG1
17186         NCHN=NCHN+1
17187         ISIG(NCHN,1)=I
17188         ISIG(NCHN,2)=-I
17189         ISIG(NCHN,3)=132
17190         SIGH(NCHN)=0.5*FACGG2
17191   660   CONTINUE
17192
17193 C...q + g -> q + g.
17194         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
17195      &  FACA
17196         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
17197         DO 680 I=-3,3
17198         IF(I.EQ.0) GOTO 680
17199         DO 670 ISDE=1,2
17200         NCHN=NCHN+1
17201         ISIG(NCHN,ISDE)=I
17202         ISIG(NCHN,3-ISDE)=21
17203         ISIG(NCHN,3)=281
17204         SIGH(NCHN)=FACQG1
17205         NCHN=NCHN+1
17206         ISIG(NCHN,ISDE)=I
17207         ISIG(NCHN,3-ISDE)=21
17208         ISIG(NCHN,3)=282
17209         SIGH(NCHN)=FACQG2
17210   670   CONTINUE
17211   680   CONTINUE
17212
17213 C...g + g -> q + qb or g + g.
17214         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
17215      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17216         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
17217      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17218         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
17219      &  TH2/SH2)*FACA
17220         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
17221      &  SH2/UH2)*FACA
17222         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
17223         NCHN=NCHN+1
17224         ISIG(NCHN,1)=21
17225         ISIG(NCHN,2)=21
17226         ISIG(NCHN,3)=531
17227         SIGH(NCHN)=FACQQ1
17228         NCHN=NCHN+1
17229         ISIG(NCHN,1)=21
17230         ISIG(NCHN,2)=21
17231         ISIG(NCHN,3)=532
17232         SIGH(NCHN)=FACQQ2
17233         NCHN=NCHN+1
17234         ISIG(NCHN,1)=21
17235         ISIG(NCHN,2)=21
17236         ISIG(NCHN,3)=681
17237         SIGH(NCHN)=0.5*FACGG1
17238         NCHN=NCHN+1
17239         ISIG(NCHN,1)=21
17240         ISIG(NCHN,2)=21
17241         ISIG(NCHN,3)=682
17242         SIGH(NCHN)=0.5*FACGG2
17243         NCHN=NCHN+1
17244         ISIG(NCHN,1)=21
17245         ISIG(NCHN,2)=21
17246         ISIG(NCHN,3)=683
17247         SIGH(NCHN)=0.5*FACGG3
17248       ENDIF
17249
17250 C...E: 2 -> 1, loop diagrams.
17251
17252       ELSEIF(ISUB.LE.110) THEN
17253       IF(ISUB.EQ.101) THEN
17254 C...g + g -> gamma*/Z0.
17255
17256       ELSEIF(ISUB.EQ.102) THEN
17257 C...g + g -> H0.
17258         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)
17259         ETARE=0.
17260         ETAIM=0.
17261         DO 690 I=1,2*MSTP(1)
17262         EPS=4.*PMAS(I,1)**2/SH
17263         IF(EPS.LE.1.) THEN
17264           IF(EPS.GT.1.E-4) THEN
17265             ROOT=SQRT(1.-EPS)
17266             RLN=LOG((1.+ROOT)/(1.-ROOT))
17267           ELSE
17268             RLN=LOG(4./EPS-2.)
17269           ENDIF
17270           PHIRE=0.25*(RLN**2-PARU(1)**2)
17271           PHIIM=0.5*PARU(1)*RLN
17272         ELSE
17273           PHIRE=-(ASIN(1./SQRT(EPS)))**2
17274           PHIIM=0.
17275         ENDIF
17276         ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
17277         ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
17278   690   CONTINUE
17279         ETA2=ETARE**2+ETAIM**2
17280         FACH=COMFAC*FACA*(AS/PARU(1)*AEM/XW)**2*1./512.*
17281      &  (SH/SQMW)**2*ETA2*SH2/((SH-SQMH)**2+GMMH**2)*
17282      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
17283         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 700
17284         NCHN=NCHN+1
17285         ISIG(NCHN,1)=21
17286         ISIG(NCHN,2)=21
17287         ISIG(NCHN,3)=1
17288         SIGH(NCHN)=FACH
17289   700   CONTINUE
17290
17291       ENDIF
17292
17293 C...F: 2 -> 2, box diagrams.
17294
17295       ELSEIF(ISUB.LE.120) THEN
17296       IF(ISUB.EQ.111) THEN
17297 C...f + fb -> g + H0 (q + qb -> g + H0 only).
17298         A5STUR=0.
17299         A5STUI=0.
17300         DO 710 I=1,2*MSTP(1)
17301         SQMQ=PMAS(I,1)**2
17302         EPSS=4.*SQMQ/SH
17303         EPSH=4.*SQMQ/SQMH
17304         A5STUR=A5STUR+SQMQ/SQMH*(4.+4.*SH/(TH+UH)*(PYW1AU(EPSS,1)-
17305      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,1)-
17306      &  PYW2AU(EPSH,1)))
17307         A5STUI=A5STUI+SQMQ/SQMH*(4.*SH/(TH+UH)*(PYW1AU(EPSS,2)-
17308      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,2)-
17309      &  PYW2AU(EPSH,2)))
17310   710   CONTINUE
17311         FACGH=COMFAC*FACA/(144.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
17312      &  SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
17313         FACGH=FACGH*WIDS(25,2)
17314         DO 720 I=MINA,MAXA
17315         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 720
17316         NCHN=NCHN+1
17317         ISIG(NCHN,1)=I
17318         ISIG(NCHN,2)=-I
17319         ISIG(NCHN,3)=1
17320         SIGH(NCHN)=FACGH
17321   720   CONTINUE
17322
17323       ELSEIF(ISUB.EQ.112) THEN
17324 C...f + g -> f + H0 (q + g -> q + H0 only).
17325         A5TSUR=0.
17326         A5TSUI=0.
17327         DO 730 I=1,2*MSTP(1)
17328         SQMQ=PMAS(I,1)**2
17329         EPST=4.*SQMQ/TH
17330         EPSH=4.*SQMQ/SQMH
17331         A5TSUR=A5TSUR+SQMQ/SQMH*(4.+4.*TH/(SH+UH)*(PYW1AU(EPST,1)-
17332      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,1)-
17333      &  PYW2AU(EPSH,1)))
17334         A5TSUI=A5TSUI+SQMQ/SQMH*(4.*TH/(SH+UH)*(PYW1AU(EPST,2)-
17335      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,2)-
17336      &  PYW2AU(EPSH,2)))
17337   730   CONTINUE
17338         FACQH=COMFAC*FACA/(384.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
17339      &  SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
17340         FACQH=FACQH*WIDS(25,2)
17341         DO 750 I=MINA,MAXA
17342         IF(I.EQ.0) GOTO 750
17343         DO 740 ISDE=1,2
17344         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 740
17345         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 740
17346         NCHN=NCHN+1
17347         ISIG(NCHN,ISDE)=I
17348         ISIG(NCHN,3-ISDE)=21
17349         ISIG(NCHN,3)=1
17350         SIGH(NCHN)=FACQH
17351   740   CONTINUE
17352   750   CONTINUE
17353
17354       ELSEIF(ISUB.EQ.113) THEN
17355 C...g + g -> g + H0.
17356         A2STUR=0.
17357         A2STUI=0.
17358         A2USTR=0.
17359         A2USTI=0.
17360         A2TUSR=0.
17361         A2TUSI=0.
17362         A4STUR=0.
17363         A4STUI=0.
17364         DO 760 I=6,2*MSTP(1)
17365 C'''Only t-quarks yet included
17366         SQMQ=PMAS(I,1)**2
17367         EPSS=4.*SQMQ/SH
17368         EPST=4.*SQMQ/TH
17369         EPSU=4.*SQMQ/UH
17370         EPSH=4.*SQMQ/SQMH
17371         IF(EPSH.LT.1.E-6) GOTO 760
17372         BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
17373         BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
17374         BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
17375         BEUTS=BESTU
17376         BETSU=BEUST
17377         BESUT=BETUS
17378         W3STUR=PYI3AU(BESTU,EPSH,1)-PYI3AU(BESTU,EPSS,1)-
17379      &  PYI3AU(BESTU,EPSU,1)
17380         W3STUI=PYI3AU(BESTU,EPSH,2)-PYI3AU(BESTU,EPSS,2)-
17381      &  PYI3AU(BESTU,EPSU,2)
17382         W3SUTR=PYI3AU(BESUT,EPSH,1)-PYI3AU(BESUT,EPSS,1)-
17383      &  PYI3AU(BESUT,EPST,1)
17384         W3SUTI=PYI3AU(BESUT,EPSH,2)-PYI3AU(BESUT,EPSS,2)-
17385      &  PYI3AU(BESUT,EPST,2)
17386         W3TSUR=PYI3AU(BETSU,EPSH,1)-PYI3AU(BETSU,EPST,1)-
17387      &  PYI3AU(BETSU,EPSU,1)
17388         W3TSUI=PYI3AU(BETSU,EPSH,2)-PYI3AU(BETSU,EPST,2)-
17389      &  PYI3AU(BETSU,EPSU,2)
17390         W3TUSR=PYI3AU(BETUS,EPSH,1)-PYI3AU(BETUS,EPST,1)-
17391      &  PYI3AU(BETUS,EPSS,1)
17392         W3TUSI=PYI3AU(BETUS,EPSH,2)-PYI3AU(BETUS,EPST,2)-
17393      &  PYI3AU(BETUS,EPSS,2)
17394         W3USTR=PYI3AU(BEUST,EPSH,1)-PYI3AU(BEUST,EPSU,1)-
17395      &  PYI3AU(BEUST,EPST,1)
17396         W3USTI=PYI3AU(BEUST,EPSH,2)-PYI3AU(BEUST,EPSU,2)-
17397      &  PYI3AU(BEUST,EPST,2)
17398         W3UTSR=PYI3AU(BEUTS,EPSH,1)-PYI3AU(BEUTS,EPSU,1)-
17399      &  PYI3AU(BEUTS,EPSS,1)
17400         W3UTSI=PYI3AU(BEUTS,EPSH,2)-PYI3AU(BEUTS,EPSU,2)-
17401      &  PYI3AU(BEUTS,EPSS,2)
17402         B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2.*TH*UH*(UH+2.*SH)/
17403      &  (SH+UH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
17404      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3STUR)+
17405      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,1)-
17406      &  PYW2AU(EPSH,1))+0.5*TH*UH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
17407      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUR)
17408         B2STUI=SQMQ/SQMH**2*(2.*TH*UH*(UH+2.*SH)/(SH+UH)**2*
17409      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
17410      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3STUI)+
17411      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,2)-
17412      &  PYW2AU(EPSH,2))+0.5*TH*UH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
17413      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUI)
17414         B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2.*UH*TH*(TH+2.*SH)/
17415      &  (SH+TH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
17416      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3SUTR)+
17417      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,1)-
17418      &  PYW2AU(EPSH,1))+0.5*UH*TH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
17419      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTR)
17420         B2SUTI=SQMQ/SQMH**2*(2.*UH*TH*(TH+2.*SH)/(SH+TH)**2*
17421      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
17422      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3SUTI)+
17423      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,2)-
17424      &  PYW2AU(EPSH,2))+0.5*UH*TH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
17425      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTI)
17426         B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2.*SH*UH*(UH+2.*TH)/
17427      &  (TH+UH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
17428      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3TSUR)+
17429      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,1)-
17430      &  PYW2AU(EPSH,1))+0.5*SH*UH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
17431      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUR)
17432         B2TSUI=SQMQ/SQMH**2*(2.*SH*UH*(UH+2.*TH)/(TH+UH)**2*
17433      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
17434      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3TSUI)+
17435      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,2)-
17436      &  PYW2AU(EPSH,2))+0.5*SH*UH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
17437      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUI)
17438         B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2.*UH*SH*(SH+2.*TH)/
17439      &  (TH+SH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
17440      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3TUSR)+
17441      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,1)-
17442      &  PYW2AU(EPSH,1))+0.5*UH*SH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
17443      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSR)
17444         B2TUSI=SQMQ/SQMH**2*(2.*UH*SH*(SH+2.*TH)/(TH+SH)**2*
17445      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
17446      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3TUSI)+
17447      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,2)-
17448      &  PYW2AU(EPSH,2))+0.5*UH*SH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
17449      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSI)
17450         B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2.*SH*TH*(TH+2.*UH)/
17451      &  (UH+TH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
17452      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3USTR)+
17453      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,1)-
17454      &  PYW2AU(EPSH,1))+0.5*SH*TH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
17455      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTR)
17456         B2USTI=SQMQ/SQMH**2*(2.*SH*TH*(TH+2.*UH)/(UH+TH)**2*
17457      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
17458      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3USTI)+
17459      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,2)-
17460      &  PYW2AU(EPSH,2))+0.5*SH*TH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
17461      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTI)
17462         B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2.*TH*SH*(SH+2.*UH)/
17463      &  (UH+SH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
17464      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3UTSR)+
17465      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,1)-
17466      &  PYW2AU(EPSH,1))+0.5*TH*SH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
17467      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSR)
17468         B2UTSI=SQMQ/SQMH**2*(2.*TH*SH*(SH+2.*UH)/(UH+SH)**2*
17469      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
17470      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3UTSI)+
17471      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,2)-
17472      &  PYW2AU(EPSH,2))+0.5*TH*SH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
17473      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSI)
17474         B4STUR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,1)-
17475      &  PYW2AU(EPSH,1)+W3STUR))
17476         B4STUI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,2)-
17477      &  PYW2AU(EPSH,2)+W3STUI)
17478         B4TUSR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,1)-
17479      &  PYW2AU(EPSH,1)+W3TUSR))
17480         B4TUSI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,2)-
17481      &  PYW2AU(EPSH,2)+W3TUSI)
17482         B4USTR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,1)-
17483      &  PYW2AU(EPSH,1)+W3USTR))
17484         B4USTI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,2)-
17485      &  PYW2AU(EPSH,2)+W3USTI)
17486         A2STUR=A2STUR+B2STUR+B2SUTR
17487         A2STUI=A2STUI+B2STUI+B2SUTI
17488         A2USTR=A2USTR+B2USTR+B2UTSR
17489         A2USTI=A2USTI+B2USTI+B2UTSI
17490         A2TUSR=A2TUSR+B2TUSR+B2TSUR
17491         A2TUSI=A2TUSI+B2TUSI+B2TSUI
17492         A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
17493         A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
17494   760   CONTINUE
17495         FACGH=COMFAC*FACA*3./(128.*PARU(1)**2)*AEM/XW*AS**3*
17496      &  SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
17497      &  A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
17498         FACGH=FACGH*WIDS(25,2)
17499         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 770
17500         NCHN=NCHN+1
17501         ISIG(NCHN,1)=21
17502         ISIG(NCHN,2)=21
17503         ISIG(NCHN,3)=1
17504         SIGH(NCHN)=FACGH
17505   770   CONTINUE
17506
17507       ELSEIF(ISUB.EQ.114) THEN
17508 C...g + g -> gamma + gamma.
17509         ASRE=0.
17510         ASIM=0.
17511         DO 780 I=1,2*MSTP(1)
17512         EI=KCHG(IABS(I),1)/3.
17513         SQMQ=PMAS(I,1)**2
17514         EPSS=4.*SQMQ/SH
17515         EPST=4.*SQMQ/TH
17516         EPSU=4.*SQMQ/UH
17517         IF(EPSS+ABS(EPST)+ABS(EPSU).LT.3.E-6) THEN
17518           A0STUR=1.+(TH-UH)/SH*LOG(TH/UH)+0.5*(TH2+UH2)/SH2*
17519      &    (LOG(TH/UH)**2+PARU(1)**2)
17520           A0STUI=0.
17521           A0TSUR=1.+(SH-UH)/TH*LOG(-SH/UH)+0.5*(SH2+UH2)/TH2*
17522      &    LOG(-SH/UH)**2
17523           A0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*LOG(-SH/UH))
17524           A0UTSR=1.+(TH-SH)/UH*LOG(-TH/SH)+0.5*(TH2+SH2)/UH2*
17525      &    LOG(-TH/SH)**2
17526           A0UTSI=PARU(1)*((TH-SH)/UH+(TH2+SH2)/UH2*LOG(-TH/SH))
17527           A1STUR=-1.
17528           A1STUI=0.
17529           A2STUR=-1.
17530           A2STUI=0.
17531         ELSE
17532           BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
17533           BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
17534           BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
17535           BEUTS=BESTU
17536           BETSU=BEUST
17537           BESUT=BETUS
17538           A0STUR=1.+(1.+2.*TH/SH)*PYW1AU(EPST,1)+(1.+2.*UH/SH)*
17539      &    PYW1AU(EPSU,1)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,1)+
17540      &    PYW2AU(EPSU,1))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,1)+
17541      &    PYI3AU(BESUT,EPST,1))-0.25*EPSU*(1.-0.5*EPSS)*
17542      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))+
17543      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
17544      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))
17545           A0STUI=(1.+2.*TH/SH)*PYW1AU(EPST,2)+(1.+2.*UH/SH)*
17546      &    PYW1AU(EPSU,2)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,2)+
17547      &    PYW2AU(EPSU,2))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,2)+
17548      &    PYI3AU(BESUT,EPST,2))-0.25*EPSU*(1.-0.5*EPSS)*
17549      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))+
17550      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
17551      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))
17552           A0TSUR=1.+(1.+2.*SH/TH)*PYW1AU(EPSS,1)+(1.+2.*UH/TH)*
17553      &    PYW1AU(EPSU,1)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,1)+
17554      &    PYW2AU(EPSU,1))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,1)+
17555      &    PYI3AU(BETUS,EPSS,1))-0.25*EPSU*(1.-0.5*EPST)*
17556      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))+
17557      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
17558      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))
17559           A0TSUI=(1.+2.*SH/TH)*PYW1AU(EPSS,2)+(1.+2.*UH/TH)*
17560      &    PYW1AU(EPSU,2)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,2)+
17561      &    PYW2AU(EPSU,2))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,2)+
17562      &    PYI3AU(BETUS,EPSS,2))-0.25*EPSU*(1.-0.5*EPST)*
17563      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))+
17564      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
17565      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))
17566           A0UTSR=1.+(1.+2.*TH/UH)*PYW1AU(EPST,1)+(1.+2.*SH/UH)*
17567      &    PYW1AU(EPSS,1)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,1)+
17568      &    PYW2AU(EPSS,1))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,1)+
17569      &    PYI3AU(BEUST,EPST,1))-0.25*EPSS*(1.-0.5*EPSU)*
17570      &    (PYI3AU(BEUTS,EPSU,1)+PYI3AU(BEUTS,EPSS,1))+
17571      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
17572      &    (PYI3AU(BETUS,EPST,1)+PYI3AU(BETUS,EPSS,1))
17573           A0UTSI=(1.+2.*TH/UH)*PYW1AU(EPST,2)+(1.+2.*SH/UH)*
17574      &    PYW1AU(EPSS,2)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,2)+
17575      &    PYW2AU(EPSS,2))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,2)+
17576      &    PYI3AU(BEUST,EPST,2))-0.25*EPSS*(1.-0.5*EPSU)*
17577      &    (PYI3AU(BEUTS,EPSU,2)+PYI3AU(BEUTS,EPSS,2))+
17578      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
17579      &    (PYI3AU(BETUS,EPST,2)+PYI3AU(BETUS,EPSS,2))
17580           A1STUR=-1.-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,1)+
17581      &    PYW2AU(EPST,1)+PYW2AU(EPSU,1))+0.25*(EPSU+0.5*EPSS*EPST)*
17582      &    (PYI3AU(BESUT,EPSS,1)+PYI3AU(BESUT,EPST,1))+
17583      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,1)+
17584      &    PYI3AU(BESTU,EPSU,1))+0.25*(EPSS+0.5*EPST*EPSU)*
17585      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))
17586           A1STUI=-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,2)+PYW2AU(EPST,2)+
17587      &    PYW2AU(EPSU,2))+0.25*(EPSU+0.5*EPSS*EPST)*
17588      &    (PYI3AU(BESUT,EPSS,2)+PYI3AU(BESUT,EPST,2))+
17589      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,2)+
17590      &    PYI3AU(BESTU,EPSU,2))+0.25*(EPSS+0.5*EPST*EPSU)*
17591      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))
17592           A2STUR=-1.+0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,1)+
17593      &    PYI3AU(BESUT,EPST,1))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,1)+
17594      &    PYI3AU(BESTU,EPSU,1))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,1)+
17595      &    PYI3AU(BETSU,EPSU,1))
17596           A2STUI=0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,2)+
17597      &    PYI3AU(BESUT,EPST,2))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,2)+
17598      &    PYI3AU(BESTU,EPSU,2))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,2)+
17599      &    PYI3AU(BETSU,EPSU,2))
17600         ENDIF
17601         ASRE=ASRE+EI**2*(A0STUR+A0TSUR+A0UTSR+4.*A1STUR+A2STUR)
17602         ASIM=ASIM+EI**2*(A0STUI+A0TSUI+A0UTSI+4.*A1STUI+A2STUI)
17603   780   CONTINUE
17604         FACGG=COMFAC*FACA/(8.*PARU(1)**2)*AS**2*AEM**2*(ASRE**2+ASIM**2)
17605         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 790
17606         NCHN=NCHN+1
17607         ISIG(NCHN,1)=21
17608         ISIG(NCHN,2)=21
17609         ISIG(NCHN,3)=1
17610         SIGH(NCHN)=FACGG
17611   790   CONTINUE
17612
17613       ELSEIF(ISUB.EQ.115) THEN
17614 C...g + g -> gamma + Z0.
17615
17616       ELSEIF(ISUB.EQ.116) THEN
17617 C...g + g -> Z0 + Z0.
17618
17619       ELSEIF(ISUB.EQ.117) THEN
17620 C...g + g -> W+ + W-.
17621
17622       ENDIF
17623
17624 C...G: 2 -> 3, tree diagrams.
17625
17626       ELSEIF(ISUB.LE.140) THEN
17627       IF(ISUB.EQ.121) THEN
17628 C...g + g -> f + fb + H0.
17629
17630       ENDIF
17631
17632 C...H: 2 -> 1, tree diagrams, non-standard model processes.
17633
17634       ELSEIF(ISUB.LE.160) THEN
17635       IF(ISUB.EQ.141) THEN
17636 C...f + fb -> gamma*/Z0/Z'0.
17637         MINT(61)=2
17638         CALL PYWIDT(32,SQRT(SH),WDTP,WDTE)
17639         FACZP=COMFAC*AEM**2*4./9.
17640         DO 800 I=MINA,MAXA
17641         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 800
17642         EI=KCHG(IABS(I),1)/3.
17643         AI=SIGN(1.,EI)
17644         VI=AI-4.*EI*XW
17645         API=SIGN(1.,EI)
17646         VPI=API-4.*EI*XW
17647         NCHN=NCHN+1
17648         ISIG(NCHN,1)=I
17649         ISIG(NCHN,2)=-I
17650         ISIG(NCHN,3)=1
17651         SIGH(NCHN)=FACZP*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
17652      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+EI*VPI/(8.*XW*
17653      &  (1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GMMZP**2)*VINT(113)+
17654      &  (VI**2+AI**2)/(16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*
17655      &  VINT(114)+2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*SH2*
17656      &  ((SH-SQMZ)*(SH-SQMZP)+GMMZ*GMMZP)/(((SH-SQMZ)**2+GMMZ**2)*
17657      &  ((SH-SQMZP)**2+GMMZP**2))*VINT(115)+(VPI**2+API**2)/
17658      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZP)**2+GMMZP**2)*VINT(116))
17659   800   CONTINUE
17660
17661       ELSEIF(ISUB.EQ.142) THEN
17662 C...f + fb' -> H+/-.
17663         CALL PYWIDT(37,SQRT(SH),WDTP,WDTE)
17664         FHC=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/
17665      &  ((SH-SQMHC)**2+GMMHC**2)
17666 C'''No construction yet for leptons
17667         DO 840 I=1,MSTP(54)/2
17668         IL=2*I-1
17669         IU=2*I
17670         RMQL=PMAS(IL,1)**2/SH
17671         RMQU=PMAS(IU,1)**2/SH
17672         FACHC=FHC*((RMQL*PARU(121)+RMQU/PARU(121))*(1.-RMQL-RMQU)-
17673      &  4.*RMQL*RMQU)/SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))
17674         IF(KFAC(1,IL)*KFAC(2,-IU).EQ.0) GOTO 810
17675         KCHHC=(KCHG(IL,1)-KCHG(IU,1))/3
17676         NCHN=NCHN+1
17677         ISIG(NCHN,1)=IL
17678         ISIG(NCHN,2)=-IU
17679         ISIG(NCHN,3)=1
17680         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17681   810   IF(KFAC(1,-IL)*KFAC(2,IU).EQ.0) GOTO 820
17682         KCHHC=(-KCHG(IL,1)+KCHG(IU,1))/3
17683         NCHN=NCHN+1
17684         ISIG(NCHN,1)=-IL
17685         ISIG(NCHN,2)=IU
17686         ISIG(NCHN,3)=1
17687         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17688   820   IF(KFAC(1,IU)*KFAC(2,-IL).EQ.0) GOTO 830
17689         KCHHC=(KCHG(IU,1)-KCHG(IL,1))/3
17690         NCHN=NCHN+1
17691         ISIG(NCHN,1)=IU
17692         ISIG(NCHN,2)=-IL
17693         ISIG(NCHN,3)=1
17694         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17695   830   IF(KFAC(1,-IU)*KFAC(2,IL).EQ.0) GOTO 840
17696         KCHHC=(-KCHG(IU,1)+KCHG(IL,1))/3
17697         NCHN=NCHN+1
17698         ISIG(NCHN,1)=-IU
17699         ISIG(NCHN,2)=IL
17700         ISIG(NCHN,3)=1
17701         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17702   840   CONTINUE
17703
17704       ELSEIF(ISUB.EQ.143) THEN
17705 C...f + fb -> R.
17706         CALL PYWIDT(40,SQRT(SH),WDTP,WDTE)
17707         FACR=COMFAC*(AEM/XW)**2*1./9.*SH2/((SH-SQMR)**2+GMMR**2)
17708         DO 860 I=MIN1,MAX1
17709         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
17710         IA=IABS(I)
17711         DO 850 J=MIN2,MAX2
17712         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
17713         JA=IABS(J)
17714         IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 850
17715         NCHN=NCHN+1
17716         ISIG(NCHN,1)=I
17717         ISIG(NCHN,2)=J
17718         ISIG(NCHN,3)=1
17719         SIGH(NCHN)=FACR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
17720   850   CONTINUE
17721   860   CONTINUE
17722
17723       ENDIF
17724
17725 C...I: 2 -> 2, tree diagrams, non-standard model processes.
17726
17727       ELSE
17728       IF(ISUB.EQ.161) THEN
17729 C...f + g -> f' + H+/- (q + g -> q' + H+/- only).
17730         FHCQ=COMFAC*FACA*AS*AEM/XW*1./24
17731         DO 900 I=1,MSTP(54)
17732         IU=I+MOD(I,2)
17733         SQMQ=PMAS(IU,1)**2
17734         FACHCQ=FHCQ/PARU(121)*SQMQ/SQMW*(SH/(SQMQ-UH)+
17735      &  2.*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
17736      &  2.*SQMQ/(SQMQ-UH)+2.*(SQMHC-UH)/(SQMQ-UH)*(SQMHC-SQMQ-SH)/SH)
17737         IF(KFAC(1,-I)*KFAC(2,21).EQ.0) GOTO 870
17738         KCHHC=ISIGN(1,-KCHG(I,1))
17739         NCHN=NCHN+1
17740         ISIG(NCHN,1)=-I
17741         ISIG(NCHN,2)=21
17742         ISIG(NCHN,3)=1
17743         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17744   870   IF(KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 880
17745         KCHHC=ISIGN(1,KCHG(I,1))
17746         NCHN=NCHN+1
17747         ISIG(NCHN,1)=I
17748         ISIG(NCHN,2)=21
17749         ISIG(NCHN,3)=1
17750         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17751   880   IF(KFAC(1,21)*KFAC(2,-I).EQ.0) GOTO 890
17752         KCHHC=ISIGN(1,-KCHG(I,1))
17753         NCHN=NCHN+1
17754         ISIG(NCHN,1)=21
17755         ISIG(NCHN,2)=-I
17756         ISIG(NCHN,3)=1
17757         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17758   890   IF(KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 900
17759         KCHHC=ISIGN(1,KCHG(I,1))
17760         NCHN=NCHN+1
17761         ISIG(NCHN,1)=21
17762         ISIG(NCHN,2)=I
17763         ISIG(NCHN,3)=1
17764         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
17765   900   CONTINUE
17766
17767       ENDIF
17768       ENDIF
17769
17770 C...Multiply with structure functions.
17771       IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
17772         DO 910 ICHN=1,NCHN
17773         IF(MINT(41).EQ.2) THEN
17774           KFL1=ISIG(ICHN,1)
17775           IF(KFL1.EQ.21) KFL1=0
17776           SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
17777         ENDIF
17778         IF(MINT(42).EQ.2) THEN
17779           KFL2=ISIG(ICHN,2)
17780           IF(KFL2.EQ.21) KFL2=0
17781           SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
17782         ENDIF
17783   910   SIGS=SIGS+SIGH(ICHN)
17784       ENDIF
17785
17786       RETURN
17787       END
17788
17789 C*********************************************************************
17790
17791       SUBROUTINE PYSTFU(KF,X,Q2,XPQ,JBT)
17792
17793 C                       *******JBT specifies beam or target of the particle
17794 C...Gives proton and pi+ parton structure functions according to a few
17795 C...different parametrizations. Note that what is coded is x times the
17796 C...probability distribution, i.e. xq(x,Q2) etc.
17797       COMMON/HIPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
17798       COMMON/HIJCRDN/YP(3,300),YT(3,300)
17799 C                       ********COMMON BLOCK FROM HIJING
17800       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17801       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
17802       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17803       COMMON/PYINT1/MINT(400),VINT(400)
17804       DIMENSION XPQ(-6:6),XQ(6),TX(6),TT(6),TS(6),NEHLQ(8,2),
17805      &CEHLQ(6,6,2,8,2),CDO(3,6,5,2),COW(3,5,4,2)
17806       SAVE
17807
17808 C...The following data lines are coefficients needed in the
17809 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
17810 C...parametrizations, see below.
17811 C...Powers of 1-x in different cases.
17812       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
17813 C...Expansion coefficients for up valence quark distribution.
17814       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
17815      1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,
17816      2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,
17817      3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,
17818      4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,
17819      5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,
17820      6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,
17821      1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,
17822      2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,
17823      3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,
17824      4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,
17825      5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,
17826      6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/
17827       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
17828      1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,
17829      2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,
17830      3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,
17831      4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,
17832      5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,
17833      6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,
17834      1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,
17835      2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,
17836      3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,
17837      4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,
17838      5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,
17839      6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/
17840 C...Expansion coefficients for down valence quark distribution.
17841       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
17842      1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,
17843      2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,
17844      3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,
17845      4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,
17846      5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,
17847      6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,
17848      1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,
17849      2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,
17850      3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,
17851      4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,
17852      5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,
17853      6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/
17854       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
17855      1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,
17856      2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,
17857      3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,
17858      4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,
17859      5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,
17860      6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,
17861      1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,
17862      2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,
17863      3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,
17864      4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,
17865      5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,
17866      6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/
17867 C...Expansion coefficients for up and down sea quark distributions.
17868       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
17869      1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,
17870      2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,
17871      3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,
17872      4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,
17873      5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,
17874      6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,
17875      1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,
17876      2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,
17877      3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,
17878      4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,
17879      5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,
17880      6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/
17881       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
17882      1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,
17883      2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,
17884      3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,
17885      4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,
17886      5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,
17887      6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,
17888      1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,
17889      2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,
17890      3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,
17891      4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,
17892      5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,
17893      6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/
17894 C...Expansion coefficients for gluon distribution.
17895       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
17896      1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,
17897      2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,
17898      3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,
17899      4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,
17900      5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,
17901      6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,
17902      1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,
17903      2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,
17904      3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,
17905      4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,
17906      5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,
17907      6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/
17908       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
17909      1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,
17910      2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,
17911      3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,
17912      4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,
17913      5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,
17914      6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,
17915      1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,
17916      2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,
17917      3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,
17918      4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,
17919      5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,
17920      6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/
17921 C...Expansion coefficients for strange sea quark distribution.
17922       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
17923      1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,
17924      2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,
17925      3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,
17926      4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,
17927      5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,
17928      6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,
17929      1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,
17930      2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,
17931      3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,
17932      4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,
17933      5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,
17934      6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/
17935       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
17936      1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,
17937      2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,
17938      3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,
17939      4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,
17940      5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,
17941      6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,
17942      1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,
17943      2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,
17944      3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,
17945      4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,
17946      5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,
17947      6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/
17948 C...Expansion coefficients for charm sea quark distribution.
17949       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
17950      1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,
17951      2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,
17952      3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,
17953      4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,
17954      5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,
17955      6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,
17956      1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,
17957      2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,
17958      3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,
17959      4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,
17960      5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,
17961      6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/
17962       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
17963      1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,
17964      2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,
17965      3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,
17966      4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,
17967      5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,
17968      6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,
17969      1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,
17970      2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,
17971      3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,
17972      4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,
17973      5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,
17974      6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/
17975 C...Expansion coefficients for bottom sea quark distribution.
17976       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
17977      1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,
17978      2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,
17979      3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,
17980      4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,
17981      5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,
17982      6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,
17983      1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,
17984      2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,
17985      3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,
17986      4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,
17987      5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,
17988      6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/
17989       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
17990      1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,
17991      2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,
17992      3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,
17993      4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,
17994      5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,
17995      6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,
17996      1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,
17997      2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,
17998      3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,
17999      4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,
18000      5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,
18001      6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/
18002 C...Expansion coefficients for top sea quark distribution.
18003       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
18004      1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,
18005      2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,
18006      3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,
18007      4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,
18008      5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,
18009      6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
18010      1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,
18011      2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,
18012      3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,
18013      4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,
18014      5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,
18015      6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/
18016       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
18017      1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,
18018      2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,
18019      3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,
18020      4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,
18021      5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,
18022      6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
18023      1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,
18024      2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,
18025      3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,
18026      4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,
18027      5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,
18028      6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/
18029
18030 C...The following data lines are coefficients needed in the
18031 C...Duke, Owens proton structure function parametrizations, see below.
18032 C...Expansion coefficients for (up+down) valence quark distribution.
18033       DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
18034      1 4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18035      2 4.000E-03, 7.240E-01,-4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18036      3-7.000E-03,-6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/
18037       DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
18038      1 3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18039      2 1.400E-02, 7.530E-01,-6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18040      3 0.000E+00,-7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/
18041 C...Expansion coefficients for down valence quark distribution.
18042       DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
18043      1 7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18044      2-2.370E-01, 6.270E-01,-4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00,
18045      3 2.600E-02,-1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/
18046       DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
18047      1 7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18048      2-2.320E-01, 6.270E-01,-4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00,
18049      3 2.300E-02,-1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/
18050 C...Expansion coefficients for (up+down+strange) sea quark distribution.
18051       DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
18052      1 1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18053      2-1.132E+00,-3.720E-01, 1.590E+00, 6.310E+00,-1.050E+01, 1.470E+01,
18054      3 2.930E-01,-2.900E-02,-1.530E-01,-2.730E-01,-3.170E+00, 9.800E+00/
18055       DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
18056      1 1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18057      2-1.920E+00,-2.730E-01, 5.300E-01, 1.570E+01,-1.010E+02, 2.230E+02,
18058      3 5.820E-01,-1.640E-01,-7.630E-01,-2.830E+00, 4.470E+01,-1.170E+02/
18059 C...Expansion coefficients for charm sea quark distribution.
18060       DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
18061      1 0.000E+00,-3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18062      2 1.350E-01,-2.220E-01, 3.260E+00,-3.030E+00, 1.740E+01,-1.790E+01,
18063      3-7.500E-02,-5.800E-02,-9.090E-01, 1.500E+00,-1.130E+01, 1.560E+01/
18064        DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
18065      1 0.000E+00,-1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00,
18066      2 6.700E-02,-2.330E-01, 3.660E+00,-4.740E-01, 9.500E+00,-1.660E+01,
18067      3-3.100E-02,-2.300E-02,-4.530E-01, 3.580E-01,-5.430E+00, 1.550E+01/
18068 C...Expansion coefficients for gluon distribution.
18069       DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
18070      1 1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
18071      2-1.710E+00,-9.490E-01, 1.440E+00,-7.190E+00,-1.650E+01, 1.530E+01,
18072      3 6.380E-01, 3.250E-01,-1.050E+00, 2.550E-01, 1.090E+01,-1.010E+01/
18073       DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
18074      1 8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
18075      2-9.710E-01,-1.160E+00, 1.230E+00,-5.640E+00,-7.540E+00,-5.960E-01,
18076      3 4.340E-01, 4.760E-01,-2.540E-01,-8.170E-01, 5.500E+00, 1.260E-01/
18077
18078 C...The following data lines are coefficients needed in the
18079 C...Owens pion structure function parametrizations, see below.
18080 C...Expansion coefficients for up and down valence quark distributions.
18081       DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
18082      1  4.0000E-01,  7.0000E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18083      2 -6.2120E-02,  6.4780E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18084      3 -7.1090E-03,  1.3350E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/
18085       DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
18086      1  4.0000E-01,  6.2800E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18087      2 -5.9090E-02,  6.4360E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00,
18088      3 -6.5240E-03,  1.4510E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/
18089 C...Expansion coefficients for gluon distribution.
18090       DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
18091      1  8.8800E-01,  0.0000E+00,  3.1100E+00,  6.0000E+00,  0.0000E+00,
18092      2 -1.8020E+00, -1.5760E+00, -1.3170E-01,  2.8010E+00, -1.7280E+01,
18093      3  1.8120E+00,  1.2000E+00,  5.0680E-01, -1.2160E+01,  2.0490E+01/
18094       DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
18095      1  7.9400E-01,  0.0000E+00,  2.8900E+00,  6.0000E+00,  0.0000E+00,
18096      2 -9.1440E-01, -1.2370E+00,  5.9660E-01, -3.6710E+00, -8.1910E+00,
18097      3  5.9660E-01,  6.5820E-01, -2.5500E-01, -2.3040E+00,  7.7580E+00/
18098 C...Expansion coefficients for (up+down+strange) quark sea distribution.
18099       DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
18100      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00,
18101      2 -2.4280E-01, -2.1200E-01,  8.6730E-01,  1.2660E+00,  2.3820E+00,
18102      3  1.3860E-01,  3.6710E-03,  4.7470E-02, -2.2150E+00,  3.4820E-01/
18103       DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
18104      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00,
18105      2 -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00,  5.6210E-01,
18106      3 -1.7400E-01, -9.6230E-02,  1.5750E+00,  1.3780E+00, -2.7010E-01/
18107 C...Expansion coefficients for charm quark sea distribution.
18108       DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
18109      1  0.0000E+00, -2.2120E-02,  2.8940E+00,  0.0000E+00,  0.0000E+00,
18110      2  7.9280E-02, -3.7850E-01,  9.4330E+00,  5.2480E+00,  8.3880E+00,
18111      3 -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/
18112       DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
18113      1  0.0000E+00, -8.8200E-02,  1.9240E+00,  0.0000E+00,  0.0000E+00,
18114      2  6.2290E-02, -2.8920E-01,  2.4240E-01, -4.4630E+00, -8.3670E-01,
18115      3 -4.0990E-02, -1.0820E-01,  2.0360E+00,  5.2090E+00, -4.8400E-02/
18116
18117 C...Euler's beta function, requires ordinary Gamma function
18118       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
18119
18120 C...Reset structure functions, check x and hadron flavour.
18121       ALAM=0.
18122       DO 100 KFL=-6,6
18123   100 XPQ(KFL)=0.
18124       IF(X.LT.0..OR.X.GT.1.) THEN
18125         WRITE(MSTU(11),1000) X
18126         RETURN
18127       ENDIF
18128       KFA=IABS(KF)
18129       IF(KFA.NE.211.AND.KFA.NE.2212.AND.KFA.NE.2112) THEN
18130         WRITE(MSTU(11),1100) KF
18131         RETURN
18132       ENDIF
18133
18134 C...Call user-supplied structure function. Select proton/neutron/pion.
18135       IF(MSTP(51).EQ.0.OR.MSTP(52).GE.2) THEN
18136         KFE=KFA
18137         IF(KFA.EQ.2112) KFE=2212
18138         CALL PYSTFE(KFE,X,Q2,XPQ)
18139         GOTO 230
18140       ENDIF
18141       IF(KFA.EQ.211) GOTO 200
18142
18143       IF(MSTP(51).EQ.1.OR.MSTP(51).EQ.2) THEN
18144 C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.
18145 C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1
18146
18147 C...Determine set, Lamdba and x and t expansion variables.
18148         NSET=MSTP(51)
18149         IF(NSET.EQ.1) ALAM=0.2
18150         IF(NSET.EQ.2) ALAM=0.29
18151         TMIN=LOG(5./ALAM**2)
18152         TMAX=LOG(1E8/ALAM**2)
18153         IF(MSTP(52).EQ.0) THEN
18154           T=TMIN
18155         ELSE
18156           T=LOG(Q2/ALAM**2)
18157         ENDIF
18158         VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
18159         NX=1
18160         IF(X.LE.0.1) NX=2
18161         IF(NX.EQ.1) VX=(2.*X-1.1)/0.9
18162         IF(NX.EQ.2) VX=MAX(-1.,(2.*LOG(X)+11.51293)/6.90776)
18163         CXS=1.
18164         IF(X.LT.1E-4.AND.ABS(PARP(51)-1.).GT.0.01) CXS=
18165      &  (1E-4/X)**(PARP(51)-1.)
18166
18167 C...Chebyshev polynomials for x and t expansion.
18168         TX(1)=1.
18169         TX(2)=VX
18170         TX(3)=2.*VX**2-1.
18171         TX(4)=4.*VX**3-3.*VX
18172         TX(5)=8.*VX**4-8.*VX**2+1.
18173         TX(6)=16.*VX**5-20.*VX**3+5.*VX
18174         TT(1)=1.
18175         TT(2)=VT
18176         TT(3)=2.*VT**2-1.
18177         TT(4)=4.*VT**3-3.*VT
18178         TT(5)=8.*VT**4-8.*VT**2+1.
18179         TT(6)=16.*VT**5-20.*VT**3+5.*VT
18180
18181 C...Calculate structure functions.
18182         DO 120 KFL=1,6
18183         XQSUM=0.
18184         DO 110 IT=1,6
18185         DO 110 IX=1,6
18186   110   XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
18187   120   XQ(KFL)=XQSUM*(1.-X)**NEHLQ(KFL,NSET)*CXS
18188
18189 C...Put into output array.
18190         XPQ(0)=XQ(4)
18191         XPQ(1)=XQ(2)+XQ(3)
18192         XPQ(2)=XQ(1)+XQ(3)
18193         XPQ(3)=XQ(5)
18194         XPQ(4)=XQ(6)
18195         XPQ(-1)=XQ(3)
18196         XPQ(-2)=XQ(3)
18197         XPQ(-3)=XQ(5)
18198         XPQ(-4)=XQ(6)
18199
18200 C...Special expansion for bottom (threshold effects).
18201         IF(MSTP(54).GE.5) THEN
18202           IF(NSET.EQ.1) TMIN=8.1905
18203           IF(NSET.EQ.2) TMIN=7.4474
18204           IF(T.LE.TMIN) GOTO 140
18205           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
18206           TT(1)=1.
18207           TT(2)=VT
18208           TT(3)=2.*VT**2-1.
18209           TT(4)=4.*VT**3-3.*VT
18210           TT(5)=8.*VT**4-8.*VT**2+1.
18211           TT(6)=16.*VT**5-20.*VT**3+5.*VT
18212           XQSUM=0.
18213           DO 130 IT=1,6
18214           DO 130 IX=1,6
18215   130     XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
18216           XPQ(5)=XQSUM*(1.-X)**NEHLQ(7,NSET)
18217           XPQ(-5)=XPQ(5)
18218   140     CONTINUE
18219         ENDIF
18220
18221 C...Special expansion for top (threshold effects).
18222         IF(MSTP(54).GE.6) THEN
18223           IF(NSET.EQ.1) TMIN=11.5528
18224           IF(NSET.EQ.2) TMIN=10.8097
18225           TMIN=TMIN+2.*LOG(PMAS(6,1)/30.)
18226           TMAX=TMAX+2.*LOG(PMAS(6,1)/30.)
18227           IF(T.LE.TMIN) GOTO 160
18228           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
18229           TT(1)=1.
18230           TT(2)=VT
18231           TT(3)=2.*VT**2-1.
18232           TT(4)=4.*VT**3-3.*VT
18233           TT(5)=8.*VT**4-8.*VT**2+1.
18234           TT(6)=16.*VT**5-20.*VT**3+5.*VT
18235           XQSUM=0.
18236           DO 150 IT=1,6
18237           DO 150 IX=1,6
18238   150     XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
18239           XPQ(6)=XQSUM*(1.-X)**NEHLQ(8,NSET)
18240           XPQ(-6)=XPQ(6)
18241   160     CONTINUE
18242         ENDIF
18243
18244       ELSEIF(MSTP(51).EQ.3.OR.MSTP(51).EQ.4) THEN
18245 C...Proton structure functions from Duke, Owens.
18246 C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.
18247
18248 C...Determine set, Lambda and s expansion parameter.
18249         NSET=MSTP(51)-2
18250         IF(NSET.EQ.1) ALAM=0.2
18251         IF(NSET.EQ.2) ALAM=0.4
18252         IF(MSTP(52).LE.0) THEN
18253           SD=0.
18254         ELSE
18255           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
18256         ENDIF
18257
18258 C...Calculate structure functions.
18259         DO 180 KFL=1,5
18260         DO 170 IS=1,6
18261   170   TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
18262      &  CDO(3,IS,KFL,NSET)*SD**2
18263         IF(KFL.LE.2) THEN
18264           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBET(TS(1),
18265      &    TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))
18266         ELSE
18267           XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2+
18268      &    TS(6)*X**3)
18269         ENDIF
18270   180   CONTINUE
18271
18272 C...Put into output arrays.
18273         XPQ(0)=XQ(5)
18274         XPQ(1)=XQ(2)+XQ(3)/6.
18275         XPQ(2)=3.*XQ(1)-XQ(2)+XQ(3)/6.
18276         XPQ(3)=XQ(3)/6.
18277         XPQ(4)=XQ(4)
18278         XPQ(-1)=XQ(3)/6.
18279         XPQ(-2)=XQ(3)/6.
18280         XPQ(-3)=XQ(3)/6.
18281         XPQ(-4)=XQ(4)
18282
18283 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
18284 C...These are accessed via PYSTFE since the files needed may not always
18285 C...available.
18286       ELSEIF(MSTP(51).GE.11.AND.MSTP(51).LE.13) THEN
18287         CALL PYSTFE(2212,X,Q2,XPQ)
18288
18289 C...Unknown proton parametrization.
18290       ELSE
18291         WRITE(MSTU(11),1200) MSTP(51)
18292       ENDIF
18293       GOTO 230
18294
18295   200 IF((MSTP(51).GE.1.AND.MSTP(51).LE.4).OR.
18296      &(MSTP(51).GE.11.AND.MSTP(51).LE.13)) THEN
18297 C...Pion structure functions from Owens.
18298 C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2.
18299
18300 C...Determine set, Lambda and s expansion variable.
18301         NSET=1
18302         IF(MSTP(51).EQ.2.OR.MSTP(51).EQ.4.OR.MSTP(51).EQ.13) NSET=2
18303         IF(NSET.EQ.1) ALAM=0.2
18304         IF(NSET.EQ.2) ALAM=0.4
18305         IF(MSTP(52).LE.0) THEN
18306           SD=0.
18307         ELSE
18308           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
18309         ENDIF
18310
18311 C...Calculate structure functions.
18312         DO 220 KFL=1,4
18313         DO 210 IS=1,5
18314   210   TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
18315      &  COW(3,IS,KFL,NSET)*SD**2
18316         IF(KFL.EQ.1) THEN
18317           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBET(TS(1),TS(2)+1.)
18318         ELSE
18319           XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2)
18320         ENDIF
18321   220   CONTINUE
18322
18323 C...Put into output arrays.
18324         XPQ(0)=XQ(2)
18325         XPQ(1)=XQ(3)/6.
18326         XPQ(2)=XQ(1)+XQ(3)/6.
18327         XPQ(3)=XQ(3)/6.
18328         XPQ(4)=XQ(4)
18329         XPQ(-1)=XQ(1)+XQ(3)/6.
18330         XPQ(-2)=XQ(3)/6.
18331         XPQ(-3)=XQ(3)/6.
18332         XPQ(-4)=XQ(4)
18333
18334 C...Unknown pion parametrization.
18335       ELSE
18336         WRITE(MSTU(11),1200) MSTP(51)
18337       ENDIF
18338
18339 C...Isospin conjugation for neutron, charge conjugation for antipart.
18340   230 IF(KFA.EQ.2112) THEN
18341         XPS=XPQ(1)
18342         XPQ(1)=XPQ(2)
18343         XPQ(2)=XPS
18344         XPS=XPQ(-1)
18345         XPQ(-1)=XPQ(-2)
18346         XPQ(-2)=XPS
18347       ENDIF
18348       IF(KF.LT.0) THEN
18349         DO 240 KFL=1,4
18350         XPS=XPQ(KFL)
18351         XPQ(KFL)=XPQ(-KFL)
18352   240   XPQ(-KFL)=XPS
18353       ENDIF
18354
18355 C...Check positivity and reset above maximum allowed flavour.
18356       DO 250 KFL=-6,6
18357       XPQ(KFL)=MAX(0.,XPQ(KFL))
18358   250 IF(IABS(KFL).GT.MSTP(54)) XPQ(KFL)=0.
18359
18360 C...consider nuclear effect on the structure function
18361         IF((JBT.NE.1.AND.JBT.NE.2).OR.IHPR2(6).EQ.0
18362      &                  .OR.IHNT2(16).EQ.1) GO TO 400
18363         ATNM=IHNT2(2*JBT-1)
18364         IF(ATNM.LE.1.0) GO TO 400
18365         IF(JBT.EQ.1) THEN
18366           BBR2=(YP(1,IHNT2(11))**2+YP(2,IHNT2(11))**2)/1.44/ATNM**0.66666
18367         ELSEIF(JBT.EQ.2) THEN
18368           BBR2=(YT(1,IHNT2(12))**2+YT(2,IHNT2(12))**2)/1.44/ATNM**0.66666
18369         ENDIF
18370         BBR2=MIN(1.0,BBR2)
18371         ABX=(ATNM**0.33333333-1.0)
18372         APX=HIPR1(6)*4.0/3.0*ABX*SQRT(1.0-BBR2)
18373         AAX=1.192*ALOG(ATNM)**0.1666666
18374         RRX=AAX*(X**3-1.2*X**2+0.21*X)+1.0
18375      &          -(APX-1.079*ABX*SQRT(X)/ALOG(ATNM+1.0))*EXP(-X**2.0/0.01)
18376         DO 300 KFL=-6,6
18377                 XPQ(KFL)=XPQ(KFL)*RRX
18378 300     CONTINUE
18379 C                       ********consider the nuclear effect on the structure
18380 C                               fucntion which also depends on the impact
18381 C                               parameter of the nuclear reaction
18382
18383 400     CONTINUE
18384 C...Formats for error printouts.
18385  1000 FORMAT(' Error: x value outside physical range, x =',1P,E12.3)
18386  1100 FORMAT(' Error: illegal particle code for structure function,',
18387      &' KF =',I5)
18388  1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',
18389      &' MSTP(51) =',I5)
18390
18391       RETURN
18392       END
18393
18394 C*********************************************************************
18395
18396       SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
18397
18398 C...In case of a hadron remnant which is more complicated than just a
18399 C...quark or a diquark, split it into two (partons or hadron + parton).
18400       DIMENSION KFL(3)
18401
18402 C...Preliminaries. Parton composition.
18403       KFA=IABS(KF)
18404       KFS=ISIGN(1,KF)
18405       KFL(1)=MOD(KFA/1000,10)
18406       KFL(2)=MOD(KFA/100,10)
18407       KFL(3)=MOD(KFA/10,10)
18408       KFLR=KFLIN*KFS
18409       KFLCH=0
18410
18411 C...Subdivide meson.
18412       IF(KFL(1).EQ.0) THEN
18413         KFL(2)=KFL(2)*(-1)**KFL(2)
18414         KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
18415         IF(KFLR.EQ.KFL(2)) THEN
18416           KFLSP=KFL(3)
18417         ELSEIF(KFLR.EQ.KFL(3)) THEN
18418           KFLSP=KFL(2)
18419         ELSEIF(IABS(KFLR).EQ.21.AND.RLU(0).GT.0.5) THEN
18420           KFLSP=KFL(2)
18421           KFLCH=KFL(3)
18422         ELSEIF(IABS(KFLR).EQ.21) THEN
18423           KFLSP=KFL(3)
18424           KFLCH=KFL(2)
18425         ELSEIF(KFLR*KFL(2).GT.0) THEN
18426           CALL LUKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
18427           KFLSP=KFL(3)
18428         ELSE
18429           CALL LUKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
18430           KFLSP=KFL(2)
18431         ENDIF
18432
18433 C...Subdivide baryon.
18434       ELSE
18435         NAGR=0
18436         DO 100 J=1,3
18437   100   IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
18438         IF(NAGR.GE.1) THEN
18439           RAGR=0.00001+(NAGR-0.00002)*RLU(0)
18440           IAGR=0
18441           DO 110 J=1,3
18442           IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1.
18443   110     IF(IAGR.EQ.0.AND.RAGR.LE.0.) IAGR=J
18444         ELSE
18445           IAGR=1.00001+2.99998*RLU(0)
18446         ENDIF
18447         ID1=1
18448         IF(IAGR.EQ.1) ID1=2
18449         IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
18450         ID2=6-IAGR-ID1
18451         KSP=3
18452         IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
18453           IF(IAGR.NE.3.AND.RLU(0).GT.0.25) KSP=1
18454         ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
18455           IF(IAGR.NE.1.AND.RLU(0).GT.0.25) KSP=1
18456         ELSEIF(MOD(KFA,10).EQ.2) THEN
18457           IF(IAGR.EQ.1) KSP=1
18458           IF(IAGR.NE.1.AND.RLU(0).GT.0.75) KSP=1
18459         ENDIF
18460         KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
18461         IF(KFLIN.EQ.21) THEN
18462           KFLCH=KFL(IAGR)
18463         ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
18464           CALL LUKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
18465         ELSEIF(NAGR.EQ.0) THEN
18466           CALL LUKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
18467           KFLSP=KFL(IAGR)
18468         ENDIF
18469       ENDIF
18470
18471 C...Add on correct sign for result.
18472       KFLCH=KFLCH*KFS
18473       KFLSP=KFLSP*KFS
18474
18475       RETURN
18476       END
18477
18478 C*********************************************************************
18479
18480       FUNCTION PYGAMM(X)
18481
18482 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
18483 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
18484 C...(Dover, 1965) 6.1.36.
18485       DIMENSION B(8)
18486       DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857,
18487      &-0.756704078,0.482199394,-0.193527818,0.035868343/
18488
18489       NX=INT(X)
18490       DX=X-NX
18491
18492       PYGAMM=1.
18493       DO 100 I=1,8
18494   100 PYGAMM=PYGAMM+B(I)*DX**I
18495       IF(X.LT.1.) THEN
18496         PYGAMM=PYGAMM/X
18497       ELSE
18498         DO 110 IX=1,NX-1
18499   110   PYGAMM=(X-IX)*PYGAMM
18500       ENDIF
18501
18502       RETURN
18503       END
18504
18505 C***********************************************************************
18506
18507       FUNCTION PYW1AU(EPS,IREIM)
18508
18509 C...Calculates real and imaginary parts of the auxiliary function W1;
18510 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18511 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18512       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18513       SAVE
18514
18515       ASINH(X)=LOG(X+SQRT(X**2+1.))
18516       ACOSH(X)=LOG(X+SQRT(X**2-1.))
18517
18518       IF(EPS.LT.0.) THEN
18519         W1RE=2.*SQRT(1.-EPS)*ASINH(SQRT(-1./EPS))
18520         W1IM=0.
18521       ELSEIF(EPS.LT.1.) THEN
18522         W1RE=2.*SQRT(1.-EPS)*ACOSH(SQRT(1./EPS))
18523         W1IM=-PARU(1)*SQRT(1.-EPS)
18524       ELSE
18525         W1RE=2.*SQRT(EPS-1.)*ASIN(SQRT(1./EPS))
18526         W1IM=0.
18527       ENDIF
18528
18529 c      IF(IREIM.EQ.1) -man
18530       PYW1AU=W1RE
18531       IF(IREIM.EQ.2) PYW1AU=W1IM
18532
18533       RETURN
18534       END
18535
18536 C***********************************************************************
18537
18538       FUNCTION PYW2AU(EPS,IREIM)
18539
18540 C...Calculates real and imaginary parts of the auxiliary function W2;
18541 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18542 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18543       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18544       SAVE
18545
18546       ASINH(X)=LOG(X+SQRT(X**2+1.))
18547       ACOSH(X)=LOG(X+SQRT(X**2-1.))
18548
18549       IF(EPS.LT.0.) THEN
18550         W2RE=4.*(ASINH(SQRT(-1./EPS)))**2
18551         W2IM=0.
18552       ELSEIF(EPS.LT.1.) THEN
18553         W2RE=4.*(ACOSH(SQRT(1./EPS)))**2-PARU(1)**2
18554         W2IM=-4.*PARU(1)*ACOSH(SQRT(1./EPS))
18555       ELSE
18556         W2RE=-4.*(ASIN(SQRT(1./EPS)))**2
18557         W2IM=0.
18558       ENDIF
18559
18560 c      IF(IREIM.EQ.1) -man
18561       PYW2AU=W2RE
18562       IF(IREIM.EQ.2) PYW2AU=W2IM
18563
18564       RETURN
18565       END
18566
18567 C***********************************************************************
18568
18569       FUNCTION PYI3AU(BE,EPS,IREIM)
18570
18571 C...Calculates real and imaginary parts of the auxiliary function I3;
18572 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
18573 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
18574       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18575       SAVE
18576
18577       PYI3AU=0.
18578
18579       IF(EPS.LT.1.) GA=0.5*(1.+SQRT(1.-EPS))
18580
18581       IF(EPS.LT.0.) THEN
18582         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+
18583      &  PYSPEN((BE-GA)/BE,0.,1)-PYSPEN((BE-GA)/(BE-1.),0.,1)+
18584      &  (LOG(BE)**2-LOG(BE-1.)**2)/2.+LOG(GA)*LOG((GA+BE-1.)/BE)+
18585      &  LOG(GA-1.)*LOG((BE-1.)/(GA+BE-1.))
18586         F3IM=0.
18587       ELSEIF(EPS.LT.1.) THEN
18588         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+
18589      &  PYSPEN(GA/(GA-BE),0.,1)-PYSPEN((GA-1.)/(GA-BE),0.,1)+
18590      &  LOG(GA/(1.-GA))*LOG((GA+BE-1.)/(BE-GA))
18591         F3IM=-PARU(1)*LOG((GA+BE-1.)/(BE-GA))
18592       ELSE
18593         RSQ=EPS/(EPS-1.+(2.*BE-1.)**2)
18594         RCTHE=RSQ*(1.-2.*BE/EPS)
18595         RSTHE=SQRT(RSQ-RCTHE**2)
18596         RCPHI=RSQ*(1.+2.*(BE-1.)/EPS)
18597         RSPHI=SQRT(RSQ-RCPHI**2)
18598         R=SQRT(RSQ)
18599         THE=ACOS(RCTHE/R)
18600         PHI=ACOS(RCPHI/R)
18601         F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
18602      &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
18603      &  (PHI-THE)*(PHI+THE-PARU(1))
18604         F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
18605      &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
18606       ENDIF
18607
18608       IF(IREIM.EQ.1) PYI3AU=2./(2.*BE-1.)*F3RE
18609       IF(IREIM.EQ.2) PYI3AU=2./(2.*BE-1.)*F3IM
18610
18611       RETURN
18612       END
18613
18614 C***********************************************************************
18615
18616       FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
18617
18618 C...Calculates real and imaginary part of Spence function; see
18619 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
18620       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18621       DIMENSION B(0:14)
18622       SAVE
18623
18624       DATA B/
18625      & 1.000000E+00,        -5.000000E-01,         1.666667E-01,
18626      & 0.000000E+00,        -3.333333E-02,         0.000000E+00,
18627      & 2.380952E-02,         0.000000E+00,        -3.333333E-02,
18628      & 0.000000E+00,         7.575757E-02,         0.000000E+00,
18629      &-2.531135E-01,         0.000000E+00,         1.166667E+00/
18630
18631       XRE=XREIN
18632       XIM=XIMIN
18633       PYSPEN=0.
18634       IF(ABS(1.-XRE).LT.1.E-6.AND.ABS(XIM).LT.1.E-6) THEN
18635         IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6.
18636         IF(IREIM.EQ.2) PYSPEN=0.
18637         RETURN
18638       ENDIF
18639
18640       XMOD=SQRT(XRE**2+XIM**2)
18641       IF(XMOD.LT.1.E-6) THEN
18642         IF(IREIM.EQ.1) PYSPEN=0.
18643         IF(IREIM.EQ.2) PYSPEN=0.
18644         RETURN
18645       ENDIF
18646
18647       XARG=SIGN(ACOS(XRE/XMOD),XIM)
18648       SP0RE=0.
18649       SP0IM=0.
18650       SGN=1.
18651       IF(XMOD.GT.1.) THEN
18652         ALGXRE=LOG(XMOD)
18653         ALGXIM=XARG-SIGN(PARU(1),XARG)
18654         SP0RE=-PARU(1)**2/6.-(ALGXRE**2-ALGXIM**2)/2.
18655         SP0IM=-ALGXRE*ALGXIM
18656         SGN=-1.
18657         XMOD=1./XMOD
18658         XARG=-XARG
18659         XRE=XMOD*COS(XARG)
18660         XIM=XMOD*SIN(XARG)
18661       ENDIF
18662       IF(XRE.GT.0.5) THEN
18663         ALGXRE=LOG(XMOD)
18664         ALGXIM=XARG
18665         XRE=1.-XRE
18666         XIM=-XIM
18667         XMOD=SQRT(XRE**2+XIM**2)
18668         XARG=SIGN(ACOS(XRE/XMOD),XIM)
18669         ALGYRE=LOG(XMOD)
18670         ALGYIM=XARG
18671         SP0RE=SP0RE+SGN*(PARU(1)**2/6.-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
18672         SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
18673         SGN=-SGN
18674       ENDIF
18675
18676       XRE=1.-XRE
18677       XIM=-XIM
18678       XMOD=SQRT(XRE**2+XIM**2)
18679       XARG=SIGN(ACOS(XRE/XMOD),XIM)
18680       ZRE=-LOG(XMOD)
18681       ZIM=-XARG
18682
18683       SPRE=0.
18684       SPIM=0.
18685       SAVERE=1.
18686       SAVEIM=0.
18687       DO 100 I=0,14
18688       TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/FLOAT(I+1)
18689       TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/FLOAT(I+1)
18690       SAVERE=TERMRE
18691       SAVEIM=TERMIM
18692       SPRE=SPRE+B(I)*TERMRE
18693   100 SPIM=SPIM+B(I)*TERMIM
18694
18695       IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
18696       IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
18697
18698       RETURN
18699       END
18700
18701 ***********************************************************************
18702
18703       SUBROUTINE PYTEST(MTEST)
18704
18705 C...Purpose: to provide a simple program (disguised as a subroutine) to
18706 C...run at installation as a check that the program works as intended.
18707       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
18708       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18709       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
18710       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
18711       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
18712       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18713       SAVE
18714
18715 C...Common initial values. Loop over initiating conditions.
18716       MSTP(122)=1
18717       IF(MTEST.LE.0) MSTP(122)=0
18718       MDCY(LUCOMP(111),1)=0
18719       NERR=0
18720       DO 130 IPROC=1,7
18721
18722 C...Reset process type, kinematics cuts, and the flags used.
18723       MSEL=0
18724       DO 100 ISUB=1,200
18725   100 MSUB(ISUB)=0
18726       CKIN(1)=2.
18727       CKIN(3)=0.
18728       MSTP(2)=1
18729       MSTP(33)=0
18730       MSTP(81)=1
18731       MSTP(82)=1
18732       MSTP(111)=1
18733       MSTP(131)=0
18734       MSTP(133)=0
18735       PARP(131)=0.01
18736
18737 C...Prompt photon production at fixed target.
18738       IF(IPROC.EQ.1) THEN
18739         PZSUM=300.
18740         PESUM=SQRT(PZSUM**2+ULMASS(211)**2)+ULMASS(2212)
18741         PQSUM=2.
18742         MSEL=10
18743         CKIN(3)=5.
18744         CALL PYINIT('FIXT','pi+','p',PZSUM)
18745
18746 C...QCD processes at ISR energies.
18747       ELSEIF(IPROC.EQ.2) THEN
18748         PESUM=63.
18749         PZSUM=0.
18750         PQSUM=2.
18751         MSEL=1
18752         CKIN(3)=5.
18753         CALL PYINIT('CMS','p','p',PESUM)
18754
18755 C...W production + multiple interactions at CERN Collider.
18756       ELSEIF(IPROC.EQ.3) THEN
18757         PESUM=630.
18758         PZSUM=0.
18759         PQSUM=0.
18760         MSEL=12
18761         CKIN(1)=20.
18762         MSTP(82)=4
18763         MSTP(2)=2
18764         MSTP(33)=3
18765         CALL PYINIT('CMS','p','pbar',PESUM)
18766
18767 C...W/Z gauge boson pairs + overlayed events at the Tevatron.
18768       ELSEIF(IPROC.EQ.4) THEN
18769         PESUM=1800.
18770         PZSUM=0.
18771         PQSUM=0.
18772         MSUB(22)=1
18773         MSUB(23)=1
18774         MSUB(25)=1
18775         CKIN(1)=200.
18776         MSTP(111)=0
18777         MSTP(131)=1
18778         MSTP(133)=2
18779         PARP(131)=0.04
18780         CALL PYINIT('CMS','p','pbar',PESUM)
18781
18782 C...Higgs production at LHC.
18783       ELSEIF(IPROC.EQ.5) THEN
18784         PESUM=17000.
18785         PZSUM=0.
18786         PQSUM=0.
18787         MSEL=16
18788         PMAS(25,1)=300.
18789         CKIN(1)=200.
18790         MSTP(81)=0
18791         MSTP(111)=0
18792         CALL PYINIT('CMS','p','pbar',PESUM)
18793
18794 C...Z' production at SSC.
18795       ELSEIF(IPROC.EQ.6) THEN
18796         PESUM=40000.
18797         PZSUM=0.
18798         PQSUM=0.
18799         MSEL=21
18800         PMAS(32,1)=600.
18801         CKIN(1)=400.
18802         MSTP(81)=0
18803         MSTP(111)=0
18804         CALL PYINIT('CMS','p','pbar',PESUM)
18805
18806 C...W pair production at 1 TeV e+e- collider.
18807       ELSEIF(IPROC.EQ.7) THEN
18808         PESUM=1000.
18809         PZSUM=0.
18810         PQSUM=0.
18811         MSUB(25)=1
18812         CALL PYINIT('CMS','e+','e-',PESUM)
18813       ENDIF
18814
18815 C...Generate 20 events of each required type.
18816       DO 120 IEV=1,20
18817       CALL PYTHIA
18818       PESUMM=PESUM
18819       IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
18820
18821 C...Check conservation of energy/momentum/flavour.
18822       MERR=0
18823       DEVE=ABS(PLU(0,4)-PESUMM)+ABS(PLU(0,3)-PZSUM)
18824       DEVT=ABS(PLU(0,1))+ABS(PLU(0,2))
18825       DEVQ=ABS(PLU(0,6)-PQSUM)
18826       IF(DEVE.GT.1E-3*PESUM.OR.DEVT.GT.MAX(0.01,1E-5*PESUM).OR.
18827      &DEVQ.GT.0.1) MERR=1
18828       IF(MERR.NE.0) WRITE(MSTU(11),1000) IPROC,IEV
18829
18830 C...Check that all KF codes are known ones, and that partons/particles
18831 C...satisfy energy-momentum-mass relation.
18832       DO 110 I=1,N
18833       IF(K(I,1).GT.20) GOTO 110
18834       IF(LUCOMP(K(I,2)).EQ.0) THEN
18835         WRITE(MSTU(11),1100) I
18836         MERR=MERR+1
18837       ENDIF
18838       PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
18839      &SIGN(1.,P(I,5))
18840       IF(ABS(PD).GT.MAX(0.1,0.002*P(I,4)**2,0.002*P(I,5)**2).OR.
18841      &(P(I,5).GE.0..AND.P(I,4).LT.0.)) THEN
18842         WRITE(MSTU(11),1200) I
18843         MERR=MERR+1
18844       ENDIF
18845   110 CONTINUE
18846
18847 C...Listing of erronoeus events, and first event of each type.
18848       IF(MERR.GE.1) NERR=NERR+1
18849       IF(NERR.GE.10) THEN
18850         WRITE(MSTU(11),1300)
18851         CALL LULIST(1)
18852         STOP
18853       ENDIF
18854       IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
18855         IF(MERR.GE.1) WRITE(MSTU(11),1400)
18856         CALL LULIST(1)
18857       ENDIF
18858   120 CONTINUE
18859
18860 C...List statistics for each process type.
18861       IF(MTEST.GE.1) CALL PYSTAT(1)
18862   130 CONTINUE
18863
18864 C...Summarize result of run.
18865       IF(NERR.EQ.0) WRITE(MSTU(11),1500)
18866       IF(NERR.GT.0) WRITE(MSTU(11),1600) NERR
18867       RETURN
18868
18869 C...Formats for information.
18870  1000 FORMAT(/5X,'Energy/momentum/flavour nonconservation for process',
18871      &I2,', event',I4)
18872  1100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
18873  1200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
18874      &'kinematics')
18875  1300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
18876      &'wrong.'/5X,'Execution will be stopped after listing of event.')
18877  1400 FORMAT(5X,'Faulty event follows:')
18878  1500 FORMAT(//5X,'End result of run: no errors detected.')
18879  1600 FORMAT(//5X,'End result of run:',I2,' errors detected.'/
18880      &5X,'This should not have happened!')
18881       END
18882
18883 C*********************************************************************
18884
18885       BLOCK DATA PYDATA
18886
18887 C...Give sensible default values to all status codes and parameters.
18888       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
18889       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18890       COMMON/PYINT1/MINT(400),VINT(400)
18891       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
18892       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18893       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
18894       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
18895       COMMON/PYINT6/PROC(0:200)
18896       CHARACTER PROC*28
18897       SAVE
18898
18899 C...Default values for allowed processes and kinematics constraints.
18900       DATA MSEL/1/
18901       DATA MSUB/200*0/
18902       DATA ((KFIN(I,J),J=-40,40),I=1,2)/40*1,0,80*1,0,40*1/
18903       DATA CKIN/
18904      &   2.0, -1.0,  0.0, -1.0,  1.0,  1.0, -10.,  10., -10.,  10.,
18905      1  -10.,  10., -10.,  10., -10.,  10., -1.0,  1.0, -1.0,  1.0,
18906      2   0.0,  1.0,  0.0,  1.0, -1.0,  1.0, -1.0,  1.0,   0.,   0.,
18907      3   2.0, -1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18908      4   160*0./
18909
18910 C...Default values for main switches and parameters. Reset information.
18911       DATA (MSTP(I),I=1,100)/
18912      &     3,    1,    2,    0,    0,    0,    0,    0,    0,    0,
18913      1     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18914      2     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18915      3     1,    2,    0,    0,    0,    2,    0,    0,    0,    0,
18916      4     1,    0,    3,    7,    1,    0,    0,    0,    0,    0,
18917      5     1,    1,   20,    6,    0,    0,    0,    0,    0,    0,
18918      6     1,    2,    2,    2,    1,    0,    0,    0,    0,    0,
18919      7     1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18920      8     1,    1,  100,    0,    0,    0,    0,    0,    0,    0,
18921      9     1,    4,    0,    0,    0,    0,    0,    0,    0,    0/
18922       DATA (MSTP(I),I=101,200)/
18923      &     1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18924      1     1,    1,    1,    0,    0,    0,    0,    0,    0,    0,
18925      2     0,    1,    2,    1,    1,   20,    0,    0,    0,    0,
18926      3     0,    4,    0,    1,    0,    0,    0,    0,    0,    0,
18927      4     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18928      5     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18929      6     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18930      7     0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18931      8     5,    3, 1989,   11,   24,    0,    0,    0,    0,    0,
18932      9     0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
18933       DATA (PARP(I),I=1,100)/
18934      &  0.25,  10.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18935      1    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18936      2    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18937      3   1.5,  2.0, 0.075,  0.,  0.2,   0.,   0.,   0.,   0.,   0.,
18938      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18939      5   1.0, 2.26, 1.E4, 1.E-4,  0.,   0.,   0.,   0.,   0.,   0.,
18940      6  0.25,  1.0, 0.25,  1.0,  2.0, 1.E-3, 4.0,   0.,   0.,   0.,
18941      7   4.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18942      8   1.6, 1.85,  0.5,  0.2, 0.33, 0.66,  0.7,  0.5,   0.,   0.,
18943      9  0.44, 0.44,  2.0,  1.0,   0.,  3.0,  1.0, 0.75,   0.,   0./
18944       DATA (PARP(I),I=101,200)/
18945      & -0.02,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18946      1   2.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18947      2   0.4,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18948      3  0.01,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18949      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18950      5    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18951      6    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18952      7    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18953      8    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,
18954      9    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0./
18955       DATA MSTI/200*0/
18956       DATA PARI/200*0./
18957       DATA MINT/400*0/
18958       DATA VINT/400*0./
18959
18960 C...Constants for the generation of the various processes.
18961       DATA (ISET(I),I=1,100)/
18962      &    1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,   -2,
18963      1    2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
18964      2   -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
18965      3    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
18966      4   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
18967      5   -1,   -1,    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
18968      6   -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,   -1,   -1,
18969      7    4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,   -2,
18970      8    2,    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18971      9    0,    0,    0,   -1,    0,    5,   -2,   -2,   -2,   -2/
18972       DATA (ISET(I),I=101,200)/
18973      &   -1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18974      1    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,   -2,
18975      2   -1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18976      3   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18977      4    1,    1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18978      5   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18979      6    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18980      7   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18981      8   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
18982      9   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2/
18983       DATA ((KFPR(I,J),J=1,2),I=1,50)/
18984      &   23,    0,   24,    0,   25,    0,   24,    0,   25,    0,
18985      &   24,    0,   23,    0,   25,    0,    0,    0,    0,    0,
18986      1    0,    0,    0,    0,   21,   21,   21,   22,   21,   23,
18987      1   21,   24,   21,   25,   22,   22,   22,   23,   22,   24,
18988      2   22,   25,   23,   23,   23,   24,   23,   25,   24,   24,
18989      2   24,   25,   25,   25,    0,   21,    0,   22,    0,   23,
18990      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
18991      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
18992      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
18993      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23/
18994       DATA ((KFPR(I,J),J=1,2),I=51,100)/
18995      5    0,   24,    0,   25,    0,    0,    0,    0,    0,    0,
18996      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18997      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
18998      6    0,    0,    0,    0,   21,   21,   24,   24,   22,   24,
18999      7   23,   23,   24,   24,   23,   24,   23,   25,   22,   22,
19000      7   23,   23,   24,   24,   24,   25,   25,   25,    0,    0,
19001      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19002      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19003      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19004      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
19005       DATA ((KFPR(I,J),J=1,2),I=101,150)/
19006      &   23,    0,   25,    0,    0,    0,    0,    0,    0,    0,
19007      &    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19008      1   21,   25,    0,   25,   21,   25,   22,   22,   22,   23,
19009      1   23,   23,   24,   24,    0,    0,    0,    0,    0,    0,
19010      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19011      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19012      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19013      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19014      4   32,    0,   37,    0,   40,    0,    0,    0,    0,    0,
19015      4    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
19016       DATA ((KFPR(I,J),J=1,2),I=151,200)/
19017      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19018      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19019      6    0,   37,    0,    0,    0,    0,    0,    0,    0,    0,
19020      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19021      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19022      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19023      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19024      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19025      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
19026      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
19027       DATA COEF/4000*0./
19028       DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
19029      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,
19030      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,
19031      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,
19032      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,
19033      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,
19034      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,
19035      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,
19036      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,
19037      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,
19038      & 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/
19039
19040 C...Character constants: name of processes.
19041       DATA PROC(0)/                    'All included subprocesses   '/
19042       DATA (PROC(I),I=1,20)/
19043      1'f + fb -> gamma*/Z0         ',  'f + fb'' -> W+/-             ',
19044      2'f + fb -> H0                ',  'gamma + W+/- -> W+/-        ',
19045      3'Z0 + Z0 -> H0               ',  'Z0 + W+/- -> W+/-           ',
19046      4'                            ',  'W+ + W- -> H0               ',
19047      5'                            ',  '                            ',
19048      6'f + f'' -> f + f''            ','f + fb -> f'' + fb''          ',
19049      7'f + fb -> g + g             ',  'f + fb -> g + gamma         ',
19050      8'f + fb -> g + Z0            ',  'f + fb'' -> g + W+/-         ',
19051      9'f + fb -> g + H0            ',  'f + fb -> gamma + gamma     ',
19052      &'f + fb -> gamma + Z0        ',  'f + fb'' -> gamma + W+/-     '/
19053       DATA (PROC(I),I=21,40)/
19054      1'f + fb -> gamma + H0        ',  'f + fb -> Z0 + Z0           ',
19055      2'f + fb'' -> Z0 + W+/-        ', 'f + fb -> Z0 + H0           ',
19056      3'f + fb -> W+ + W-           ',  'f + fb'' -> W+/- + H0        ',
19057      4'f + fb -> H0 + H0           ',  'f + g -> f + g              ',
19058      5'f + g -> f + gamma          ',  'f + g -> f + Z0             ',
19059      6'f + g -> f'' + W+/-          ', 'f + g -> f + H0             ',
19060      7'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',
19061      8'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ',
19062      9'f + gamma -> f + H0         ',  'f + Z0 -> f + g             ',
19063      &'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/
19064       DATA (PROC(I),I=41,60)/
19065      1'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + H0            ',
19066      2'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ',
19067      3'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ',
19068      4'f + W+/- -> f'' + H0         ', 'f + H0 -> f + g             ',
19069      5'f + H0 -> f + gamma         ',  'f + H0 -> f + Z0            ',
19070      6'f + H0 -> f'' + W+/-         ', 'f + H0 -> f + H0            ',
19071      7'g + g -> f + fb             ',  'g + gamma -> f + fb         ',
19072      8'g + Z0 -> f + fb            ',  'g + W+/- -> f + fb''         ',
19073      9'g + H0 -> f + fb            ',  'gamma + gamma -> f + fb     ',
19074      &'gamma + Z0 -> f + fb        ',  'gamma + W+/- -> f + fb''     '/
19075       DATA (PROC(I),I=61,80)/
19076      1'gamma + H0 -> f + fb        ',  'Z0 + Z0 -> f + fb           ',
19077      2'Z0 + W+/- -> f + fb''        ', 'Z0 + H0 -> f + fb           ',
19078      3'W+ + W- -> f + fb           ',  'W+/- + H0 -> f + fb''        ',
19079      4'H0 + H0 -> f + fb           ',  'g + g -> g + g              ',
19080      5'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> gamma + W+/-',
19081      6'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',
19082      7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + H0          ',
19083      8'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',
19084      9'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + H0 -> W+/- + H0      ',
19085      &'H0 + H0 -> H0 + H0          ',  '                            '/
19086       DATA (PROC(I),I=81,100)/
19087      1'q + qb -> Q + QB, massive   ',  'g + g -> Q + QB, massive    ',
19088      2'                            ',  '                            ',
19089      3'                            ',  '                            ',
19090      4'                            ',  '                            ',
19091      5'                            ',  '                            ',
19092      6'Elastic scattering          ',  'Single diffractive          ',
19093      7'Double diffractive          ',  'Central diffractive         ',
19094      8'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',
19095      9'                            ',  '                            ',
19096      &'                            ',  '                            '/
19097       DATA (PROC(I),I=101,120)/
19098      1'g + g -> gamma*/Z0          ',  'g + g -> H0                 ',
19099      2'                            ',  '                            ',
19100      3'                            ',  '                            ',
19101      4'                            ',  '                            ',
19102      5'                            ',  '                            ',
19103      6'f + fb -> g + H0            ',  'q + g -> q + H0             ',
19104      7'g + g -> g + H0             ',  'g + g -> gamma + gamma      ',
19105      8'g + g -> gamma + Z0         ',  'g + g -> Z0 + Z0            ',
19106      9'g + g -> W+ + W-            ',  '                            ',
19107      &'                            ',  '                            '/
19108       DATA (PROC(I),I=121,140)/
19109      1'g + g -> f + fb + H0        ',  '                            ',
19110      2'                            ',  '                            ',
19111      3'                            ',  '                            ',
19112      4'                            ',  '                            ',
19113      5'                            ',  '                            ',
19114      6'                            ',  '                            ',
19115      7'                            ',  '                            ',
19116      8'                            ',  '                            ',
19117      9'                            ',  '                            ',
19118      &'                            ',  '                            '/
19119       DATA (PROC(I),I=141,160)/
19120      1'f + fb -> gamma*/Z0/Z''0     ', 'f + fb'' -> H+/-             ',
19121      2'f + fb -> R                 ',  '                            ',
19122      3'                            ',  '                            ',
19123      4'                            ',  '                            ',
19124      5'                            ',  '                            ',
19125      6'                            ',  '                            ',
19126      7'                            ',  '                            ',
19127      8'                            ',  '                            ',
19128      9'                            ',  '                            ',
19129      &'                            ',  '                            '/
19130       DATA (PROC(I),I=161,180)/
19131      1'f + g -> f'' + H+/-          ', '                            ',
19132      2'                            ',  '                            ',
19133      3'                            ',  '                            ',
19134      4'                            ',  '                            ',
19135      5'                            ',  '                            ',
19136      6'                            ',  '                            ',
19137      7'                            ',  '                            ',
19138      8'                            ',  '                            ',
19139      9'                            ',  '                            ',
19140      &'                            ',  '                            '/
19141       DATA (PROC(I),I=181,200)/     20*'                            '/
19142
19143       END
19144
19145 C*********************************************************************
19146
19147       SUBROUTINE PYKCUT(MCUT)
19148
19149 C...Dummy routine, which the user can replace in order to make cuts on
19150 C...the kinematics on the parton level before the matrix elements are
19151 C...evaluated and the event is generated. The cross-section estimates
19152 C...will automatically take these cuts into account, so the given
19153 C...values are for the allowed phase space region only. MCUT=0 means
19154 C...that the event has passed the cuts, MCUT=1 that it has failed.
19155       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19156       SAVE
19157
19158       MCUT=0
19159
19160       RETURN
19161       END
19162
19163 C*********************************************************************
19164
19165       SUBROUTINE PYSTFE(KF,X,Q2,XPQ)
19166
19167 C...This is a dummy routine, where the user can introduce an interface
19168 C...to his own external structure function parametrization.
19169 C...Arguments in:
19170 C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge
19171 C...    conjugation for pbar, nbar or pi- is performed by PYSTFU.
19172 C...X : x value.
19173 C...Q2 : Q^2 value.
19174 C...Arguments out:
19175 C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,
19176 C...    except that gluon is placed in 0. Thus XPQ(0) = xg,
19177 C...    XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar,
19178 C...    XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar,
19179 C...    XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar.
19180 C...
19181 C...One such interface, to the Diemos, Ferroni, Longo, Martinelli
19182 C...proton structure functions, already comes with the package. What
19183 C...the user needs here is external files with the three routines
19184 C...FXG160, FXG260 and FXG360 of the authors above, plus the
19185 C...interpolation routine FINT, which is part of the CERN library
19186 C...KERNLIB package. To avoid problems with unresolved external
19187 C...references, the external calls are commented in the current
19188 C...version. To enable this option, remove the C* at the beginning
19189 C...of the relevant lines.
19190 C...
19191 C...Alternatively, the routine can be used as an interface to the
19192 C...structure function evolution program of Tung. This can be achieved
19193 C...by removing C* at the beginning of some of the lines below.
19194       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19195       SAVE /LUDAT1/
19196       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
19197       SAVE /LUDAT2/
19198       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19199       SAVE /PYPARS/
19200       DIMENSION XPQ(-6:6),XFDFLM(9)
19201       CHARACTER CHDFLM(9)*5,HEADER*40
19202       DATA CHDFLM/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',
19203      &'CBAR ','BBAR ','TBAR '/
19204       DATA HEADER/'Tung evolution package has been invoked'/
19205       DATA INIT/0/
19206       KF=KF
19207       HEADER=HEADER
19208       CHDFLM(1)=CHDFLM(1)
19209 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
19210 C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95.
19211       IF(MSTP(51).GE.11.AND.MSTP(51).LE.13.AND.MSTP(52).LE.1) THEN
19212         XDFLM=MAX(0.51E-4,X)
19213         Q2DFLM=MAX(10.,MIN(1E8,Q2))
19214         IF(MSTP(52).EQ.0) Q2DFLM=10.
19215         DO 100 J=1,9
19216         IF(MSTP(52).EQ.1.AND.J.EQ.9) THEN
19217           Q2DFLM=Q2DFLM*(40./PMAS(6,1))**2
19218           Q2DFLM=MAX(10.,MIN(1E8,Q2))
19219         ENDIF
19220         XFDFLM(J)=0.
19221 C...Remove C* on following three lines to enable the DFLM options.
19222 C*      IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19223 C*      IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19224 C*      IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
19225   100   CONTINUE
19226         IF(X.LT.0.51E-4.AND.ABS(PARP(51)-1.).GT.0.01) THEN
19227           CXS=(0.51E-4/X)**(PARP(51)-1.)
19228           DO 110 J=1,7
19229   110     XFDFLM(J)=XFDFLM(J)*CXS
19230         ENDIF
19231         XPQ(0)=XFDFLM(3)
19232         XPQ(1)=XFDFLM(2)+XFDFLM(5)
19233         XPQ(2)=XFDFLM(1)+XFDFLM(5)
19234         XPQ(3)=XFDFLM(6)
19235         XPQ(4)=XFDFLM(7)
19236         XPQ(5)=XFDFLM(8)
19237         XPQ(6)=XFDFLM(9)
19238         XPQ(-1)=XFDFLM(5)
19239         XPQ(-2)=XFDFLM(5)
19240         XPQ(-3)=XFDFLM(6)
19241         XPQ(-4)=XFDFLM(7)
19242         XPQ(-5)=XFDFLM(8)
19243         XPQ(-6)=XFDFLM(9)
19244
19245 C...Proton structure function evolution from Wu-Ki Tung: parton
19246 C...distribution functions incorporating heavy quark mass effects.
19247 C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.
19248       ELSE
19249         IF(INIT.EQ.0) THEN
19250           I1=0
19251           IF(MSTP(52).EQ.4) I1=1
19252           IHDRN=1
19253           NU=MSTP(53)
19254           I2=MSTP(51)
19255           IF(MSTP(51).GE.11) I2=MSTP(51)-3
19256           I3=0
19257           IF(MSTP(52).EQ.3) I3=1
19258
19259 C...Convert to Lambda in CWZ scheme (approximately linear relation).
19260           ALAM=0.75*PARP(1)
19261           TPMS=PMAS(6,1)
19262           QINI=PARP(52)
19263           QMAX=PARP(53)
19264           XMIN=PARP(54)
19265
19266 C...Initialize evolution (perform calculation or read results from
19267 C...file).
19268 C...Remove C* on following two lines to enable Tung initialization.
19269 C*        CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,
19270 C*   &    I2,I3,IRET,IRR)
19271           INIT=1
19272         ENDIF
19273
19274 C...Put into output array.
19275         Q=SQRT(Q2)
19276         DO 200 I=-6,6
19277         FIXQ=0.
19278 C...Remove C* on following line to enable structure function call.
19279 C*      FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR))
19280   200   XPQ(I)=X*FIXQ
19281
19282 C...Change order of u and d quarks from Tung to PYTHIA convention.
19283         XPS=XPQ(1)
19284         XPQ(1)=XPQ(2)
19285         XPQ(2)=XPS
19286         XPS=XPQ(-1)
19287         XPQ(-1)=XPQ(-2)
19288         XPQ(-2)=XPS
19289       ENDIF
19290
19291       RETURN
19292       END