Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2023-10-25 09:48:33

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.