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.