Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2024-04-06 12:13:47

0001 C
0002 C
0003 C
0004 C     Modified for HIJING program
0005 c
0006 c    modification July 22, 1997  In pyremnn put an upper limit
0007 c     on the total pt kick the parton can accumulate via multiple
0008 C     scattering. Set the upper limit to be the sqrt(s)/2,
0009 c     this is fix cronin bug for Pb+Pb events at SPS energy.
0010 c
0011 C
0012 C Last modification Oct. 1993 to comply with non-vax
0013 C machines' compiler 
0014 C
0015 C
0016       SUBROUTINE LU1ENT(IP,KF,PE,THE,PHI)   
0017     
0018 C...Purpose: to store one parton/particle in commonblock LUJETS.    
0019       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5) 
0020       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0021       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0022       SAVE
0023     
0024 C...Standard checks.    
0025       MSTU(28)=0    
0026       IF(MSTU(12).GE.1) CALL LULIST(0)  
0027       IPA=MAX(1,IABS(IP))   
0028       IF(IPA.GT.MSTU(4)) CALL LUERRM(21,    
0029      &'(LU1ENT:) writing outside LUJETS memory')    
0030       KC=LUCOMP(KF) 
0031       IF(KC.EQ.0) CALL LUERRM(12,'(LU1ENT:) unknown flavour code')  
0032     
0033 C...Find mass. Reset K, P and V vectors.    
0034       PM=0. 
0035       IF(MSTU(10).EQ.1) PM=P(IPA,5) 
0036       IF(MSTU(10).GE.2) PM=ULMASS(KF)   
0037       DO 100 J=1,5  
0038       K(IPA,J)=0    
0039       P(IPA,J)=0.   
0040   100 V(IPA,J)=0.   
0041     
0042 C...Store parton/particle in K and P vectors.   
0043       K(IPA,1)=1    
0044       IF(IP.LT.0) K(IPA,1)=2    
0045       K(IPA,2)=KF   
0046       P(IPA,5)=PM   
0047       P(IPA,4)=MAX(PE,PM)   
0048       PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)  
0049       P(IPA,1)=PA*SIN(THE)*COS(PHI) 
0050       P(IPA,2)=PA*SIN(THE)*SIN(PHI) 
0051       P(IPA,3)=PA*COS(THE)  
0052     
0053 C...Set N. Optionally fragment/decay.   
0054       N=IPA 
0055       IF(IP.EQ.0) CALL LUEXEC   
0056     
0057       RETURN    
0058       END   
0059     
0060 C*********************************************************************  
0061     
0062       SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)    
0063     
0064 C...Purpose: to store two partons/particles in their CM frame,  
0065 C...with the first along the +z axis.   
0066       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0067       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0068       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0069       SAVE  
0070     
0071 C...Standard checks.    
0072       MSTU(28)=0    
0073       IF(MSTU(12).GE.1) CALL LULIST(0)  
0074       IPA=MAX(1,IABS(IP))   
0075       IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,  
0076      &'(LU2ENT:) writing outside LUJETS memory')    
0077       KC1=LUCOMP(KF1)   
0078       KC2=LUCOMP(KF2)   
0079       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,  
0080      &'(LU2ENT:) unknown flavour code') 
0081     
0082 C...Find masses. Reset K, P and V vectors.  
0083       PM1=0.    
0084       IF(MSTU(10).EQ.1) PM1=P(IPA,5)    
0085       IF(MSTU(10).GE.2) PM1=ULMASS(KF1) 
0086       PM2=0.    
0087       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)  
0088       IF(MSTU(10).GE.2) PM2=ULMASS(KF2) 
0089       DO 100 I=IPA,IPA+1    
0090       DO 100 J=1,5  
0091       K(I,J)=0  
0092       P(I,J)=0. 
0093   100 V(I,J)=0. 
0094     
0095 C...Check flavours. 
0096       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)  
0097       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)  
0098       IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,  
0099      &'(LU2ENT:) unphysical flavour combination')   
0100       K(IPA,2)=KF1  
0101       K(IPA+1,2)=KF2    
0102     
0103 C...Store partons/particles in K vectors for normal case.   
0104       IF(IP.GE.0) THEN  
0105         K(IPA,1)=1  
0106         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2    
0107         K(IPA+1,1)=1    
0108     
0109 C...Store partons in K vectors for parton shower evolution. 
0110       ELSE  
0111         IF(KQ1.EQ.0.OR.KQ2.EQ.0) CALL LUERRM(2, 
0112      &  '(LU2ENT:) requested flavours can not develop parton shower')   
0113         K(IPA,1)=3  
0114         K(IPA+1,1)=3    
0115         K(IPA,4)=MSTU(5)*(IPA+1)    
0116         K(IPA,5)=K(IPA,4)   
0117         K(IPA+1,4)=MSTU(5)*IPA  
0118         K(IPA+1,5)=K(IPA+1,4)   
0119       ENDIF 
0120     
0121 C...Check kinematics and store partons/particles in P vectors.  
0122       IF(PECM.LE.PM1+PM2) CALL LUERRM(13,   
0123      &'(LU2ENT:) energy smaller than sum of masses')    
0124       PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/  
0125      &(2.*PECM) 
0126       P(IPA,3)=PA   
0127       P(IPA,4)=SQRT(PM1**2+PA**2)   
0128       P(IPA,5)=PM1  
0129       P(IPA+1,3)=-PA    
0130       P(IPA+1,4)=SQRT(PM2**2+PA**2) 
0131       P(IPA+1,5)=PM2    
0132     
0133 C...Set N. Optionally fragment/decay.   
0134       N=IPA+1   
0135       IF(IP.EQ.0) CALL LUEXEC   
0136     
0137       RETURN    
0138       END   
0139     
0140 C*********************************************************************  
0141     
0142       SUBROUTINE LU3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)  
0143     
0144 C...Purpose: to store three partons or particles in their CM frame, 
0145 C...with the first along the +z axis and the third in the (x,z) 
0146 C...plane with x > 0.   
0147       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0148       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0149       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0150       SAVE  
0151     
0152 C...Standard checks.    
0153       MSTU(28)=0    
0154       IF(MSTU(12).GE.1) CALL LULIST(0)  
0155       IPA=MAX(1,IABS(IP))   
0156       IF(IPA.GT.MSTU(4)-2) CALL LUERRM(21,  
0157      &'(LU3ENT:) writing outside LUJETS memory')    
0158       KC1=LUCOMP(KF1)   
0159       KC2=LUCOMP(KF2)   
0160       KC3=LUCOMP(KF3)   
0161       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LUERRM(12,  
0162      &'(LU3ENT:) unknown flavour code') 
0163     
0164 C...Find masses. Reset K, P and V vectors.  
0165       PM1=0.    
0166       IF(MSTU(10).EQ.1) PM1=P(IPA,5)    
0167       IF(MSTU(10).GE.2) PM1=ULMASS(KF1) 
0168       PM2=0.    
0169       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)  
0170       IF(MSTU(10).GE.2) PM2=ULMASS(KF2) 
0171       PM3=0.    
0172       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)  
0173       IF(MSTU(10).GE.2) PM3=ULMASS(KF3) 
0174       DO 100 I=IPA,IPA+2    
0175       DO 100 J=1,5  
0176       K(I,J)=0  
0177       P(I,J)=0. 
0178   100 V(I,J)=0. 
0179     
0180 C...Check flavours. 
0181       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)  
0182       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)  
0183       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)  
0184       IF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN   
0185       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.KQ1+KQ3.EQ.4))  
0186      &THEN  
0187       ELSE  
0188         CALL LUERRM(2,'(LU3ENT:) unphysical flavour combination')   
0189       ENDIF 
0190       K(IPA,2)=KF1  
0191       K(IPA+1,2)=KF2    
0192       K(IPA+2,2)=KF3    
0193     
0194 C...Store partons/particles in K vectors for normal case.   
0195       IF(IP.GE.0) THEN  
0196         K(IPA,1)=1  
0197         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2  
0198         K(IPA+1,1)=1    
0199         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2  
0200         K(IPA+2,1)=1    
0201     
0202 C...Store partons in K vectors for parton shower evolution. 
0203       ELSE  
0204         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0) CALL LUERRM(2, 
0205      &  '(LU3ENT:) requested flavours can not develop parton shower')   
0206         K(IPA,1)=3  
0207         K(IPA+1,1)=3    
0208         K(IPA+2,1)=3    
0209         KCS=4   
0210         IF(KQ1.EQ.-1) KCS=5 
0211         K(IPA,KCS)=MSTU(5)*(IPA+1)  
0212         K(IPA,9-KCS)=MSTU(5)*(IPA+2)    
0213         K(IPA+1,KCS)=MSTU(5)*(IPA+2)    
0214         K(IPA+1,9-KCS)=MSTU(5)*IPA  
0215         K(IPA+2,KCS)=MSTU(5)*IPA    
0216         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)  
0217       ENDIF 
0218     
0219 C...Check kinematics.   
0220       MKERR=0   
0221       IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.   
0222      &0.5*X3*PECM.LE.PM3) MKERR=1   
0223       PA1=SQRT(MAX(0.,(0.5*X1*PECM)**2-PM1**2)) 
0224       PA2=SQRT(MAX(0.,(0.5*(2.-X1-X3)*PECM)**2-PM2**2)) 
0225       PA3=SQRT(MAX(0.,(0.5*X3*PECM)**2-PM3**2)) 
0226       CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2) 
0227       CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3) 
0228       IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1    
0229       CTHE3=MAX(-1.,MIN(1.,CTHE3))  
0230       IF(MKERR.NE.0) CALL LUERRM(13,    
0231      &'(LU3ENT:) unphysical kinematical variable setup')    
0232     
0233 C...Store partons/particles in P vectors.   
0234       P(IPA,3)=PA1  
0235       P(IPA,4)=SQRT(PA1**2+PM1**2)  
0236       P(IPA,5)=PM1  
0237       P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)  
0238       P(IPA+2,3)=PA3*CTHE3  
0239       P(IPA+2,4)=SQRT(PA3**2+PM3**2)    
0240       P(IPA+2,5)=PM3    
0241       P(IPA+1,1)=-P(IPA+2,1)    
0242       P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)   
0243       P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)   
0244       P(IPA+1,5)=PM2    
0245     
0246 C...Set N. Optionally fragment/decay.   
0247       N=IPA+2   
0248       IF(IP.EQ.0) CALL LUEXEC   
0249     
0250       RETURN    
0251       END   
0252     
0253 C*********************************************************************  
0254     
0255       SUBROUTINE LU4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)   
0256     
0257 C...Purpose: to store four partons or particles in their CM frame, with 
0258 C...the first along the +z axis, the last in the xz plane with x > 0    
0259 C...and the second having y < 0 and y > 0 with equal probability.   
0260       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0261       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0262       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0263       SAVE  
0264     
0265 C...Standard checks.    
0266       MSTU(28)=0    
0267       IF(MSTU(12).GE.1) CALL LULIST(0)  
0268       IPA=MAX(1,IABS(IP))   
0269       IF(IPA.GT.MSTU(4)-3) CALL LUERRM(21,  
0270      &'(LU4ENT:) writing outside LUJETS momory')    
0271       KC1=LUCOMP(KF1)   
0272       KC2=LUCOMP(KF2)   
0273       KC3=LUCOMP(KF3)   
0274       KC4=LUCOMP(KF4)   
0275       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LUERRM(12,  
0276      &'(LU4ENT:) unknown flavour code') 
0277     
0278 C...Find masses. Reset K, P and V vectors.  
0279       PM1=0.    
0280       IF(MSTU(10).EQ.1) PM1=P(IPA,5)    
0281       IF(MSTU(10).GE.2) PM1=ULMASS(KF1) 
0282       PM2=0.    
0283       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)  
0284       IF(MSTU(10).GE.2) PM2=ULMASS(KF2) 
0285       PM3=0.    
0286       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)  
0287       IF(MSTU(10).GE.2) PM3=ULMASS(KF3) 
0288       PM4=0.    
0289       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)  
0290       IF(MSTU(10).GE.2) PM4=ULMASS(KF4) 
0291       DO 100 I=IPA,IPA+3    
0292       DO 100 J=1,5  
0293       K(I,J)=0  
0294       P(I,J)=0. 
0295   100 V(I,J)=0. 
0296     
0297 C...Check flavours. 
0298       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)  
0299       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)  
0300       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)  
0301       KQ4=KCHG(KC4,2)*ISIGN(1,KF4)  
0302       IF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN  
0303       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.   
0304      &KQ1+KQ4.EQ.4)) THEN   
0305       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)  
0306      &THEN  
0307       ELSE  
0308         CALL LUERRM(2,'(LU4ENT:) unphysical flavour combination')   
0309       ENDIF 
0310       K(IPA,2)=KF1  
0311       K(IPA+1,2)=KF2    
0312       K(IPA+2,2)=KF3    
0313       K(IPA+3,2)=KF4    
0314     
0315 C...Store partons/particles in K vectors for normal case.   
0316       IF(IP.GE.0) THEN  
0317         K(IPA,1)=1  
0318         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2  
0319         K(IPA+1,1)=1    
0320         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))    
0321      &  K(IPA+1,1)=2    
0322         K(IPA+2,1)=1    
0323         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2  
0324         K(IPA+3,1)=1    
0325     
0326 C...Store partons for parton shower evolution from q-g-g-qbar or    
0327 C...g-g-g-g event.  
0328       ELSEIF(KQ1+KQ2.NE.0) THEN 
0329         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0.OR.KQ4.EQ.0) CALL LUERRM(2, 
0330      &  '(LU4ENT:) requested flavours can not develop parton shower')   
0331         K(IPA,1)=3  
0332         K(IPA+1,1)=3    
0333         K(IPA+2,1)=3    
0334         K(IPA+3,1)=3    
0335         KCS=4   
0336         IF(KQ1.EQ.-1) KCS=5 
0337         K(IPA,KCS)=MSTU(5)*(IPA+1)  
0338         K(IPA,9-KCS)=MSTU(5)*(IPA+3)    
0339         K(IPA+1,KCS)=MSTU(5)*(IPA+2)    
0340         K(IPA+1,9-KCS)=MSTU(5)*IPA  
0341         K(IPA+2,KCS)=MSTU(5)*(IPA+3)    
0342         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)  
0343         K(IPA+3,KCS)=MSTU(5)*IPA    
0344         K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)  
0345     
0346 C...Store partons for parton shower evolution from q-qbar-q-qbar event. 
0347       ELSE  
0348         IF(KQ1.EQ.0.OR.KQ2.EQ.0.OR.KQ3.EQ.0.OR.KQ4.EQ.0) CALL LUERRM(2, 
0349      &  '(LU4ENT:) requested flavours can not develop parton shower')   
0350         K(IPA,1)=3  
0351         K(IPA+1,1)=3    
0352         K(IPA+2,1)=3    
0353         K(IPA+3,1)=3    
0354         K(IPA,4)=MSTU(5)*(IPA+1)    
0355         K(IPA,5)=K(IPA,4)   
0356         K(IPA+1,4)=MSTU(5)*IPA  
0357         K(IPA+1,5)=K(IPA+1,4)   
0358         K(IPA+2,4)=MSTU(5)*(IPA+3)  
0359         K(IPA+2,5)=K(IPA+2,4)   
0360         K(IPA+3,4)=MSTU(5)*(IPA+2)  
0361         K(IPA+3,5)=K(IPA+3,4)   
0362       ENDIF 
0363     
0364 C...Check kinematics.   
0365       MKERR=0   
0366       IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)* 
0367      &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1    
0368       PA1=SQRT(MAX(0.,(0.5*X1*PECM)**2-PM1**2)) 
0369       PA2=SQRT(MAX(0.,(0.5*X2*PECM)**2-PM2**2)) 
0370       PA3=SQRT(MAX(0.,(0.5*(2.-X1-X2-X4)*PECM)**2-PM3**2))  
0371       PA4=SQRT(MAX(0.,(0.5*X4*PECM)**2-PM4**2)) 
0372       X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2 
0373       CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4) 
0374       IF(ABS(CTHE4).GE.1.002) MKERR=1   
0375       CTHE4=MAX(-1.,MIN(1.,CTHE4))  
0376       STHE4=SQRT(1.-CTHE4**2)   
0377       CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2) 
0378       IF(ABS(CTHE2).GE.1.002) MKERR=1   
0379       CTHE2=MAX(-1.,MIN(1.,CTHE2))  
0380       STHE2=SQRT(1.-CTHE2**2)   
0381       CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/    
0382      &(4.*PA2*STHE2*PA4*STHE4)  
0383       IF(ABS(CPHI2).GE.1.05) MKERR=1    
0384       CPHI2=MAX(-1.,MIN(1.,CPHI2))  
0385       IF(MKERR.EQ.1) CALL LUERRM(13,    
0386      &'(LU4ENT:) unphysical kinematical variable setup')    
0387     
0388 C...Store partons/particles in P vectors.   
0389       P(IPA,3)=PA1  
0390       P(IPA,4)=SQRT(PA1**2+PM1**2)  
0391       P(IPA,5)=PM1  
0392       P(IPA+3,1)=PA4*STHE4  
0393       P(IPA+3,3)=PA4*CTHE4  
0394       P(IPA+3,4)=SQRT(PA4**2+PM4**2)    
0395       P(IPA+3,5)=PM4    
0396       P(IPA+1,1)=PA2*STHE2*CPHI2    
0397       P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLU(0)+0.5) 
0398       P(IPA+1,3)=PA2*CTHE2  
0399       P(IPA+1,4)=SQRT(PA2**2+PM2**2)    
0400       P(IPA+1,5)=PM2    
0401       P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1) 
0402       P(IPA+2,2)=-P(IPA+1,2)    
0403       P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)    
0404       P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2) 
0405       P(IPA+2,5)=PM3    
0406     
0407 C...Set N. Optionally fragment/decay.   
0408       N=IPA+3   
0409       IF(IP.EQ.0) CALL LUEXEC   
0410     
0411       RETURN    
0412       END   
0413     
0414 C*********************************************************************  
0415     
0416       SUBROUTINE LUJOIN(NJOIN,IJOIN)    
0417     
0418 C...Purpose: to connect a sequence of partons with colour flow indices, 
0419 C...as required for subsequent shower evolution (or other operations).  
0420       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0421       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0422       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0423       DIMENSION IJOIN(*)    
0424       SAVE
0425     
0426 C...Check that partons are of right types to be connected.  
0427       IF(NJOIN.LT.2) GOTO 120   
0428       KQSUM=0   
0429       DO 100 IJN=1,NJOIN    
0430       I=IJOIN(IJN)  
0431       IF(I.LE.0.OR.I.GT.N) GOTO 120 
0432       IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120   
0433       KC=LUCOMP(K(I,2)) 
0434       IF(KC.EQ.0) GOTO 120  
0435       KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
0436       IF(KQ.EQ.0) GOTO 120  
0437       IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120    
0438       IF(KQ.NE.2) KQSUM=KQSUM+KQ    
0439   100 IF(IJN.EQ.1) KQS=KQ   
0440       IF(KQSUM.NE.0) GOTO 120   
0441     
0442 C...Connect the partons sequentially (closing for gluon loop).  
0443       KCS=(9-KQS)/2 
0444       IF(KQS.EQ.2) KCS=INT(4.5+RLU(0))  
0445       DO 110 IJN=1,NJOIN    
0446       I=IJOIN(IJN)  
0447       K(I,1)=3  
0448       IF(IJN.NE.1) IP=IJOIN(IJN-1)  
0449       IF(IJN.EQ.1) IP=IJOIN(NJOIN)  
0450       IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)  
0451       IF(IJN.EQ.NJOIN) IN=IJOIN(1)  
0452       K(I,KCS)=MSTU(5)*IN   
0453       K(I,9-KCS)=MSTU(5)*IP 
0454       IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0    
0455   110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0  
0456     
0457 C...Error exit: no action taken.    
0458       RETURN    
0459   120 CALL LUERRM(12,   
0460      &'(LUJOIN:) given entries can not be joined by one string')    
0461     
0462       RETURN    
0463       END   
0464     
0465 C*********************************************************************  
0466     
0467       SUBROUTINE LUGIVE(CHIN)   
0468     
0469 C...Purpose: to set values of commonblock variables.    
0470       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0471       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0472       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0473       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
0474       COMMON/LUDAT4/CHAF(500)   
0475       CHARACTER CHAF*8  
0476       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,   
0477      &CHNAM*4,CHVAR(17)*4,CHALP(2)*26,CHIND*8,CHINI*10,CHINR*16 
0478       SAVE
0479       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',    
0480      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/  
0481       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',  
0482      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
0483     
0484 C...Length of character variable. Subdivide it into instructions.   
0485       IF(MSTU(12).GE.1) CALL LULIST(0)  
0486       CHBIT=CHIN//' '   
0487       LBIT=101  
0488   100 LBIT=LBIT-1   
0489       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100  
0490       LTOT=0    
0491       DO 110 LCOM=1,LBIT    
0492       IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110  
0493       LTOT=LTOT+1   
0494       CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM) 
0495   110 CONTINUE  
0496       LLOW=0    
0497   120 LHIG=LLOW+1   
0498   130 LHIG=LHIG+1   
0499       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130 
0500       LBIT=LHIG-LLOW-1  
0501       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)    
0502     
0503 C...Identify commonblock variable.  
0504       LNAM=1    
0505   140 LNAM=LNAM+1   
0506       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.   
0507      &LNAM.LE.4) GOTO 140   
0508       CHNAM=CHBIT(1:LNAM-1)//' '    
0509       DO 150 LCOM=1,LNAM-1  
0510       DO 150 LALP=1,26  
0511   150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)= 
0512      &CHALP(2)(LALP:LALP)   
0513       IVAR=0    
0514       DO 160 IV=1,17    
0515   160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV    
0516       IF(IVAR.EQ.0) THEN    
0517         CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)   
0518         LLOW=LHIG   
0519         IF(LLOW.LT.LTOT) GOTO 120   
0520         RETURN  
0521       ENDIF 
0522     
0523 C...Identify any indices.   
0524       I=0   
0525       J=0   
0526       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN  
0527         LIND=LNAM   
0528   170   LIND=LIND+1 
0529         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170    
0530         CHIND=' '   
0531         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').    
0532      &  AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN 
0533           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)    
0534           READ(CHIND,'(I8)') I1 
0535           I=LUCOMP(I1)  
0536         ELSE    
0537           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)    
0538           READ(CHIND,'(I8)') I  
0539         ENDIF   
0540         LNAM=LIND   
0541         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 
0542       ENDIF 
0543       IF(CHBIT(LNAM:LNAM).EQ.',') THEN  
0544         LIND=LNAM   
0545   180   LIND=LIND+1 
0546         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180    
0547         CHIND=' '   
0548         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)  
0549         READ(CHIND,'(I8)') J    
0550         LNAM=LIND+1 
0551       ENDIF 
0552     
0553 C...Check that indices allowed and save old value.  
0554       IERR=1    
0555       IF(CHBIT(LNAM:LNAM).NE.'=') GOTO 190  
0556       IF(IVAR.EQ.1) THEN    
0557         IF(I.NE.0.OR.J.NE.0) GOTO 190   
0558         IOLD=N  
0559       ELSEIF(IVAR.EQ.2) THEN    
0560         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0561         IOLD=K(I,J) 
0562       ELSEIF(IVAR.EQ.3) THEN    
0563         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0564         ROLD=P(I,J) 
0565       ELSEIF(IVAR.EQ.4) THEN    
0566         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0567         ROLD=V(I,J) 
0568       ELSEIF(IVAR.EQ.5) THEN    
0569         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0570         IOLD=MSTU(I)    
0571       ELSEIF(IVAR.EQ.6) THEN    
0572         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0573         ROLD=PARU(I)    
0574       ELSEIF(IVAR.EQ.7) THEN    
0575         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0576         IOLD=MSTJ(I)    
0577       ELSEIF(IVAR.EQ.8) THEN    
0578         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0579         ROLD=PARJ(I)    
0580       ELSEIF(IVAR.EQ.9) THEN    
0581         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190 
0582         IOLD=KCHG(I,J)  
0583       ELSEIF(IVAR.EQ.10) THEN   
0584         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.4) GOTO 190 
0585         ROLD=PMAS(I,J)  
0586       ELSEIF(IVAR.EQ.11) THEN   
0587         IF(I.LT.1.OR.I.GT.2000.OR.J.NE.0) GOTO 190  
0588         ROLD=PARF(I)    
0589       ELSEIF(IVAR.EQ.12) THEN   
0590         IF(I.LT.1.OR.I.GT.4.OR.J.LT.1.OR.J.GT.4) GOTO 190   
0591         ROLD=VCKM(I,J)  
0592       ELSEIF(IVAR.EQ.13) THEN   
0593         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190 
0594         IOLD=MDCY(I,J)  
0595       ELSEIF(IVAR.EQ.14) THEN   
0596         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.2) GOTO 190 
0597         IOLD=MDME(I,J)  
0598       ELSEIF(IVAR.EQ.15) THEN   
0599         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.NE.0) GOTO 190   
0600         ROLD=BRAT(I)    
0601       ELSEIF(IVAR.EQ.16) THEN   
0602         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0603         IOLD=KFDP(I,J)  
0604       ELSEIF(IVAR.EQ.17) THEN   
0605         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.NE.0) GOTO 190   
0606         CHOLD=CHAF(I)   
0607       ENDIF 
0608       IERR=0    
0609   190 IF(IERR.EQ.1) THEN    
0610         CALL LUERRM(18,'(LUGIVE:) unallowed indices for '// 
0611      &  CHBIT(1:LNAM-1))    
0612         LLOW=LHIG   
0613         IF(LLOW.LT.LTOT) GOTO 120   
0614         RETURN  
0615       ENDIF 
0616     
0617 C...Print current value of variable. Loop back. 
0618       IF(LNAM.GE.LBIT) THEN 
0619         CHBIT(LNAM:14)=' '  
0620         CHBIT(15:60)=' has the value                                '   
0621         IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR. 
0622      &  IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN   
0623           WRITE(CHBIT(51:60),'(I10)') IOLD  
0624         ELSEIF(IVAR.NE.17) THEN 
0625           WRITE(CHBIT(47:60),'(F14.5)') ROLD    
0626         ELSE    
0627           CHBIT(53:60)=CHOLD    
0628         ENDIF   
0629         IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)  
0630         LLOW=LHIG   
0631         IF(LLOW.LT.LTOT) GOTO 120   
0632         RETURN  
0633       ENDIF 
0634     
0635 C...Read in new variable value. 
0636       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.   
0637      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN 
0638         CHINI=' '   
0639         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)   
0640         READ(CHINI,'(I10)') INEW    
0641       ELSEIF(IVAR.NE.17) THEN   
0642         CHINR=' '   
0643         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)   
0644         READ(CHINR,'(F16.2)') RNEW  
0645       ELSE  
0646         CHNEW=CHBIT(LNAM+1:LBIT)//' '   
0647       ENDIF 
0648     
0649 C...Store new variable value.   
0650       IF(IVAR.EQ.1) THEN    
0651         N=INEW  
0652       ELSEIF(IVAR.EQ.2) THEN    
0653         K(I,J)=INEW 
0654       ELSEIF(IVAR.EQ.3) THEN    
0655         P(I,J)=RNEW 
0656       ELSEIF(IVAR.EQ.4) THEN    
0657         V(I,J)=RNEW 
0658       ELSEIF(IVAR.EQ.5) THEN    
0659         MSTU(I)=INEW    
0660       ELSEIF(IVAR.EQ.6) THEN    
0661         PARU(I)=RNEW    
0662       ELSEIF(IVAR.EQ.7) THEN    
0663         MSTJ(I)=INEW    
0664       ELSEIF(IVAR.EQ.8) THEN    
0665         PARJ(I)=RNEW    
0666       ELSEIF(IVAR.EQ.9) THEN    
0667         KCHG(I,J)=INEW  
0668       ELSEIF(IVAR.EQ.10) THEN   
0669         PMAS(I,J)=RNEW  
0670       ELSEIF(IVAR.EQ.11) THEN   
0671         PARF(I)=RNEW    
0672       ELSEIF(IVAR.EQ.12) THEN   
0673         VCKM(I,J)=RNEW  
0674       ELSEIF(IVAR.EQ.13) THEN   
0675         MDCY(I,J)=INEW  
0676       ELSEIF(IVAR.EQ.14) THEN   
0677         MDME(I,J)=INEW  
0678       ELSEIF(IVAR.EQ.15) THEN   
0679         BRAT(I)=RNEW    
0680       ELSEIF(IVAR.EQ.16) THEN   
0681         KFDP(I,J)=INEW  
0682       ELSEIF(IVAR.EQ.17) THEN   
0683         CHAF(I)=CHNEW   
0684       ENDIF 
0685     
0686 C...Write old and new value. Loop back. 
0687       CHBIT(LNAM:14)=' '    
0688       CHBIT(15:60)=' changed from                to               ' 
0689       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.   
0690      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN 
0691         WRITE(CHBIT(33:42),'(I10)') IOLD    
0692         WRITE(CHBIT(51:60),'(I10)') INEW    
0693       ELSEIF(IVAR.NE.17) THEN   
0694         WRITE(CHBIT(29:42),'(F14.5)') ROLD  
0695         WRITE(CHBIT(47:60),'(F14.5)') RNEW  
0696       ELSE  
0697         CHBIT(35:42)=CHOLD  
0698         CHBIT(53:60)=CHNEW  
0699       ENDIF 
0700       IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)    
0701       LLOW=LHIG 
0702       IF(LLOW.LT.LTOT) GOTO 120 
0703     
0704 C...Format statement for output on unit MSTU(11) (by default 6).    
0705  1000 FORMAT(5X,A60)    
0706     
0707       RETURN    
0708       END   
0709     
0710 C*********************************************************************  
0711     
0712       SUBROUTINE LUEXEC 
0713     
0714 C...Purpose: to administrate the fragmentation and decay chain. 
0715       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0716       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0717       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0718       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
0719       DIMENSION PS(2,6) 
0720       SAVE
0721     
0722 C...Initialize and reset.   
0723       MSTU(24)=0    
0724       IF(MSTU(12).GE.1) CALL LULIST(0)  
0725       MSTU(31)=MSTU(31)+1   
0726       MSTU(1)=0 
0727       MSTU(2)=0 
0728       MSTU(3)=0 
0729       MCONS=1   
0730     
0731 C...Sum up momentum, energy and charge for starting entries.    
0732       NSAV=N    
0733       DO 100 I=1,2  
0734       DO 100 J=1,6  
0735   100 PS(I,J)=0.    
0736       DO 120 I=1,N  
0737       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120  
0738       DO 110 J=1,4  
0739   110 PS(1,J)=PS(1,J)+P(I,J)    
0740       PS(1,6)=PS(1,6)+LUCHGE(K(I,2))    
0741   120 CONTINUE  
0742       PARU(21)=PS(1,4)  
0743     
0744 C...Prepare system for subsequent fragmentation/decay.  
0745       CALL LUPREP(0)    
0746     
0747 C...Loop through jet fragmentation and particle decays. 
0748       MBE=0 
0749   130 MBE=MBE+1 
0750       IP=0  
0751   140 IP=IP+1   
0752       KC=0  
0753       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2)) 
0754       IF(KC.EQ.0) THEN  
0755     
0756 C...Particle decay if unstable and allowed. Save long-lived particle    
0757 C...decays until second pass after Bose-Einstein effects.   
0758       ELSEIF(KCHG(KC,2).EQ.0) THEN  
0759         IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE. 
0760      &  EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))    
0761      &  CALL LUDECY(IP) 
0762     
0763 C...Decay products may develop a shower.    
0764         IF(MSTJ(92).GT.0) THEN  
0765           IP1=MSTJ(92)  
0766           QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,  
0767      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))    
0768           CALL LUSHOW(IP1,IP1+1,QMAX)   
0769           CALL LUPREP(IP1)  
0770           MSTJ(92)=0    
0771         ELSEIF(MSTJ(92).LT.0) THEN  
0772           IP1=-MSTJ(92) 
0773           CALL LUSHOW(IP1,-3,P(IP,5))   
0774           CALL LUPREP(IP1)  
0775           MSTJ(92)=0    
0776         ENDIF   
0777     
0778 C...Jet fragmentation: string or independent fragmentation. 
0779       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN 
0780         MFRAG=MSTJ(1)   
0781         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2 
0782         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN 
0783           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.   
0784      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN  
0785             IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)    
0786           ENDIF 
0787         ENDIF   
0788         IF(MFRAG.EQ.1) CALL LUSTRF(IP)  
0789         IF(MFRAG.EQ.2) CALL LUINDF(IP)  
0790         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0 
0791         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0    
0792       ENDIF 
0793     
0794 C...Loop back if enough space left in LUJETS and no error abort.    
0795       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN  
0796       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN 
0797         GOTO 140    
0798       ELSEIF(IP.LT.N) THEN  
0799         CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')   
0800       ENDIF 
0801     
0802 C...Include simple Bose-Einstein effect parametrization if desired. 
0803       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN   
0804         CALL LUBOEI(NSAV)   
0805         GOTO 130    
0806       ENDIF 
0807     
0808 C...Check that momentum, energy and charge were conserved.  
0809       DO 160 I=1,N  
0810       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160  
0811       DO 150 J=1,4  
0812   150 PS(2,J)=PS(2,J)+P(I,J)    
0813       PS(2,6)=PS(2,6)+LUCHGE(K(I,2))    
0814   160 CONTINUE  
0815       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-  
0816      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4))) 
0817       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,   
0818      &'(LUEXEC:) four-momentum was not conserved')  
0819       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,    
0820      &'(LUEXEC:) charge was not conserved') 
0821     
0822       RETURN    
0823       END   
0824     
0825 C*********************************************************************  
0826     
0827       SUBROUTINE LUPREP(IP) 
0828     
0829 C...Purpose: to rearrange partons along strings, to allow small systems 
0830 C...to collapse into one or two particles and to check flavours.    
0831       IMPLICIT DOUBLE PRECISION(D)  
0832       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0833       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0834       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0835       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
0836       DIMENSION DPS(5),DPC(5),UE(3) 
0837       SAVE
0838     
0839 C...Rearrange parton shower product listing along strings: begin loop.  
0840       I1=N  
0841       DO 130 MQGST=1,2  
0842       DO 120 I=MAX(1,IP),N  
0843       IF(K(I,1).NE.3) GOTO 120  
0844       KC=LUCOMP(K(I,2)) 
0845       IF(KC.EQ.0) GOTO 120  
0846       KQ=KCHG(KC,2) 
0847       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120  
0848     
0849 C...Pick up loose string end.   
0850       KCS=4 
0851       IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 
0852       IA=I  
0853       NSTP=0    
0854   100 NSTP=NSTP+1   
0855       IF(NSTP.GT.4*N) THEN  
0856         CALL LUERRM(14,'(LUPREP:) caught in infinite loop') 
0857         RETURN  
0858       ENDIF 
0859     
0860 C...Copy undecayed parton.  
0861       IF(K(IA,1).EQ.3) THEN 
0862         IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN   
0863           CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS') 
0864           RETURN    
0865         ENDIF   
0866         I1=I1+1 
0867         K(I1,1)=2   
0868         IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1 
0869         K(I1,2)=K(IA,2) 
0870         K(I1,3)=IA  
0871         K(I1,4)=0   
0872         K(I1,5)=0   
0873         DO 110 J=1,5    
0874         P(I1,J)=P(IA,J) 
0875   110   V(I1,J)=V(IA,J) 
0876         K(IA,1)=K(IA,1)+10  
0877         IF(K(I1,1).EQ.1) GOTO 120   
0878       ENDIF 
0879     
0880 C...Go to next parton in colour space.  
0881       IB=IA 
0882       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).   
0883      &NE.0) THEN    
0884         IA=MOD(K(IB,KCS),MSTU(5))   
0885         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2  
0886         MREV=0  
0887       ELSE  
0888         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)). 
0889      &  EQ.0) KCS=9-KCS 
0890         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))   
0891         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2    
0892         MREV=1  
0893       ENDIF 
0894       IF(IA.LE.0.OR.IA.GT.N) THEN   
0895         CALL LUERRM(12,'(LUPREP:) colour rearrangement failed') 
0896         RETURN  
0897       ENDIF 
0898       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), 
0899      &MSTU(5)).EQ.IB) THEN  
0900         IF(MREV.EQ.1) KCS=9-KCS 
0901         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS  
0902         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2    
0903       ELSE  
0904         IF(MREV.EQ.0) KCS=9-KCS 
0905         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS  
0906         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2  
0907       ENDIF 
0908       IF(IA.NE.I) GOTO 100  
0909       K(I1,1)=1 
0910   120 CONTINUE  
0911   130 CONTINUE  
0912       N=I1  
0913     
0914 C...Find lowest-mass colour singlet jet system, OK if above threshold.  
0915       IF(MSTJ(14).LE.0) GOTO 320    
0916       NS=N  
0917   140 NSIN=N-NS 
0918       PDM=1.+PARJ(32)   
0919       IC=0  
0920       DO 190 I=MAX(1,IP),NS 
0921       IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN  
0922       ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN  
0923         NSIN=NSIN+1 
0924         IC=I    
0925         DO 150 J=1,4    
0926   150   DPS(J)=P(I,J)   
0927         MSTJ(93)=1  
0928         DPS(5)=ULMASS(K(I,2))   
0929       ELSEIF(K(I,1).EQ.2) THEN  
0930         DO 160 J=1,4    
0931   160   DPS(J)=DPS(J)+P(I,J)    
0932       ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN  
0933         DO 170 J=1,4    
0934   170   DPS(J)=DPS(J)+P(I,J)    
0935         MSTJ(93)=1  
0936         DPS(5)=DPS(5)+ULMASS(K(I,2))    
0937         PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)    
0938         IF(PD.LT.PDM) THEN  
0939           PDM=PD    
0940           DO 180 J=1,5  
0941   180     DPC(J)=DPS(J) 
0942           IC1=IC    
0943           IC2=I 
0944         ENDIF   
0945         IC=0    
0946       ELSE  
0947         NSIN=NSIN+1 
0948       ENDIF 
0949   190 CONTINUE  
0950       IF(PDM.GE.PARJ(32)) GOTO 320  
0951     
0952 C...Fill small-mass system as cluster.  
0953       NSAV=N    
0954       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))   
0955       K(N+1,1)=11   
0956       K(N+1,2)=91   
0957       K(N+1,3)=IC1  
0958       K(N+1,4)=N+2  
0959       K(N+1,5)=N+3  
0960       P(N+1,1)=DPC(1)   
0961       P(N+1,2)=DPC(2)   
0962       P(N+1,3)=DPC(3)   
0963       P(N+1,4)=DPC(4)   
0964       P(N+1,5)=PECM 
0965     
0966 C...Form two particles from flavours of lowest-mass system, if feasible.    
0967       K(N+2,1)=1    
0968       K(N+3,1)=1    
0969       IF(MSTU(16).NE.2) THEN    
0970         K(N+2,3)=N+1    
0971         K(N+3,3)=N+1    
0972       ELSE  
0973         K(N+2,3)=IC1    
0974         K(N+3,3)=IC2    
0975       ENDIF 
0976       K(N+2,4)=0    
0977       K(N+3,4)=0    
0978       K(N+2,5)=0    
0979       K(N+3,5)=0    
0980       IF(IABS(K(IC1,2)).NE.21) THEN 
0981         KC1=LUCOMP(K(IC1,2))    
0982         KC2=LUCOMP(K(IC2,2))    
0983         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320   
0984         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))   
0985         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))   
0986         IF(KQ1+KQ2.NE.0) GOTO 320   
0987   200   CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))   
0988         CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2)) 
0989         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200 
0990       ELSE  
0991         IF(IABS(K(IC2,2)).NE.21) GOTO 320   
0992   210   CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)    
0993         CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))   
0994         CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))    
0995         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210 
0996       ENDIF 
0997       P(N+2,5)=ULMASS(K(N+2,2)) 
0998       P(N+3,5)=ULMASS(K(N+3,2)) 
0999       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320 
1000       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260   
1001     
1002 C...Perform two-particle decay of jet system, if possible.  
1003       IF(PECM.GE.0.02*DPC(4)) THEN  
1004         PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-  
1005      &  (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)  
1006         UE(3)=2.*RLU(0)-1.  
1007         PHI=PARU(2)*RLU(0)  
1008         UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)    
1009         UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)    
1010         DO 220 J=1,3    
1011         P(N+2,J)=PA*UE(J)   
1012   220   P(N+3,J)=-PA*UE(J)  
1013         P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)    
1014         P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)    
1015         CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),  
1016      &  DPC(3)/DPC(4))  
1017       ELSE  
1018         NP=0    
1019         DO 230 I=IC1,IC2    
1020   230   IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1  
1021         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-   
1022      &  P(IC1,3)*P(IC2,3)   
1023         IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260    
1024         HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)   
1025         HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)   
1026         HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/    
1027      &  (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1. 
1028         HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2    
1029         HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC    
1030         HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC    
1031         DO 240 J=1,4    
1032         P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J) 
1033   240   P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J) 
1034       ENDIF 
1035       DO 250 J=1,4  
1036       V(N+1,J)=V(IC1,J) 
1037       V(N+2,J)=V(IC1,J) 
1038   250 V(N+3,J)=V(IC2,J) 
1039       V(N+1,5)=0.   
1040       V(N+2,5)=0.   
1041       V(N+3,5)=0.   
1042       N=N+3 
1043       GOTO 300  
1044     
1045 C...Else form one particle from the flavours available, if possible.    
1046   260 K(N+1,5)=N+2  
1047       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN  
1048         GOTO 320    
1049       ELSEIF(IABS(K(IC1,2)).NE.21) THEN 
1050         CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))  
1051       ELSE  
1052         KFLN=1+INT((2.+PARJ(2))*RLU(0)) 
1053         CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2)) 
1054       ENDIF 
1055       IF(K(N+2,2).EQ.0) GOTO 260    
1056       P(N+2,5)=ULMASS(K(N+2,2)) 
1057     
1058 C...Find parton/particle which combines to largest extra mass.  
1059       IR=0  
1060       HA=0. 
1061       DO 280 MCOMB=1,3  
1062       IF(IR.NE.0) GOTO 280  
1063       DO 270 I=MAX(1,IP),N  
1064       IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2. 
1065      &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270    
1066       IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2)) 
1067       IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270  
1068       IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270  
1069       IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100) 
1070      &GOTO 270  
1071       HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)   
1072       IF(HCR.GT.HA) THEN    
1073         IR=I    
1074         HA=HCR  
1075       ENDIF 
1076   270 CONTINUE  
1077   280 CONTINUE  
1078     
1079 C...Shuffle energy and momentum to put new particle on mass shell.  
1080       HB=PECM**2+HA 
1081       HC=P(N+2,5)**2+HA 
1082       HD=P(IR,5)**2+HA
1083 C******************CHANGES BY HIJING************  
1084       HK2=0.0
1085       IF(HA**2-(PECM*P(IR,5))**2.EQ.0.0.OR.HB+HD.EQ.0.0) GO TO 285
1086 C******************
1087       HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/ 
1088      &(HA**2-(PECM*P(IR,5))**2))-(HB+HC))/(HB+HD)   
1089   285 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB 
1090       DO 290 J=1,4  
1091       P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)  
1092       P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)   
1093       V(N+1,J)=V(IC1,J) 
1094   290 V(N+2,J)=V(IC1,J) 
1095       V(N+1,5)=0.   
1096       V(N+2,5)=0.   
1097       N=N+2 
1098     
1099 C...Mark collapsed system and store daughter pointers. Iterate. 
1100   300 DO 310 I=IC1,IC2  
1101       IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)  
1102      &THEN  
1103         K(I,1)=K(I,1)+10    
1104         IF(MSTU(16).NE.2) THEN  
1105           K(I,4)=NSAV+1 
1106           K(I,5)=NSAV+1 
1107         ELSE    
1108           K(I,4)=NSAV+2 
1109           K(I,5)=N  
1110         ENDIF   
1111       ENDIF 
1112   310 CONTINUE  
1113       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140  
1114     
1115 C...Check flavours and invariant masses in parton systems.  
1116   320 NP=0  
1117       KFN=0 
1118       KQS=0 
1119       DO 330 J=1,5  
1120   330 DPS(J)=0. 
1121       DO 360 I=MAX(1,IP),N  
1122       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360  
1123       KC=LUCOMP(K(I,2)) 
1124       IF(KC.EQ.0) GOTO 360  
1125       KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
1126       IF(KQ.EQ.0) GOTO 360  
1127       NP=NP+1   
1128       IF(KQ.NE.2) THEN  
1129         KFN=KFN+1   
1130         KQS=KQS+KQ  
1131         MSTJ(93)=1  
1132         DPS(5)=DPS(5)+ULMASS(K(I,2))    
1133       ENDIF 
1134       DO 340 J=1,4  
1135   340 DPS(J)=DPS(J)+P(I,J)  
1136       IF(K(I,1).EQ.1) THEN  
1137         IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL 
1138      &  LUERRM(2,'(LUPREP:) unphysical flavour combination')    
1139         IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.  
1140      &  (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,    
1141      &  '(LUPREP:) too small mass in jet system')   
1142         NP=0    
1143         KFN=0   
1144         KQS=0   
1145         DO 350 J=1,5    
1146   350   DPS(J)=0.   
1147       ENDIF 
1148   360 CONTINUE  
1149     
1150       RETURN    
1151       END   
1152     
1153 C*********************************************************************  
1154     
1155       SUBROUTINE LUSTRF(IP) 
1156 C...Purpose: to handle the fragmentation of an arbitrary colour singlet 
1157 C...jet system according to the Lund string fragmentation model.    
1158       IMPLICIT DOUBLE PRECISION(D)  
1159       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
1160       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
1161       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
1162       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),    
1163      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),  
1164      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5)    
1165       SAVE
1166     
1167 C...Function: four-product of two vectors.  
1168       FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) 
1169       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-   
1170      &DP(I,3)*DP(J,3)   
1171     
1172 C...Reset counters. Identify parton system. 
1173       MSTJ(91)=0    
1174       NSAV=N    
1175       NP=0  
1176       KQSUM=0   
1177       DO 100 J=1,5  
1178   100 DPS(J)=0. 
1179       MJU(1)=0  
1180       MJU(2)=0  
1181       I=IP-1    
1182   110 I=I+1 
1183       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN 
1184         CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')    
1185         IF(MSTU(21).GE.1) RETURN    
1186       ENDIF 
1187       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110 
1188       KC=LUCOMP(K(I,2)) 
1189       IF(KC.EQ.0) GOTO 110  
1190       KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
1191       IF(KQ.EQ.0) GOTO 110  
1192       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN  
1193         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')   
1194         IF(MSTU(21).GE.1) RETURN    
1195       ENDIF 
1196     
1197 C...Take copy of partons to be considered. Check flavour sum.   
1198       NP=NP+1   
1199       DO 120 J=1,5  
1200       K(N+NP,J)=K(I,J)  
1201       P(N+NP,J)=P(I,J)  
1202   120 DPS(J)=DPS(J)+P(I,J)  
1203       K(N+NP,3)=I   
1204       IF(P(N+NP,4)**2.LT.P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2) THEN   
1205         P(N+NP,4)=SQRT(P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2+  
1206      &  P(N+NP,5)**2)   
1207         DPS(4)=DPS(4)+MAX(0.,P(N+NP,4)-P(I,4))  
1208       ENDIF 
1209       IF(KQ.NE.2) KQSUM=KQSUM+KQ    
1210       IF(K(I,1).EQ.41) THEN 
1211         KQSUM=KQSUM+2*KQ    
1212         IF(KQSUM.EQ.KQ) MJU(1)=N+NP 
1213         IF(KQSUM.NE.KQ) MJU(2)=N+NP 
1214       ENDIF 
1215       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110  
1216       IF(KQSUM.NE.0) THEN   
1217         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')  
1218         IF(MSTU(21).GE.1) RETURN    
1219       ENDIF 
1220     
1221 C...Boost copied system to CM frame (for better numerical precision).   
1222       CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4), 
1223      &-DPS(3)/DPS(4))   
1224     
1225 C...Search for very nearby partons that may be recombined.  
1226       NTRYR=0   
1227       PARU12=PARU(12)   
1228       PARU13=PARU(13)   
1229       MJU(3)=MJU(1) 
1230       MJU(4)=MJU(2) 
1231       NR=NP 
1232   130 IF(NR.GE.3) THEN  
1233         PDRMIN=2.*PARU12    
1234         DO 140 I=N+1,N+NR   
1235         IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 140 
1236         I1=I+1  
1237         IF(I.EQ.N+NR) I1=N+1    
1238         IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 140  
1239         IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)    
1240      &  GOTO 140    
1241         IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 140 
1242         PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+   
1243      &  P(I1,2)**2+P(I1,3)**2)) 
1244         PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)    
1245         PDR=4.*(PAP-PVP)**2/(PARU13**2*PAP+2.*(PAP-PVP))    
1246         IF(PDR.LT.PDRMIN) THEN  
1247           IR=I  
1248           PDRMIN=PDR    
1249         ENDIF   
1250   140   CONTINUE    
1251     
1252 C...Recombine very nearby partons to avoid machine precision problems.  
1253         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN    
1254           DO 150 J=1,4  
1255   150     P(N+1,J)=P(N+1,J)+P(N+NR,J)   
1256           P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- 
1257      &    P(N+1,3)**2)) 
1258           NR=NR-1   
1259           GOTO 130  
1260         ELSEIF(PDRMIN.LT.PARU12) THEN   
1261           DO 160 J=1,4  
1262   160     P(IR,J)=P(IR,J)+P(IR+1,J) 
1263           P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2- 
1264      &    P(IR,3)**2))  
1265           DO 170 I=IR+1,N+NR-1  
1266           K(I,2)=K(I+1,2)   
1267           DO 170 J=1,5  
1268   170     P(I,J)=P(I+1,J)   
1269           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)    
1270           NR=NR-1   
1271           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1  
1272           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1  
1273           GOTO 130  
1274         ENDIF   
1275       ENDIF 
1276       NTRYR=NTRYR+1 
1277     
1278 C...Reset particle counter. Skip ahead if no junctions are present; 
1279 C...this is usually the case!   
1280       NRS=MAX(5*NR+11,NP)   
1281       NTRY=0    
1282   180 NTRY=NTRY+1   
1283       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN   
1284         PARU12=4.*PARU12    
1285         PARU13=2.*PARU13    
1286         GOTO 130    
1287       ELSEIF(NTRY.GT.100) THEN  
1288         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') 
1289         IF(MSTU(21).GE.1) RETURN    
1290       ENDIF 
1291       I=N+NRS   
1292       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 500  
1293       DO 490 JT=1,2 
1294       NJS(JT)=0 
1295       IF(MJU(JT).EQ.0) GOTO 490 
1296       JS=3-2*JT 
1297     
1298 C...Find and sum up momentum on three sides of junction. Check flavours.    
1299       DO 190 IU=1,3 
1300       IJU(IU)=0 
1301       DO 190 J=1,5  
1302   190 PJU(IU,J)=0.  
1303       IU=0  
1304       DO 200 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS 
1305       IF(K(I1,2).NE.21.AND.IU.LE.2) THEN    
1306         IU=IU+1 
1307         IJU(IU)=I1  
1308       ENDIF 
1309       DO 200 J=1,4  
1310   200 PJU(IU,J)=PJU(IU,J)+P(I1,J)   
1311       DO 210 IU=1,3 
1312   210 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)    
1313       IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND. 
1314      &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN   
1315         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')  
1316         IF(MSTU(21).GE.1) RETURN    
1317       ENDIF 
1318     
1319 C...Calculate (approximate) boost to rest frame of junction.    
1320       T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/  
1321      &(PJU(1,5)*PJU(2,5))   
1322       T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/  
1323      &(PJU(1,5)*PJU(3,5))   
1324       T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/  
1325      &(PJU(2,5)*PJU(3,5))   
1326       T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))  
1327       T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))  
1328       TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))    
1329       T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)    
1330       T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)    
1331       DO 220 J=1,3  
1332   220 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5)) 
1333       TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2) 
1334       DO 230 IU=1,3 
1335   230 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)- 
1336      &TJU(3)*PJU(IU,3)  
1337     
1338 C...Put junction at rest if motion could give inconsistencies.  
1339       IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN   
1340         DO 240 J=1,3    
1341   240   TJU(J)=0.   
1342         TJU(4)=1.   
1343         PJU(1,5)=PJU(1,4)   
1344         PJU(2,5)=PJU(2,4)   
1345         PJU(3,5)=PJU(3,4)   
1346       ENDIF 
1347     
1348 C...Start preparing for fragmentation of two strings from junction. 
1349       ISTA=I    
1350       DO 470 IU=1,2 
1351       NS=IJU(IU+1)-IJU(IU)  
1352     
1353 C...Junction strings: find longitudinal string directions.  
1354       DO 260 IS=1,NS    
1355       IS1=IJU(IU)+IS-1  
1356       IS2=IJU(IU)+IS    
1357       DO 250 J=1,5  
1358       DP(1,J)=0.5*P(IS1,J)  
1359       IF(IS.EQ.1) DP(1,J)=P(IS1,J)  
1360       DP(2,J)=0.5*P(IS2,J)  
1361   250 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)   
1362       IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2) 
1363       IF(IS.EQ.NS) DP(2,5)=0.   
1364       DP(3,5)=DFOUR(1,1)    
1365       DP(4,5)=DFOUR(2,2)    
1366       DHKC=DFOUR(1,2)   
1367       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN    
1368         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1369         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1370         DP(3,5)=0D0 
1371         DP(4,5)=0D0 
1372         DHKC=DFOUR(1,2) 
1373       ENDIF 
1374       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))    
1375       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.) 
1376       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.) 
1377       IN1=N+NR+4*IS-3   
1378       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))    
1379       DO 260 J=1,4  
1380       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)   
1381   260 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J) 
1382     
1383 C...Junction strings: initialize flavour, momentum and starting pos.    
1384       ISAV=I    
1385   270 NTRY=NTRY+1   
1386       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN   
1387         PARU12=4.*PARU12    
1388         PARU13=2.*PARU13    
1389         GOTO 130    
1390       ELSEIF(NTRY.GT.100) THEN  
1391         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') 
1392         IF(MSTU(21).GE.1) RETURN    
1393       ENDIF 
1394       I=ISAV    
1395       IRANKJ=0  
1396       IE(1)=K(N+1+(JT/2)*(NP-1),3)  
1397       IN(4)=N+NR+1  
1398       IN(5)=IN(4)+1 
1399       IN(6)=N+NR+4*NS+1 
1400       DO 280 JQ=1,2 
1401       DO 280 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4 
1402       P(IN1,1)=2-JQ 
1403       P(IN1,2)=JQ-1 
1404   280 P(IN1,3)=1.   
1405       KFL(1)=K(IJU(IU),2)   
1406       PX(1)=0.  
1407       PY(1)=0.  
1408       GAM(1)=0. 
1409       DO 290 J=1,5  
1410   290 PJU(IU+3,J)=0.    
1411     
1412 C...Junction strings: find initial transverse directions.   
1413       DO 300 J=1,4  
1414       DP(1,J)=P(IN(4),J)    
1415       DP(2,J)=P(IN(4)+1,J)  
1416       DP(3,J)=0.    
1417   300 DP(4,J)=0.    
1418       DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)    
1419       DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)    
1420       DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)   
1421       DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)   
1422       DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)   
1423       IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.    
1424       IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.    
1425       IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.    
1426       IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.    
1427       DHC12=DFOUR(1,2)  
1428       DHCX1=DFOUR(3,1)/DHC12    
1429       DHCX2=DFOUR(3,2)/DHC12    
1430       DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) 
1431       DHCY1=DFOUR(4,1)/DHC12    
1432       DHCY2=DFOUR(4,2)/DHC12    
1433       DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12   
1434       DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)    
1435       DO 310 J=1,4  
1436       DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))   
1437       P(IN(6),J)=DP(3,J)    
1438   310 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-  
1439      &DHCYX*DP(3,J))    
1440     
1441 C...Junction strings: produce new particle, origin. 
1442   320 I=I+1 
1443       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN   
1444         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')   
1445         IF(MSTU(21).GE.1) RETURN    
1446       ENDIF 
1447       IRANKJ=IRANKJ+1   
1448       K(I,1)=1  
1449       K(I,3)=IE(1)  
1450       K(I,4)=0  
1451       K(I,5)=0  
1452     
1453 C...Junction strings: generate flavour, hadron, pT, z and Gamma.    
1454   330 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))   
1455       IF(K(I,2).EQ.0) GOTO 270  
1456       IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.  
1457      &IABS(KFL(3)).GT.10) THEN  
1458         IF(RLU(0).GT.PARJ(19)) GOTO 330 
1459       ENDIF 
1460       P(I,5)=ULMASS(K(I,2)) 
1461       CALL LUPTDI(KFL(1),PX(3),PY(3))   
1462       PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2 
1463       CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)    
1464       GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)    
1465       DO 340 J=1,3  
1466   340 IN(J)=IN(3+J) 
1467     
1468 C...Junction strings: stepping within or from 'low' string region easy. 
1469       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*  
1470      &P(IN(1),5)**2.GE.PR(1)) THEN  
1471         P(IN(1)+2,4)=Z*P(IN(1)+2,3) 
1472         P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2) 
1473         DO 350 J=1,4    
1474   350   P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)  
1475         GOTO 420    
1476       ELSEIF(IN(1)+1.EQ.IN(2)) THEN 
1477         P(IN(2)+2,4)=P(IN(2)+2,3)   
1478         P(IN(2)+2,1)=1. 
1479         IN(2)=IN(2)+4   
1480         IF(IN(2).GT.N+NR+4*NS) GOTO 270 
1481         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1482           P(IN(1)+2,4)=P(IN(1)+2,3) 
1483           P(IN(1)+2,1)=0.   
1484           IN(1)=IN(1)+4 
1485         ENDIF   
1486       ENDIF 
1487     
1488 C...Junction strings: find new transverse directions.   
1489   360 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.   
1490      &IN(1).GT.IN(2)) GOTO 270  
1491       IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN 
1492         DO 370 J=1,4    
1493         DP(1,J)=P(IN(1),J)  
1494         DP(2,J)=P(IN(2),J)  
1495         DP(3,J)=0.  
1496   370   DP(4,J)=0.  
1497         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1498         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1499         DHC12=DFOUR(1,2)    
1500         IF(DHC12.LE.1E-2) THEN  
1501           P(IN(1)+2,4)=P(IN(1)+2,3) 
1502           P(IN(1)+2,1)=0.   
1503           IN(1)=IN(1)+4 
1504           GOTO 360  
1505         ENDIF   
1506         IN(3)=N+NR+4*NS+5   
1507         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) 
1508         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) 
1509         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) 
1510         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.  
1511         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.  
1512         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.  
1513         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.  
1514         DHCX1=DFOUR(3,1)/DHC12  
1515         DHCX2=DFOUR(3,2)/DHC12  
1516         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)   
1517         DHCY1=DFOUR(4,1)/DHC12  
1518         DHCY2=DFOUR(4,2)/DHC12  
1519         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 
1520         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)  
1521         DO 380 J=1,4    
1522         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) 
1523         P(IN(3),J)=DP(3,J)  
1524   380   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-    
1525      &  DHCYX*DP(3,J))  
1526 C...Express pT with respect to new axes, if sensible.   
1527         PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))    
1528         PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))    
1529         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN   
1530           PX(3)=PXP 
1531           PY(3)=PYP 
1532         ENDIF   
1533       ENDIF 
1534     
1535 C...Junction strings: sum up known four-momentum, coefficients for m2.  
1536       DO 400 J=1,4  
1537       DHG(J)=0. 
1538       P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+  
1539      &PY(3)*P(IN(3)+1,J)    
1540       DO 390 IN1=IN(4),IN(1)-4,4    
1541   390 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) 
1542       DO 400 IN2=IN(5),IN(2)-4,4    
1543   400 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) 
1544       DHM(1)=FOUR(I,I)  
1545       DHM(2)=2.*FOUR(I,IN(1))   
1546       DHM(3)=2.*FOUR(I,IN(2))   
1547       DHM(4)=2.*FOUR(IN(1),IN(2))   
1548     
1549 C...Junction strings: find coefficients for Gamma expression.   
1550       DO 410 IN2=IN(1)+1,IN(2),4    
1551       DO 410 IN1=IN(1),IN2-1,4  
1552       DHC=2.*FOUR(IN1,IN2)  
1553       DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC   
1554       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC 
1555       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC 
1556   410 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC   
1557     
1558 C...Junction strings: solve (m2, Gamma) equation system for energies.   
1559       DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)  
1560       IF(ABS(DHS1).LT.1E-4) GOTO 270    
1561       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)* 
1562      &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)  
1563       DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1)) 
1564       P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-  
1565      &DHS2/DHS1)    
1566       IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 270 
1567       P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/  
1568      &(DHM(2)+DHM(4)*P(IN(2)+2,4))  
1569     
1570 C...Junction strings: step to new region if necessary.  
1571       IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN 
1572         P(IN(2)+2,4)=P(IN(2)+2,3)   
1573         P(IN(2)+2,1)=1. 
1574         IN(2)=IN(2)+4   
1575         IF(IN(2).GT.N+NR+4*NS) GOTO 270 
1576         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1577           P(IN(1)+2,4)=P(IN(1)+2,3) 
1578           P(IN(1)+2,1)=0.   
1579           IN(1)=IN(1)+4 
1580         ENDIF   
1581         GOTO 360    
1582       ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN 
1583         P(IN(1)+2,4)=P(IN(1)+2,3)   
1584         P(IN(1)+2,1)=0. 
1585         IN(1)=IN(1)+JS  
1586         GOTO 710    
1587       ENDIF 
1588     
1589 C...Junction strings: particle four-momentum, remainder, loop back. 
1590   420 DO 430 J=1,4  
1591       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J) 
1592   430 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)    
1593       IF(P(I,4).LE.0.) GOTO 270 
1594       PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-    
1595      &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) 
1596       IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN 
1597         KFL(1)=-KFL(3)  
1598         PX(1)=-PX(3)    
1599         PY(1)=-PY(3)    
1600         GAM(1)=GAM(3)   
1601         IF(IN(3).NE.IN(6)) THEN 
1602           DO 440 J=1,4  
1603           P(IN(6),J)=P(IN(3),J) 
1604   440     P(IN(6)+1,J)=P(IN(3)+1,J) 
1605         ENDIF   
1606         DO 450 JQ=1,2   
1607         IN(3+JQ)=IN(JQ) 
1608         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)   
1609   450   P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)  
1610         GOTO 320    
1611       ENDIF 
1612     
1613 C...Junction strings: save quantities left after each string.   
1614       IF(IABS(KFL(1)).GT.10) GOTO 270   
1615       I=I-1 
1616       KFJH(IU)=KFL(1)   
1617       DO 460 J=1,4  
1618   460 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)  
1619   470 CONTINUE  
1620     
1621 C...Junction strings: put together to new effective string endpoint.    
1622       NJS(JT)=I-ISTA    
1623       KFJS(JT)=K(K(MJU(JT+2),3),2)  
1624       KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1   
1625       IF(KFJH(1).EQ.KFJH(2)) KFLS=3 
1626       IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),  
1627      &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+  
1628      &KFLS,KFJH(1)) 
1629       DO 480 J=1,4  
1630       PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)  
1631   480 PJS(JT+2,J)=PJU(4,J)+PJU(5,J) 
1632       PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2- 
1633      &PJS(JT,3)**2))    
1634   490 CONTINUE  
1635     
1636 C...Open versus closed strings. Choose breakup region for latter.   
1637   500 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN  
1638         NS=MJU(2)-MJU(1)    
1639         NB=MJU(1)-N 
1640       ELSEIF(MJU(1).NE.0) THEN  
1641         NS=N+NR-MJU(1)  
1642         NB=MJU(1)-N 
1643       ELSEIF(MJU(2).NE.0) THEN  
1644         NS=MJU(2)-N 
1645         NB=1    
1646       ELSEIF(IABS(K(N+1,2)).NE.21) THEN 
1647         NS=NR-1 
1648         NB=1    
1649       ELSE  
1650         NS=NR+1 
1651         W2SUM=0.    
1652         DO 510 IS=1,NR  
1653         P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))   
1654   510   W2SUM=W2SUM+P(N+NR+IS,1)    
1655         W2RAN=RLU(0)*W2SUM  
1656         NB=0    
1657   520   NB=NB+1 
1658         W2SUM=W2SUM-P(N+NR+NB,1)    
1659         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 520    
1660       ENDIF 
1661     
1662 C...Find longitudinal string directions (i.e. lightlike four-vectors).  
1663       DO 540 IS=1,NS    
1664       IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)   
1665       IS2=N+IS+NB-NR*((IS+NB-1)/NR) 
1666       DO 530 J=1,5  
1667       DP(1,J)=P(IS1,J)  
1668       IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)  
1669       IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)   
1670       DP(2,J)=P(IS2,J)  
1671       IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)  
1672   530 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)   
1673       DP(3,5)=DFOUR(1,1)    
1674       DP(4,5)=DFOUR(2,2)    
1675       DHKC=DFOUR(1,2)   
1676       IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN    
1677         DP(3,5)=DP(1,5)**2  
1678         DP(4,5)=DP(2,5)**2  
1679         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)   
1680         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)   
1681         DHKC=DFOUR(1,2) 
1682       ENDIF 
1683       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))    
1684       DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.) 
1685       DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.) 
1686       IN1=N+NR+4*IS-3   
1687       P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))    
1688       DO 540 J=1,4  
1689       P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)   
1690   540 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J) 
1691     
1692 C...Begin initialization: sum up energy, set starting position. 
1693       ISAV=I    
1694   550 NTRY=NTRY+1   
1695       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN   
1696         PARU12=4.*PARU12    
1697         PARU13=2.*PARU13    
1698         GOTO 130    
1699       ELSEIF(NTRY.GT.100) THEN  
1700         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') 
1701         IF(MSTU(21).GE.1) RETURN    
1702       ENDIF 
1703       I=ISAV    
1704       DO 560 J=1,4  
1705       P(N+NRS,J)=0. 
1706       DO 560 IS=1,NR    
1707   560 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)   
1708       DO 570 JT=1,2 
1709       IRANK(JT)=0   
1710       IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)    
1711       IF(NS.GT.NR) IRANK(JT)=1  
1712       IE(JT)=K(N+1+(JT/2)*(NP-1),3) 
1713       IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1) 
1714       IN(3*JT+2)=IN(3*JT+1)+1   
1715       IN(3*JT+3)=N+NR+4*NS+2*JT-1   
1716       DO 570 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4 
1717       P(IN1,1)=2-JT 
1718       P(IN1,2)=JT-1 
1719   570 P(IN1,3)=1.   
1720     
1721 C...Initialize flavour and pT variables for open string.    
1722       IF(NS.LT.NR) THEN 
1723         PX(1)=0.    
1724         PY(1)=0.    
1725         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))   
1726         PX(2)=-PX(1)    
1727         PY(2)=-PY(1)    
1728         DO 580 JT=1,2   
1729         KFL(JT)=K(IE(JT),2) 
1730         IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)   
1731         MSTJ(93)=1  
1732         PMQ(JT)=ULMASS(KFL(JT)) 
1733   580   GAM(JT)=0.  
1734     
1735 C...Closed string: random initial breakup flavour, pT and vertex.   
1736       ELSE  
1737         KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)    
1738         CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)  
1739         KFL(2)=-KFL(1)  
1740         IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN   
1741           KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))  
1742         ELSEIF(IABS(KFL(1)).GT.10) THEN 
1743           KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))  
1744         ENDIF   
1745         CALL LUPTDI(KFL(1),PX(1),PY(1)) 
1746         PX(2)=-PX(1)    
1747         PY(2)=-PY(1)    
1748         PR3=MIN(25.,0.1*P(N+NR+1,5)**2) 
1749   590   CALL LUZDIS(KFL(1),KFL(2),PR3,Z)    
1750         ZR=PR3/(Z*P(N+NR+1,5)**2)   
1751         IF(ZR.GE.1.) GOTO 590   
1752         DO 600 JT=1,2   
1753         MSTJ(93)=1  
1754         PMQ(JT)=ULMASS(KFL(JT)) 
1755         GAM(JT)=PR3*(1.-Z)/Z    
1756         IN1=N+NR+3+4*(JT/2)*(NS-1)  
1757         P(IN1,JT)=1.-Z  
1758         P(IN1,3-JT)=JT-1    
1759         P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z 
1760         P(IN1+1,JT)=ZR  
1761         P(IN1+1,3-JT)=2-JT  
1762   600   P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR 
1763       ENDIF 
1764     
1765 C...Find initial transverse directions (i.e. spacelike four-vectors).   
1766       DO 640 JT=1,2 
1767       IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN    
1768         IN1=IN(3*JT+1)  
1769         IN3=IN(3*JT+3)  
1770         DO 610 J=1,4    
1771         DP(1,J)=P(IN1,J)    
1772         DP(2,J)=P(IN1+1,J)  
1773         DP(3,J)=0.  
1774   610   DP(4,J)=0.  
1775         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1776         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1777         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) 
1778         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) 
1779         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) 
1780         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.  
1781         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.  
1782         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.  
1783         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.  
1784         DHC12=DFOUR(1,2)    
1785         DHCX1=DFOUR(3,1)/DHC12  
1786         DHCX2=DFOUR(3,2)/DHC12  
1787         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)   
1788         DHCY1=DFOUR(4,1)/DHC12  
1789         DHCY2=DFOUR(4,2)/DHC12  
1790         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 
1791         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)  
1792         DO 620 J=1,4    
1793         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) 
1794         P(IN3,J)=DP(3,J)    
1795   620   P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-  
1796      &  DHCYX*DP(3,J))  
1797       ELSE  
1798         DO 630 J=1,4    
1799         P(IN3+2,J)=P(IN3,J) 
1800   630   P(IN3+3,J)=P(IN3+1,J)   
1801       ENDIF 
1802   640 CONTINUE  
1803     
1804 C...Remove energy used up in junction string fragmentation. 
1805       IF(MJU(1)+MJU(2).GT.0) THEN   
1806         DO 660 JT=1,2   
1807         IF(NJS(JT).EQ.0) GOTO 660   
1808         DO 650 J=1,4    
1809   650   P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)   
1810   660   CONTINUE    
1811       ENDIF 
1812     
1813 C...Produce new particle: side, origin. 
1814   670 I=I+1 
1815       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN   
1816         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')   
1817         IF(MSTU(21).GE.1) RETURN    
1818       ENDIF 
1819       JT=1.5+RLU(0) 
1820       IF(IABS(KFL(3-JT)).GT.10) JT=3-JT 
1821       JR=3-JT   
1822       JS=3-2*JT 
1823       IRANK(JT)=IRANK(JT)+1 
1824       K(I,1)=1  
1825       K(I,3)=IE(JT) 
1826       K(I,4)=0  
1827       K(I,5)=0  
1828     
1829 C...Generate flavour, hadron and pT.    
1830   680 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))  
1831       IF(K(I,2).EQ.0) GOTO 550  
1832       IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.  
1833      &IABS(KFL(3)).GT.10) THEN  
1834         IF(RLU(0).GT.PARJ(19)) GOTO 680 
1835       ENDIF 
1836       P(I,5)=ULMASS(K(I,2)) 
1837       CALL LUPTDI(KFL(JT),PX(3),PY(3))  
1838       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2  
1839     
1840 C...Final hadrons for small invariant mass. 
1841       MSTJ(93)=1    
1842       PMQ(3)=ULMASS(KFL(3)) 
1843       WMIN=PARJ(32+MSTJ(11))+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)  
1844       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=  
1845      &WMIN-0.5*PARJ(36)*PMQ(3)  
1846       WREM2=FOUR(N+NRS,N+NRS)   
1847       IF(WREM2.LT.0.10) GOTO 550    
1848       IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),    
1849      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 810  
1850     
1851 C...Choose z, which gives Gamma. Shift z for heavy flavours.    
1852       CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)  
1853       KFL1A=IABS(KFL(1))    
1854       KFL2A=IABS(KFL(2))    
1855       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),    
1856      &MOD(KFL2A/1000,10)).GE.4) THEN    
1857         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2  
1858         PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))    
1859         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)   
1860         PR(JR)=(PMQ(JR)+PARJ(32+MSTJ(11)))**2+(PX(JR)-PX(3))**2+    
1861      &  (PY(JR)-PY(3))**2   
1862         IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 810  
1863       ENDIF 
1864       GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)  
1865       DO 690 J=1,3  
1866   690 IN(J)=IN(3*JT+J)  
1867     
1868 C...Stepping within or from 'low' string region easy.   
1869       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*  
1870      &P(IN(1),5)**2.GE.PR(JT)) THEN 
1871         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)   
1872         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)  
1873         DO 700 J=1,4    
1874   700   P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)    
1875         GOTO 770    
1876       ELSEIF(IN(1)+1.EQ.IN(2)) THEN 
1877         P(IN(JR)+2,4)=P(IN(JR)+2,3) 
1878         P(IN(JR)+2,JT)=1.   
1879         IN(JR)=IN(JR)+4*JS  
1880         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550   
1881         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1882           P(IN(JT)+2,4)=P(IN(JT)+2,3)   
1883           P(IN(JT)+2,JT)=0. 
1884           IN(JT)=IN(JT)+4*JS    
1885         ENDIF   
1886       ENDIF 
1887     
1888 C...Find new transverse directions (i.e. spacelike string vectors). 
1889   710 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR. 
1890      &IN(1).GT.IN(2)) GOTO 550  
1891       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN   
1892         DO 720 J=1,4    
1893         DP(1,J)=P(IN(1),J)  
1894         DP(2,J)=P(IN(2),J)  
1895         DP(3,J)=0.  
1896   720   DP(4,J)=0.  
1897         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1898         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1899         DHC12=DFOUR(1,2)    
1900         IF(DHC12.LE.1E-2) THEN  
1901           P(IN(JT)+2,4)=P(IN(JT)+2,3)   
1902           P(IN(JT)+2,JT)=0. 
1903           IN(JT)=IN(JT)+4*JS    
1904           GOTO 710  
1905         ENDIF   
1906         IN(3)=N+NR+4*NS+5   
1907         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) 
1908         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) 
1909         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) 
1910         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.  
1911         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.  
1912         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.  
1913         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.  
1914         DHCX1=DFOUR(3,1)/DHC12  
1915         DHCX2=DFOUR(3,2)/DHC12  
1916         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)   
1917         DHCY1=DFOUR(4,1)/DHC12  
1918         DHCY2=DFOUR(4,2)/DHC12  
1919         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 
1920         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)  
1921         DO 730 J=1,4    
1922         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) 
1923         P(IN(3),J)=DP(3,J)  
1924   730   P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-    
1925      &  DHCYX*DP(3,J))  
1926 C...Express pT with respect to new axes, if sensible.   
1927         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*   
1928      &  FOUR(IN(3*JT+3)+1,IN(3)))   
1929         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)* 
1930      &  FOUR(IN(3*JT+3)+1,IN(3)+1)) 
1931         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN   
1932           PX(3)=PXP 
1933           PY(3)=PYP 
1934         ENDIF   
1935       ENDIF 
1936     
1937 C...Sum up known four-momentum. Gives coefficients for m2 expression.   
1938       DO 750 J=1,4  
1939       DHG(J)=0. 
1940       P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+   
1941      &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)   
1942       DO 740 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS 
1943   740 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) 
1944       DO 750 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS 
1945   750 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) 
1946       DHM(1)=FOUR(I,I)  
1947       DHM(2)=2.*FOUR(I,IN(1))   
1948       DHM(3)=2.*FOUR(I,IN(2))   
1949       DHM(4)=2.*FOUR(IN(1),IN(2))   
1950     
1951 C...Find coefficients for Gamma expression. 
1952       DO 760 IN2=IN(1)+1,IN(2),4    
1953       DO 760 IN1=IN(1),IN2-1,4  
1954       DHC=2.*FOUR(IN1,IN2)  
1955       DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC 
1956       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC 
1957       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC 
1958   760 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC   
1959     
1960 C...Solve (m2, Gamma) equation system for energies taken.   
1961       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)    
1962       IF(ABS(DHS1).LT.1E-4) GOTO 550    
1963       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*   
1964      &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)    
1965       DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))   
1966       P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)- 
1967      &DHS2/DHS1)    
1968       IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 550 
1969       P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/ 
1970      &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))  
1971     
1972 C...Step to new region if necessary.    
1973       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN   
1974         P(IN(JR)+2,4)=P(IN(JR)+2,3) 
1975         P(IN(JR)+2,JT)=1.   
1976         IN(JR)=IN(JR)+4*JS  
1977         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550   
1978         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1979           P(IN(JT)+2,4)=P(IN(JT)+2,3)   
1980           P(IN(JT)+2,JT)=0. 
1981           IN(JT)=IN(JT)+4*JS    
1982         ENDIF   
1983         GOTO 710    
1984       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN   
1985         P(IN(JT)+2,4)=P(IN(JT)+2,3) 
1986         P(IN(JT)+2,JT)=0.   
1987         IN(JT)=IN(JT)+4*JS  
1988         GOTO 710    
1989       ENDIF 
1990     
1991 C...Four-momentum of particle. Remaining quantities. Loop back. 
1992   770 DO 780 J=1,4  
1993       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J) 
1994   780 P(N+NRS,J)=P(N+NRS,J)-P(I,J)  
1995       IF(P(I,4).LE.0.) GOTO 550 
1996       KFL(JT)=-KFL(3)   
1997       PMQ(JT)=PMQ(3)    
1998       PX(JT)=-PX(3) 
1999       PY(JT)=-PY(3) 
2000       GAM(JT)=GAM(3)    
2001       IF(IN(3).NE.IN(3*JT+3)) THEN  
2002         DO 790 J=1,4    
2003         P(IN(3*JT+3),J)=P(IN(3),J)  
2004   790   P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)  
2005       ENDIF 
2006       DO 800 JQ=1,2 
2007       IN(3*JT+JQ)=IN(JQ)    
2008       P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) 
2009   800 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)   
2010       GOTO 670  
2011     
2012 C...Final hadron: side, flavour, hadron, mass.  
2013   810 I=I+1 
2014       K(I,1)=1  
2015       K(I,3)=IE(JR) 
2016       K(I,4)=0  
2017       K(I,5)=0  
2018       CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))    
2019       IF(K(I,2).EQ.0) GOTO 550  
2020       P(I,5)=ULMASS(K(I,2)) 
2021       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2  
2022     
2023 C...Final two hadrons: find common setup of four-vectors.   
2024       JQ=1  
2025       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)* 
2026      &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2    
2027       DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2)) 
2028       DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12 
2029       DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12 
2030       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN 
2031         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ) 
2032         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)   
2033         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*    
2034      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2   
2035       ENDIF 
2036     
2037 C...Solve kinematics for final two hadrons, if possible.    
2038       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2 
2039       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)  
2040       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 180  
2041       IF(FD.GE.1.) GOTO 550 
2042       FA=WREM2+PR(JT)-PR(JR)    
2043       IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(37+MSTJ(11))  
2044       IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-100.,LOG(FD)* 
2045      &PARJ(37+MSTJ(11))*(PR(1)+PR(2))**2))  
2046       FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV)) 
2047       KFL1A=IABS(KFL(1))    
2048       KFL2A=IABS(KFL(2))    
2049       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),    
2050      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-  
2051      &4.*WREM2*PR(JT))),FLOAT(JS))  
2052       DO 820 J=1,4  
2053       P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*   
2054      &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+  
2055      &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2   
2056   820 P(I,J)=P(N+NRS,J)-P(I-1,J)    
2057     
2058 C...Mark jets as fragmented and give daughter pointers. 
2059       N=I-NRS+1 
2060       DO 830 I=NSAV+1,NSAV+NP   
2061       IM=K(I,3) 
2062       K(IM,1)=K(IM,1)+10    
2063       IF(MSTU(16).NE.2) THEN    
2064         K(IM,4)=NSAV+1  
2065         K(IM,5)=NSAV+1  
2066       ELSE  
2067         K(IM,4)=NSAV+2  
2068         K(IM,5)=N   
2069       ENDIF 
2070   830 CONTINUE  
2071     
2072 C...Document string system. Move up particles.  
2073       NSAV=NSAV+1   
2074       K(NSAV,1)=11  
2075       K(NSAV,2)=92  
2076       K(NSAV,3)=IP  
2077       K(NSAV,4)=NSAV+1  
2078       K(NSAV,5)=N   
2079       DO 840 J=1,4  
2080       P(NSAV,J)=DPS(J)  
2081   840 V(NSAV,J)=V(IP,J) 
2082       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))  
2083       V(NSAV,5)=0.  
2084       DO 850 I=NSAV+1,N 
2085       DO 850 J=1,5  
2086       K(I,J)=K(I+NRS-1,J)   
2087       P(I,J)=P(I+NRS-1,J)   
2088   850 V(I,J)=0. 
2089     
2090 C...Order particles in rank along the chain. Update mother pointer. 
2091       DO 860 I=NSAV+1,N 
2092       DO 860 J=1,5  
2093       K(I-NSAV+N,J)=K(I,J)  
2094   860 P(I-NSAV+N,J)=P(I,J)  
2095       I1=NSAV   
2096       DO 880 I=N+1,2*N-NSAV 
2097       IF(K(I,3).NE.IE(1)) GOTO 880  
2098       I1=I1+1   
2099       DO 870 J=1,5  
2100       K(I1,J)=K(I,J)    
2101   870 P(I1,J)=P(I,J)    
2102       IF(MSTU(16).NE.2) K(I1,3)=NSAV    
2103   880 CONTINUE  
2104       DO 900 I=2*N-NSAV,N+1,-1  
2105       IF(K(I,3).EQ.IE(1)) GOTO 900  
2106       I1=I1+1   
2107       DO 890 J=1,5  
2108       K(I1,J)=K(I,J)    
2109   890 P(I1,J)=P(I,J)    
2110       IF(MSTU(16).NE.2) K(I1,3)=NSAV    
2111   900 CONTINUE  
2112     
2113 C...Boost back particle system. Set production vertices.    
2114       CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),   
2115      &DPS(3)/DPS(4))    
2116       DO 910 I=NSAV+1,N 
2117       DO 910 J=1,4  
2118   910 V(I,J)=V(IP,J)    
2119     
2120       RETURN    
2121       END   
2122     
2123 C*********************************************************************  
2124     
2125       SUBROUTINE LUINDF(IP) 
2126     
2127 C...Purpose: to handle the fragmentation of a jet system (or a single   
2128 C...jet) according to independent fragmentation models. 
2129       IMPLICIT DOUBLE PRECISION(D)  
2130       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2131       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
2132       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
2133       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),    
2134      &KFLO(2),PXO(2),PYO(2),WO(2)   
2135       SAVE
2136     
2137 C...Reset counters. Identify parton system and take copy. Check flavour.    
2138       NSAV=N    
2139       NJET=0    
2140       KQSUM=0   
2141       DO 100 J=1,5  
2142   100 DPS(J)=0. 
2143       I=IP-1    
2144   110 I=I+1 
2145       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN 
2146         CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')    
2147         IF(MSTU(21).GE.1) RETURN    
2148       ENDIF 
2149       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110  
2150       KC=LUCOMP(K(I,2)) 
2151       IF(KC.EQ.0) GOTO 110  
2152       KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
2153       IF(KQ.EQ.0) GOTO 110  
2154       NJET=NJET+1   
2155       IF(KQ.NE.2) KQSUM=KQSUM+KQ    
2156       DO 120 J=1,5  
2157       K(NSAV+NJET,J)=K(I,J) 
2158       P(NSAV+NJET,J)=P(I,J) 
2159   120 DPS(J)=DPS(J)+P(I,J)  
2160       K(NSAV+NJET,3)=I  
2161       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.   
2162      &K(I+1,1).EQ.2)) GOTO 110  
2163       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN 
2164         CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')  
2165         IF(MSTU(21).GE.1) RETURN    
2166       ENDIF 
2167     
2168 C...Boost copied system to CM frame. Find CM energy and sum flavours.   
2169       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),  
2170      &-DPS(2)/DPS(4),-DPS(3)/DPS(4))    
2171       PECM=0.   
2172       DO 130 J=1,3  
2173   130 NFI(J)=0  
2174       DO 140 I=NSAV+1,NSAV+NJET 
2175       PECM=PECM+P(I,4)  
2176       KFA=IABS(K(I,2))  
2177       IF(KFA.LE.3) THEN 
2178         NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))   
2179       ELSEIF(KFA.GT.1000) THEN  
2180         KFLA=MOD(KFA/1000,10)   
2181         KFLB=MOD(KFA/100,10)    
2182         IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))   
2183         IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))   
2184       ENDIF 
2185   140 CONTINUE  
2186     
2187 C...Loop over attempts made. Reset counters.    
2188       NTRY=0    
2189   150 NTRY=NTRY+1   
2190       N=NSAV+NJET   
2191       IF(NTRY.GT.200) THEN  
2192         CALL LUERRM(14,'(LUINDF:) caught in infinite loop') 
2193         IF(MSTU(21).GE.1) RETURN    
2194       ENDIF 
2195       DO 160 J=1,3  
2196       NFL(J)=NFI(J) 
2197       IFET(J)=0 
2198   160 KFLF(J)=0 
2199     
2200 C...Loop over jets to be fragmented.    
2201       DO 230 IP1=NSAV+1,NSAV+NJET   
2202       MSTJ(91)=0    
2203       NSAV1=N   
2204     
2205 C...Initial flavour and momentum values. Jet along +z axis. 
2206       KFLH=IABS(K(IP1,2))   
2207       IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10) 
2208       KFLO(2)=0 
2209       WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2) 
2210     
2211 C...Initial values for quark or diquark jet.    
2212   170 IF(IABS(K(IP1,2)).NE.21) THEN 
2213         NSTR=1  
2214         KFLO(1)=K(IP1,2)    
2215         CALL LUPTDI(0,PXO(1),PYO(1))    
2216         WO(1)=WF    
2217     
2218 C...Initial values for gluon treated like random quark jet. 
2219       ELSEIF(MSTJ(2).LE.2) THEN 
2220         NSTR=1  
2221         IF(MSTJ(2).EQ.2) MSTJ(91)=1 
2222         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)   
2223         CALL LUPTDI(0,PXO(1),PYO(1))    
2224         WO(1)=WF    
2225     
2226 C...Initial values for gluon treated like quark-antiquark jet pair, 
2227 C...sharing energy according to Altarelli-Parisi splitting function.    
2228       ELSE  
2229         NSTR=2  
2230         IF(MSTJ(2).EQ.4) MSTJ(91)=1 
2231         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)   
2232         KFLO(2)=-KFLO(1)    
2233         CALL LUPTDI(0,PXO(1),PYO(1))    
2234         PXO(2)=-PXO(1)  
2235         PYO(2)=-PYO(1)  
2236         WO(1)=WF*RLU(0)**(1./3.)    
2237         WO(2)=WF-WO(1)  
2238       ENDIF 
2239     
2240 C...Initial values for rank, flavour, pT and W+.    
2241       DO 220 ISTR=1,NSTR    
2242   180 I=N   
2243       IRANK=0   
2244       KFL1=KFLO(ISTR)   
2245       PX1=PXO(ISTR) 
2246       PY1=PYO(ISTR) 
2247       W=WO(ISTR)    
2248     
2249 C...New hadron. Generate flavour and hadron species.    
2250   190 I=I+1 
2251       IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN 
2252         CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')   
2253         IF(MSTU(21).GE.1) RETURN    
2254       ENDIF 
2255       IRANK=IRANK+1 
2256       K(I,1)=1  
2257       K(I,3)=IP1    
2258       K(I,4)=0  
2259       K(I,5)=0  
2260   200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))   
2261       IF(K(I,2).EQ.0) GOTO 180  
2262       IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND. 
2263      &IABS(KFL2).GT.10) THEN    
2264         IF(RLU(0).GT.PARJ(19)) GOTO 200 
2265       ENDIF 
2266     
2267 C...Find hadron mass. Generate four-momentum.   
2268       P(I,5)=ULMASS(K(I,2)) 
2269       CALL LUPTDI(KFL1,PX2,PY2) 
2270       P(I,1)=PX1+PX2    
2271       P(I,2)=PY1+PY2    
2272       PR=P(I,5)**2+P(I,1)**2+P(I,2)**2  
2273       CALL LUZDIS(KFL1,KFL2,PR,Z)   
2274       P(I,3)=0.5*(Z*W-PR/(Z*W)) 
2275       P(I,4)=0.5*(Z*W+PR/(Z*W)) 
2276       IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND. 
2277      &P(I,3).LE.0.001) THEN 
2278         IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180   
2279         P(I,3)=0.0001   
2280         P(I,4)=SQRT(PR) 
2281         Z=P(I,4)/W  
2282       ENDIF 
2283     
2284 C...Remaining flavour and momentum. 
2285       KFL1=-KFL2    
2286       PX1=-PX2  
2287       PY1=-PY2  
2288       W=(1.-Z)*W    
2289       DO 210 J=1,5  
2290   210 V(I,J)=0. 
2291     
2292 C...Check if pL acceptable. Go back for new hadron if enough energy.    
2293       IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) I=I-1   
2294       IF(W.GT.PARJ(31)) GOTO 190    
2295   220 N=I   
2296       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32) 
2297       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170   
2298     
2299 C...Rotate jet to new direction.    
2300       THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))    
2301       PHI=ULANGL(P(IP1,1),P(IP1,2)) 
2302       CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)    
2303       K(K(IP1,3),4)=NSAV1+1 
2304       K(K(IP1,3),5)=N   
2305     
2306 C...End of jet generation loop. Skip conservation in some cases.    
2307   230 CONTINUE  
2308       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470    
2309       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150 
2310     
2311 C...Subtract off produced hadron flavours, finished if zero.    
2312       DO 240 I=NSAV+NJET+1,N    
2313       KFA=IABS(K(I,2))  
2314       KFLA=MOD(KFA/1000,10) 
2315       KFLB=MOD(KFA/100,10)  
2316       KFLC=MOD(KFA/10,10)   
2317       IF(KFLA.EQ.0) THEN    
2318         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB    
2319         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB    
2320       ELSE  
2321         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))   
2322         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))   
2323         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))   
2324       ENDIF 
2325   240 CONTINUE  
2326       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ 
2327      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3    
2328       IF(NREQ.EQ.0) GOTO 320    
2329     
2330 C...Take away flavour of low-momentum particles until enough freedom.   
2331       NREM=0    
2332   250 IREM=0    
2333       P2MIN=PECM**2 
2334       DO 260 I=NSAV+NJET+1,N    
2335       P2=P(I,1)**2+P(I,2)**2+P(I,3)**2  
2336       IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I    
2337   260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2  
2338       IF(IREM.EQ.0) GOTO 150    
2339       K(IREM,1)=7   
2340       KFA=IABS(K(IREM,2))   
2341       KFLA=MOD(KFA/1000,10) 
2342       KFLB=MOD(KFA/100,10)  
2343       KFLC=MOD(KFA/10,10)   
2344       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8    
2345       IF(K(IREM,1).EQ.8) GOTO 250   
2346       IF(KFLA.EQ.0) THEN    
2347         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB  
2348         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN  
2349         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN  
2350       ELSE  
2351         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))    
2352         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))    
2353         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))    
2354       ENDIF 
2355       NREM=NREM+1   
2356       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ 
2357      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3    
2358       IF(NREQ.GT.NREM) GOTO 250 
2359       DO 270 I=NSAV+NJET+1,N    
2360   270 IF(K(I,1).EQ.8) K(I,1)=1  
2361     
2362 C...Find combination of existing and new flavours for hadron.   
2363   280 NFET=2    
2364       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3  
2365       IF(NREQ.LT.NREM) NFET=1   
2366       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0    
2367       DO 290 J=1,NFET   
2368       IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0) 
2369       KFLF(J)=ISIGN(1,NFL(1))   
2370       IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))   
2371   290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))  
2372       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))    
2373      &GOTO 280  
2374       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.    
2375      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).    
2376      &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280    
2377       IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))  
2378       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)    
2379       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))  
2380       IF(NFET.LE.2) KFLF(3)=0   
2381       IF(KFLF(3).NE.0) THEN 
2382         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+  
2383      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1)) 
2384         IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)  
2385      &  KFLFC=KFLFC+ISIGN(2,KFLFC)  
2386       ELSE  
2387         KFLFC=KFLF(1)   
2388       ENDIF 
2389       CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)  
2390       IF(KF.EQ.0) GOTO 280  
2391       DO 300 J=1,MAX(2,NFET)    
2392   300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))    
2393     
2394 C...Store hadron at random among free positions.    
2395       NPOS=MIN(1+INT(RLU(0)*NREM),NREM) 
2396       DO 310 I=NSAV+NJET+1,N    
2397       IF(K(I,1).EQ.7) NPOS=NPOS-1   
2398       IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310 
2399       K(I,1)=1  
2400       K(I,2)=KF 
2401       P(I,5)=ULMASS(K(I,2)) 
2402       P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)  
2403   310 CONTINUE  
2404       NREM=NREM-1   
2405       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ 
2406      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3    
2407       IF(NREM.GT.0) GOTO 280    
2408     
2409 C...Compensate for missing momentum in global scheme (3 options).   
2410   320 MTMP = MOD(MSTJ(3),5)
2411       IF(MTMP.NE.0.AND.MTMP.NE.4) THEN  
2412         DO 330 J=1,3    
2413         PSI(J)=0.   
2414         DO 330 I=NSAV+NJET+1,N  
2415   330   PSI(J)=PSI(J)+P(I,J)    
2416         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2    
2417         PWS=0.  
2418         DO 340 I=NSAV+NJET+1,N  
2419         IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)  
2420         IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+  
2421      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) 
2422   340   IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.  
2423         DO 360 I=NSAV+NJET+1,N  
2424         IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)   
2425         IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+   
2426      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) 
2427         IF(MOD(MSTJ(3),5).EQ.3) PW=1.   
2428         DO 350 J=1,3    
2429   350   P(I,J)=P(I,J)-PSI(J)*PW/PWS 
2430   360   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)    
2431     
2432 C...Compensate for missing momentum withing each jet separately.    
2433       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN  
2434         DO 370 I=N+1,N+NJET 
2435         K(I,1)=0    
2436         DO 370 J=1,5    
2437   370   P(I,J)=0.   
2438         DO 390 I=NSAV+NJET+1,N  
2439         IR1=K(I,3)  
2440         IR2=N+IR1-NSAV  
2441         K(IR2,1)=K(IR2,1)+1 
2442         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/  
2443      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)   
2444         DO 380 J=1,3    
2445   380   P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)   
2446         P(IR2,4)=P(IR2,4)+P(I,4)    
2447   390   P(IR2,5)=P(IR2,5)+PLS   
2448         PSS=0.  
2449         DO 400 I=N+1,N+NJET 
2450   400   IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))  
2451         DO 420 I=NSAV+NJET+1,N  
2452         IR1=K(I,3)  
2453         IR2=N+IR1-NSAV  
2454         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/  
2455      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)   
2456         DO 410 J=1,3    
2457   410   P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS* 
2458      &  P(IR1,J)    
2459   420   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)    
2460       ENDIF 
2461     
2462 C...Scale momenta for energy conservation.  
2463       IF(MOD(MSTJ(3),5).NE.0) THEN  
2464         PMS=0.  
2465         PES=0.  
2466         PQS=0.  
2467         DO 430 I=NSAV+NJET+1,N  
2468         PMS=PMS+P(I,5)  
2469         PES=PES+P(I,4)  
2470   430   PQS=PQS+P(I,5)**2/P(I,4)    
2471         IF(PMS.GE.PECM) GOTO 150    
2472         NECO=0  
2473   440   NECO=NECO+1 
2474         PFAC=(PECM-PQS)/(PES-PQS)   
2475         PES=0.  
2476         PQS=0.  
2477         DO 460 I=NSAV+NJET+1,N  
2478         DO 450 J=1,3    
2479   450   P(I,J)=PFAC*P(I,J)  
2480         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)    
2481         PES=PES+P(I,4)  
2482   460   PQS=PQS+P(I,5)**2/P(I,4)    
2483         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440  
2484       ENDIF 
2485     
2486 C...Origin of produced particles and parton daughter pointers.  
2487   470 DO 480 I=NSAV+NJET+1,N    
2488       IF(MSTU(16).NE.2) K(I,3)=NSAV+1   
2489   480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)  
2490       DO 490 I=NSAV+1,NSAV+NJET 
2491       I1=K(I,3) 
2492       K(I1,1)=K(I1,1)+10    
2493       IF(MSTU(16).NE.2) THEN    
2494         K(I1,4)=NSAV+1  
2495         K(I1,5)=NSAV+1  
2496       ELSE  
2497         K(I1,4)=K(I1,4)-NJET+1  
2498         K(I1,5)=K(I1,5)-NJET+1  
2499         IF(K(I1,5).LT.K(I1,4)) THEN 
2500           K(I1,4)=0 
2501           K(I1,5)=0 
2502         ENDIF   
2503       ENDIF 
2504   490 CONTINUE  
2505     
2506 C...Document independent fragmentation system. Remove copy of jets. 
2507       NSAV=NSAV+1   
2508       K(NSAV,1)=11  
2509       K(NSAV,2)=93  
2510       K(NSAV,3)=IP  
2511       K(NSAV,4)=NSAV+1  
2512       K(NSAV,5)=N-NJET+1    
2513       DO 500 J=1,4  
2514       P(NSAV,J)=DPS(J)  
2515   500 V(NSAV,J)=V(IP,J) 
2516       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))  
2517       V(NSAV,5)=0.  
2518       DO 510 I=NSAV+NJET,N  
2519       DO 510 J=1,5  
2520       K(I-NJET+1,J)=K(I,J)  
2521       P(I-NJET+1,J)=P(I,J)  
2522   510 V(I-NJET+1,J)=V(I,J)  
2523       N=N-NJET+1    
2524     
2525 C...Boost back particle system. Set production vertices.    
2526       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),   
2527      &DPS(2)/DPS(4),DPS(3)/DPS(4))  
2528       DO 520 I=NSAV+1,N 
2529       DO 520 J=1,4  
2530   520 V(I,J)=V(IP,J)    
2531     
2532       RETURN    
2533       END   
2534     
2535 C*********************************************************************  
2536     
2537       SUBROUTINE LUDECY(IP) 
2538     
2539 C...Purpose: to handle the decay of unstable particles. 
2540       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2541       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
2542       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
2543       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
2544       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),  
2545      &WTCOR(10) 
2546       SAVE
2547       DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./ 
2548     
2549 C...Functions: momentum in two-particle decays, four-product and    
2550 C...matrix element times phase space in weak decays.    
2551       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)  
2552       FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) 
2553       HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))* 
2554      &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)    
2555     
2556 C...Initial values. 
2557       NTRY=0    
2558       NSAV=N    
2559       KFA=IABS(K(IP,2)) 
2560       KFS=ISIGN(1,K(IP,2))  
2561       KC=LUCOMP(KFA)    
2562       MSTJ(92)=0    
2563     
2564 C...Choose lifetime and determine decay vertex. 
2565       IF(K(IP,1).EQ.5) THEN 
2566         V(IP,5)=0.  
2567       ELSEIF(K(IP,1).NE.4) THEN 
2568         V(IP,5)=-PMAS(KC,4)*LOG(RLU(0)) 
2569       ENDIF 
2570       DO 100 J=1,4  
2571   100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)   
2572     
2573 C...Determine whether decay allowed or not. 
2574       MOUT=0    
2575       IF(MSTJ(22).EQ.2) THEN    
2576         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1   
2577       ELSEIF(MSTJ(22).EQ.3) THEN    
2578         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1  
2579       ELSEIF(MSTJ(22).EQ.4) THEN    
2580         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 
2581         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 
2582       ENDIF 
2583       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN   
2584         K(IP,1)=4   
2585         RETURN  
2586       ENDIF 
2587     
2588 C...Check existence of decay channels. Particle/antiparticle rules. 
2589       KCA=KC    
2590       IF(MDCY(KC,2).GT.0) THEN  
2591         MDMDCY=MDME(MDCY(KC,2),2)   
2592         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY    
2593       ENDIF 
2594       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN 
2595         CALL LUERRM(9,'(LUDECY:) no decay channel defined') 
2596         RETURN  
2597       ENDIF 
2598       IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS   
2599       IF(KCHG(KC,3).EQ.0) THEN  
2600         KFSP=1  
2601         KFSN=0  
2602         IF(RLU(0).GT.0.5) KFS=-KFS  
2603       ELSEIF(KFS.GT.0) THEN 
2604         KFSP=1  
2605         KFSN=0  
2606       ELSE  
2607         KFSP=0  
2608         KFSN=1  
2609       ENDIF 
2610     
2611 C...Sum branching ratios of allowed decay channels. 
2612       NOPE=0    
2613       BRSU=0.   
2614       DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1  
2615       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.    
2616      &KFSN*MDME(IDL,1).NE.3) GOTO 120   
2617       IF(MDME(IDL,2).GT.100) GOTO 120   
2618       NOPE=NOPE+1   
2619       BRSU=BRSU+BRAT(IDL)   
2620   120 CONTINUE  
2621       IF(NOPE.EQ.0) THEN    
2622         CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')    
2623         RETURN  
2624       ENDIF 
2625     
2626 C...Select decay channel among allowed ones.    
2627   130 RBR=BRSU*RLU(0)   
2628       IDL=MDCY(KCA,2)-1 
2629   140 IDL=IDL+1 
2630       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.    
2631      &KFSN*MDME(IDL,1).NE.3) THEN   
2632         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140   
2633       ELSEIF(MDME(IDL,2).GT.100) THEN   
2634         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140   
2635       ELSE  
2636         IDC=IDL 
2637         RBR=RBR-BRAT(IDL)   
2638         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140 
2639       ENDIF 
2640     
2641 C...Start readout of decay channel: matrix element, reset counters. 
2642       MMAT=MDME(IDC,2)  
2643   150 NTRY=NTRY+1   
2644       IF(NTRY.GT.1000) THEN 
2645         CALL LUERRM(14,'(LUDECY:) caught in infinite loop') 
2646         IF(MSTU(21).GE.1) RETURN    
2647       ENDIF 
2648       I=N   
2649       NP=0  
2650       NQ=0  
2651       MBST=0    
2652       IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1   
2653       DO 160 J=1,4  
2654       PV(1,J)=0.    
2655   160 IF(MBST.EQ.0) PV(1,J)=P(IP,J) 
2656       IF(MBST.EQ.1) PV(1,4)=P(IP,5) 
2657       PV(1,5)=P(IP,5)   
2658       PS=0. 
2659       PSQ=0.    
2660       MREM=0    
2661     
2662 C...Read out decay products. Convert to standard flavour code.  
2663       JTMAX=5   
2664       IF(MDME(IDC+1,2).EQ.101) JTMAX=10 
2665       DO 170 JT=1,JTMAX 
2666       IF(JT.LE.5) KP=KFDP(IDC,JT)   
2667       IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)   
2668       IF(KP.EQ.0) GOTO 170  
2669       KPA=IABS(KP)  
2670       KCP=LUCOMP(KPA)   
2671       IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN 
2672         KFP=KP  
2673       ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN  
2674         KFP=KFS*KP  
2675       ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN  
2676         KFP=-KFS*MOD(KFA/10,10) 
2677       ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN  
2678         KFP=KFS*(100*MOD(KFA/10,100)+3) 
2679       ELSEIF(KPA.EQ.81) THEN    
2680         KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1) 
2681       ELSEIF(KP.EQ.82) THEN 
2682         CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)   
2683         IF(KFP.EQ.0) GOTO 150   
2684         MSTJ(93)=1  
2685         IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150 
2686       ELSEIF(KP.EQ.-82) THEN    
2687         KFP=-KFP    
2688         IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)    
2689       ENDIF 
2690       IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)    
2691     
2692 C...Add decay product to event record or to quark flavour list. 
2693       KFPA=IABS(KFP)    
2694       KQP=KCHG(KCP,2)   
2695       IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN   
2696         NQ=NQ+1 
2697         KFLO(NQ)=KFP    
2698         MSTJ(93)=2  
2699         PSQ=PSQ+ULMASS(KFLO(NQ))    
2700       ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)  
2701      &THEN  
2702         NQ=NQ-1 
2703         PS=PS-P(I,5)    
2704         K(I,1)=1    
2705         KFI=K(I,2)  
2706         CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))  
2707         IF(K(I,2).EQ.0) GOTO 150    
2708         MSTJ(93)=1  
2709         P(I,5)=ULMASS(K(I,2))   
2710         PS=PS+P(I,5)    
2711       ELSE  
2712         I=I+1   
2713         NP=NP+1 
2714         IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1 
2715         IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1    
2716         K(I,1)=1+MOD(NQ,2)  
2717         IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2    
2718         IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1  
2719         K(I,2)=KFP  
2720         K(I,3)=IP   
2721         K(I,4)=0    
2722         K(I,5)=0    
2723         P(I,5)=ULMASS(KFP)  
2724         IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)   
2725         PS=PS+P(I,5)    
2726       ENDIF 
2727   170 CONTINUE  
2728     
2729 C...Choose decay multiplicity in phase space model. 
2730   180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN    
2731         PSP=PS  
2732         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))   
2733         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)   
2734   190   NTRY=NTRY+1 
2735         IF(NTRY.GT.1000) THEN   
2736           CALL LUERRM(14,'(LUDECY:) caught in infinite loop')   
2737           IF(MSTU(21).GE.1) RETURN  
2738         ENDIF   
2739         IF(MMAT.LE.20) THEN 
2740           GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*  
2741      &    SIN(PARU(2)*RLU(0))   
2742           ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS  
2743           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190 
2744           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190   
2745           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190   
2746           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190   
2747         ELSE    
2748           ND=MMAT-20    
2749         ENDIF   
2750     
2751 C...Form hadrons from flavour content.  
2752         DO 200 JT=1,4   
2753   200   KFL1(JT)=KFLO(JT)   
2754         IF(ND.EQ.NP+NQ/2) GOTO 220  
2755         DO 210 I=N+NP+1,N+ND-NQ/2   
2756         JT=1+INT((NQ-1)*RLU(0)) 
2757         CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2)) 
2758         IF(K(I,2).EQ.0) GOTO 190    
2759   210   KFL1(JT)=-KFL2  
2760   220   JT=2    
2761         JT2=3   
2762         JT3=4   
2763         IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4 
2764         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))* 
2765      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3    
2766         IF(JT.EQ.3) JT2=2   
2767         IF(JT.EQ.4) JT3=2   
2768         CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))   
2769         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190  
2770         IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))   
2771         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190 
2772     
2773 C...Check that sum of decay product masses not too large.   
2774         PS=PSP  
2775         DO 230 I=N+NP+1,N+ND    
2776         K(I,1)=1    
2777         K(I,3)=IP   
2778         K(I,4)=0    
2779         K(I,5)=0    
2780         P(I,5)=ULMASS(K(I,2))   
2781   230   PS=PS+P(I,5)    
2782         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190 
2783     
2784 C...Rescale energy to subtract off spectator quark mass.    
2785       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).    
2786      &AND.NP.GE.3) THEN 
2787         PS=PS-P(N+NP,5) 
2788         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)    
2789         DO 240 J=1,5    
2790         P(N+NP,J)=PQT*PV(1,J)   
2791   240   PV(1,J)=(1.-PQT)*PV(1,J)    
2792         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150 
2793         ND=NP-1 
2794         MREM=1  
2795     
2796 C...Phase space factors imposed in W decay. 
2797       ELSEIF(MMAT.EQ.46) THEN   
2798         MSTJ(93)=1  
2799         PSMC=ULMASS(K(N+1,2))   
2800         MSTJ(93)=1  
2801         PSMC=PSMC+ULMASS(K(N+2,2))  
2802         IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130   
2803         HR1=(P(N+1,5)/PV(1,5))**2   
2804         HR2=(P(N+2,5)/PV(1,5))**2   
2805         IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).  
2806      &  LT.2.*RLU(0)) GOTO 130  
2807         ND=NP   
2808     
2809 C...Fully specified final state: check mass broadening effects. 
2810       ELSE  
2811         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150 
2812         ND=NP   
2813       ENDIF 
2814     
2815 C...Select W mass in decay Q -> W + q, without W propagator.    
2816       IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN 
2817         HLQ=(PARJ(32)/PV(1,5))**2   
2818         HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2 
2819         HRQ=(P(N+2,5)/PV(1,5))**2   
2820   250   HW=HLQ+RLU(0)*(HUQ-HLQ) 
2821         IF(HMEPS(HW).LT.RLU(0)) GOTO 250    
2822         P(N+1,5)=PV(1,5)*SQRT(HW)   
2823     
2824 C...Ditto, including W propagator. Divide mass range into three regions.    
2825       ELSEIF(MMAT.EQ.45) THEN   
2826         HQW=(PV(1,5)/PMAS(24,1))**2 
2827         HLW=(PARJ(32)/PMAS(24,1))**2    
2828         HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2 
2829         HRQ=(P(N+2,5)/PV(1,5))**2   
2830         HG=PMAS(24,2)/PMAS(24,1)    
2831         HATL=ATAN((HLW-1.)/HG)  
2832         HM=MIN(1.,HUW-0.001)    
2833         HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)   
2834   260   HM=HM-HG    
2835         HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)   
2836         HSAV1=HMEPS(HM/HQW) 
2837         HSAV2=1./((HM-1.)**2+HG**2) 
2838         IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN  
2839           HMV1=HMV2 
2840           GOTO 260  
2841         ENDIF   
2842         HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)    
2843         HM1=1.-SQRT(1./HMV-HG**2)   
2844         IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN   
2845           HM=HM1    
2846         ELSEIF(HMV2.LE.HMV1) THEN   
2847           HM=MAX(HLW,HM-MIN(0.1,1.-HM)) 
2848         ENDIF   
2849         HATM=ATAN((HM-1.)/HG)   
2850         HWT1=(HATM-HATL)/HG 
2851         HWT2=HMV*(MIN(1.,HUW)-HM)   
2852         HWT3=0. 
2853         IF(HUW.GT.1.) THEN  
2854           HATU=ATAN((HUW-1.)/HG)    
2855           HMP1=HMEPS(1./HQW)    
2856           HWT3=HMP1*HATU/HG 
2857         ENDIF   
2858     
2859 C...Select mass region and W mass there. Accept according to weight.    
2860   270   HREG=RLU(0)*(HWT1+HWT2+HWT3)    
2861         IF(HREG.LE.HWT1) THEN   
2862           HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL)) 
2863           HACC=HMEPS(HW/HQW)    
2864         ELSEIF(HREG.LE.HWT1+HWT2) THEN  
2865           HW=HM+RLU(0)*(MIN(1.,HUW)-HM) 
2866           HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV 
2867         ELSE    
2868           HW=1.+HG*TAN(RLU(0)*HATU) 
2869           HACC=HMEPS(HW/HQW)/HMP1   
2870         ENDIF   
2871         IF(HACC.LT.RLU(0)) GOTO 270 
2872         P(N+1,5)=PMAS(24,1)*SQRT(HW)    
2873       ENDIF 
2874     
2875 C...Determine position of grandmother, number of sisters, Q -> W sign.  
2876       NM=0  
2877       MSGN=0    
2878       IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN  
2879         IM=K(IP,3)  
2880         IF(IM.LT.0.OR.IM.GE.IP) IM=0    
2881         IF(IM.NE.0) KFAM=IABS(K(IM,2))  
2882         IF(IM.NE.0.AND.MMAT.EQ.3) THEN  
2883           DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)  
2884   280     IF(K(IL,3).EQ.IM) NM=NM+1 
2885           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.    
2886      &    MOD(KFAM/1000,10).NE.0) NM=0  
2887         ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN 
2888           MSGN=ISIGN(1,K(IM,2)*K(IP,2)) 
2889           IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=  
2890      &    MSGN*(-1)**MOD(KFAM/100,10)   
2891         ENDIF   
2892       ENDIF 
2893     
2894 C...Kinematics of one-particle decays.  
2895       IF(ND.EQ.1) THEN  
2896         DO 290 J=1,4    
2897   290   P(N+1,J)=P(IP,J)    
2898         GOTO 510    
2899       ENDIF 
2900     
2901 C...Calculate maximum weight ND-particle decay. 
2902       PV(ND,5)=P(N+ND,5)    
2903       IF(ND.GE.3) THEN  
2904         WTMAX=1./WTCOR(ND-2)    
2905         PMAX=PV(1,5)-PS+P(N+ND,5)   
2906         PMIN=0. 
2907         DO 300 IL=ND-1,1,-1 
2908         PMAX=PMAX+P(N+IL,5) 
2909         PMIN=PMIN+P(N+IL+1,5)   
2910   300   WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))   
2911       ENDIF 
2912     
2913 C...Find virtual gamma mass in Dalitz decay.    
2914   310 IF(ND.EQ.2) THEN  
2915       ELSEIF(MMAT.EQ.2) THEN    
2916         PMES=4.*PMAS(11,1)**2   
2917         PMRHO2=PMAS(131,1)**2   
2918         PGRHO2=PMAS(131,2)**2   
2919   320   PMST=PMES*(P(IP,5)**2/PMES)**RLU(0) 
2920         WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*    
2921      &  (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/ 
2922      &  ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2) 
2923         IF(WT.LT.RLU(0)) GOTO 320   
2924         PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))  
2925     
2926 C...M-generator gives weight. If rejected, try again.   
2927       ELSE  
2928   330   RORD(1)=1.  
2929         DO 350 IL1=2,ND-1   
2930         RSAV=RLU(0) 
2931         DO 340 IL2=IL1-1,1,-1   
2932         IF(RSAV.LE.RORD(IL2)) GOTO 350  
2933   340   RORD(IL2+1)=RORD(IL2)   
2934   350   RORD(IL2+1)=RSAV    
2935         RORD(ND)=0. 
2936         WT=1.   
2937         DO 360 IL=ND-1,1,-1 
2938         PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)    
2939   360   WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))   
2940         IF(WT.LT.RLU(0)*WTMAX) GOTO 330 
2941       ENDIF 
2942     
2943 C...Perform two-particle decays in respective CM frame. 
2944   370 DO 390 IL=1,ND-1  
2945       PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))    
2946       UE(3)=2.*RLU(0)-1.    
2947       PHI=PARU(2)*RLU(0)    
2948       UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)  
2949       UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)  
2950       DO 380 J=1,3  
2951       P(N+IL,J)=PA*UE(J)    
2952   380 PV(IL+1,J)=-PA*UE(J)  
2953       P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)    
2954   390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)  
2955     
2956 C...Lorentz transform decay products to lab frame.  
2957       DO 400 J=1,4  
2958   400 P(N+ND,J)=PV(ND,J)    
2959       DO 430 IL=ND-1,1,-1   
2960       DO 410 J=1,3  
2961   410 BE(J)=PV(IL,J)/PV(IL,4)   
2962       GA=PV(IL,4)/PV(IL,5)  
2963       DO 430 I=N+IL,N+ND    
2964       BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)    
2965       DO 420 J=1,3  
2966   420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)    
2967   430 P(I,4)=GA*(P(I,4)+BEP)    
2968     
2969 C...Matrix elements for omega and phi decays.   
2970       IF(MMAT.EQ.1) THEN    
2971         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2  
2972      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2    
2973      &  +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)   
2974         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310    
2975     
2976 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. 
2977       ELSEIF(MMAT.EQ.2) THEN    
2978         FOUR12=FOUR(N+1,N+2)    
2979         FOUR13=FOUR(N+1,N+3)    
2980         FOUR23=0.5*PMST-0.25*PMES   
2981         WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+   
2982      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)    
2983         IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370    
2984     
2985 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, 
2986 C...V vector), of form cos**2(theta02) in V1 rest frame.    
2987       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN    
2988         IF((P(IP,5)**2*FOUR(IM,N+1)-FOUR(IP,IM)*FOUR(IP,N+1))**2.LE.    
2989      &  RLU(0)*(FOUR(IP,IM)**2-(P(IP,5)*P(IM,5))**2)*(FOUR(IP,N+1)**2-  
2990      &  (P(IP,5)*P(N+1,5))**2)) GOTO 370    
2991     
2992 C...Matrix element for "onium" -> g + g + g or gamma + g + g.   
2993       ELSEIF(MMAT.EQ.4) THEN    
2994         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2  
2995         HX2=2.*FOUR(IP,N+2)/P(IP,5)**2  
2996         HX3=2.*FOUR(IP,N+3)/P(IP,5)**2  
2997         WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+ 
2998      &  ((1.-HX3)/(HX1*HX2))**2 
2999         IF(WT.LT.2.*RLU(0)) GOTO 310    
3000         IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)   
3001      &  GOTO 310    
3002     
3003 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.    
3004       ELSEIF(MMAT.EQ.41) THEN   
3005         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2  
3006         IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310    
3007     
3008 C...Matrix elements for weak decays (only semileptonic for c and b) 
3009       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN    
3010         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3) 
3011         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3) 
3012         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310  
3013       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN    
3014         DO 440 J=1,4    
3015         P(N+NP+1,J)=0.  
3016         DO 440 IS=N+3,N+NP  
3017   440   P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J) 
3018         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)  
3019         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)  
3020         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310  
3021     
3022 C...Angular distribution in W decay.    
3023       ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN 
3024         IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)    
3025         IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)    
3026         IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370  
3027       ENDIF 
3028     
3029 C...Scale back energy and reattach spectator.   
3030       IF(MREM.EQ.1) THEN    
3031         DO 450 J=1,5    
3032   450   PV(1,J)=PV(1,J)/(1.-PQT)    
3033         ND=ND+1 
3034         MREM=0  
3035       ENDIF 
3036     
3037 C...Low invariant mass for system with spectator quark gives particle,  
3038 C...not two jets. Readjust momenta accordingly. 
3039       IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN   
3040         MSTJ(93)=1  
3041         PM2=ULMASS(K(N+2,2))    
3042         MSTJ(93)=1  
3043         PM3=ULMASS(K(N+3,2))    
3044         IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE. 
3045      &  (PARJ(32)+PM2+PM3)**2) GOTO 510 
3046         K(N+2,1)=1  
3047         KFTEMP=K(N+2,2) 
3048         CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))    
3049         IF(K(N+2,2).EQ.0) GOTO 150  
3050         P(N+2,5)=ULMASS(K(N+2,2))   
3051         PS=P(N+1,5)+P(N+2,5)    
3052         PV(2,5)=P(N+2,5)    
3053         MMAT=0  
3054         ND=2    
3055         GOTO 370    
3056       ELSEIF(MMAT.EQ.44) THEN   
3057         MSTJ(93)=1  
3058         PM3=ULMASS(K(N+3,2))    
3059         MSTJ(93)=1  
3060         PM4=ULMASS(K(N+4,2))    
3061         IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE. 
3062      &  (PARJ(32)+PM3+PM4)**2) GOTO 480 
3063         K(N+3,1)=1  
3064         KFTEMP=K(N+3,2) 
3065         CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))    
3066         IF(K(N+3,2).EQ.0) GOTO 150  
3067         P(N+3,5)=ULMASS(K(N+3,2))   
3068         DO 460 J=1,3    
3069   460   P(N+3,J)=P(N+3,J)+P(N+4,J)  
3070         P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)  
3071         HA=P(N+1,4)**2-P(N+2,4)**2  
3072         HB=HA-(P(N+1,5)**2-P(N+2,5)**2) 
3073         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+   
3074      &  (P(N+1,3)-P(N+2,3))**2  
3075         HD=(PV(1,4)-P(N+3,4))**2    
3076         HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2  
3077         HF=HD*HC-HB**2  
3078         HG=HD*HC-HA*HB  
3079         HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)   
3080         DO 470 J=1,3    
3081         PCOR=HH*(P(N+1,J)-P(N+2,J)) 
3082         P(N+1,J)=P(N+1,J)+PCOR  
3083   470   P(N+2,J)=P(N+2,J)-PCOR  
3084         P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)  
3085         P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)  
3086         ND=ND-1 
3087       ENDIF 
3088     
3089 C...Check invariant mass of W jets. May give one particle or start over.    
3090   480 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN   
3091         PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))  
3092         MSTJ(93)=1  
3093         PM1=ULMASS(K(N+1,2))    
3094         MSTJ(93)=1  
3095         PM2=ULMASS(K(N+2,2))    
3096         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 490    
3097         KFLDUM=INT(1.5+RLU(0))  
3098         CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)    
3099         CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)    
3100         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150   
3101         PSM=ULMASS(KF1)+ULMASS(KF2) 
3102         IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 490 
3103         IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 490 
3104         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150   
3105         K(N+1,1)=1  
3106         KFTEMP=K(N+1,2) 
3107         CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))    
3108         IF(K(N+1,2).EQ.0) GOTO 150  
3109         P(N+1,5)=ULMASS(K(N+1,2))   
3110         K(N+2,2)=K(N+3,2)   
3111         P(N+2,5)=P(N+3,5)   
3112         PS=P(N+1,5)+P(N+2,5)    
3113         PV(2,5)=P(N+3,5)    
3114         MMAT=0  
3115         ND=2    
3116         GOTO 370    
3117       ENDIF 
3118     
3119 C...Phase space decay of partons from W decay.  
3120   490 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN  
3121         KFLO(1)=K(N+1,2)    
3122         KFLO(2)=K(N+2,2)    
3123         K(N+1,1)=K(N+3,1)   
3124         K(N+1,2)=K(N+3,2)   
3125         DO 500 J=1,5    
3126         PV(1,J)=P(N+1,J)+P(N+2,J)   
3127   500   P(N+1,J)=P(N+3,J)   
3128         PV(1,5)=PMR 
3129         N=N+1   
3130         NP=0    
3131         NQ=2    
3132         PS=0.   
3133         MSTJ(93)=2  
3134         PSQ=ULMASS(KFLO(1)) 
3135         MSTJ(93)=2  
3136         PSQ=PSQ+ULMASS(KFLO(2)) 
3137         MMAT=11 
3138         GOTO 180    
3139       ENDIF 
3140     
3141 C...Boost back for rapidly moving particle. 
3142   510 N=N+ND    
3143       IF(MBST.EQ.1) THEN    
3144         DO 520 J=1,3    
3145   520   BE(J)=P(IP,J)/P(IP,4)   
3146         GA=P(IP,4)/P(IP,5)  
3147         DO 540 I=NSAV+1,N   
3148         BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)  
3149         DO 530 J=1,3    
3150   530   P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)  
3151   540   P(I,4)=GA*(P(I,4)+BEP)  
3152       ENDIF 
3153     
3154 C...Fill in position of decay vertex.   
3155       DO 560 I=NSAV+1,N 
3156       DO 550 J=1,4  
3157   550 V(I,J)=VDCY(J)    
3158   560 V(I,5)=0. 
3159     
3160 C...Set up for parton shower evolution from jets.   
3161       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN    
3162         K(NSAV+1,1)=3   
3163         K(NSAV+2,1)=3   
3164         K(NSAV+3,1)=3   
3165         K(NSAV+1,4)=MSTU(5)*(NSAV+2)    
3166         K(NSAV+1,5)=MSTU(5)*(NSAV+3)    
3167         K(NSAV+2,4)=MSTU(5)*(NSAV+3)    
3168         K(NSAV+2,5)=MSTU(5)*(NSAV+1)    
3169         K(NSAV+3,4)=MSTU(5)*(NSAV+1)    
3170         K(NSAV+3,5)=MSTU(5)*(NSAV+2)    
3171         MSTJ(92)=-(NSAV+1)  
3172       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN  
3173         K(NSAV+2,1)=3   
3174         K(NSAV+3,1)=3   
3175         K(NSAV+2,4)=MSTU(5)*(NSAV+3)    
3176         K(NSAV+2,5)=MSTU(5)*(NSAV+3)    
3177         K(NSAV+3,4)=MSTU(5)*(NSAV+2)    
3178         K(NSAV+3,5)=MSTU(5)*(NSAV+2)    
3179         MSTJ(92)=NSAV+2 
3180       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).    
3181      &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN 
3182         K(NSAV+1,1)=3   
3183         K(NSAV+2,1)=3   
3184         K(NSAV+1,4)=MSTU(5)*(NSAV+2)    
3185         K(NSAV+1,5)=MSTU(5)*(NSAV+2)    
3186         K(NSAV+2,4)=MSTU(5)*(NSAV+1)    
3187         K(NSAV+2,5)=MSTU(5)*(NSAV+1)    
3188         MSTJ(92)=NSAV+1 
3189       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)  
3190      &THEN  
3191         K(NSAV+1,1)=3   
3192         K(NSAV+2,1)=3   
3193         K(NSAV+3,1)=3   
3194         KCP=LUCOMP(K(NSAV+1,2)) 
3195         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))    
3196         JCON=4  
3197         IF(KQP.LT.0) JCON=5 
3198         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2) 
3199         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)   
3200         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3) 
3201         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)   
3202         MSTJ(92)=NSAV+1 
3203       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN 
3204         K(NSAV+1,1)=3   
3205         K(NSAV+3,1)=3   
3206         K(NSAV+1,4)=MSTU(5)*(NSAV+3)    
3207         K(NSAV+1,5)=MSTU(5)*(NSAV+3)    
3208         K(NSAV+3,4)=MSTU(5)*(NSAV+1)    
3209         K(NSAV+3,5)=MSTU(5)*(NSAV+1)    
3210         MSTJ(92)=NSAV+1 
3211       ENDIF 
3212     
3213 C...Mark decayed particle.  
3214       IF(K(IP,1).EQ.5) K(IP,1)=15   
3215       IF(K(IP,1).LE.10) K(IP,1)=11  
3216       K(IP,4)=NSAV+1    
3217       K(IP,5)=N 
3218     
3219       RETURN    
3220       END   
3221     
3222 C*********************************************************************  
3223     
3224       SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)  
3225     
3226 C...Purpose: to generate a new flavour pair and combine off a hadron.   
3227       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
3228       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
3229       SAVE 
3230     
3231 C...Default flavour values. Input consistency checks.   
3232       KF1A=IABS(KFL1)   
3233       KF2A=IABS(KFL2)   
3234       KFL3=0    
3235       KF=0  
3236       IF(KF1A.EQ.0) RETURN  
3237       IF(KF2A.NE.0) THEN    
3238         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN 
3239         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN    
3240         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN    
3241       ENDIF 
3242     
3243 C...Check if tabulated flavour probabilities are to be used.    
3244       IF(MSTJ(15).EQ.1) THEN    
3245         KTAB1=-1    
3246         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A  
3247         KFL1A=MOD(KF1A/1000,10) 
3248         KFL1B=MOD(KF1A/100,10)  
3249         KFL1S=MOD(KF1A,10)  
3250         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4) 
3251      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2 
3252         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1  
3253         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A  
3254         KTAB2=0 
3255         IF(KF2A.NE.0) THEN  
3256           KTAB2=-1  
3257           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A    
3258           KFL2A=MOD(KF2A/1000,10)   
3259           KFL2B=MOD(KF2A/100,10)    
3260           KFL2S=MOD(KF2A,10)    
3261           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)   
3262      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2   
3263           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1    
3264         ENDIF   
3265         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140  
3266       ENDIF 
3267     
3268 C...Parameters and breaking diquark parameter combinations. 
3269   100 PAR2=PARJ(2)  
3270       PAR3=PARJ(3)  
3271       PAR4=3.*PARJ(4)   
3272       IF(MSTJ(12).GE.2) THEN    
3273         PAR3M=SQRT(PARJ(3)) 
3274         PAR4M=1./(3.*SQRT(PARJ(4))) 
3275         PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))   
3276         PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))   
3277         PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+ 
3278      &  PAR2*PAR3M*PARJ(6)*PARJ(7)) 
3279         PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)    
3280         PARSM=MAX(PARS0,PARS1,PARS2)    
3281         PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))  
3282       ENDIF 
3283     
3284 C...Choice of whether to generate meson or baryon.  
3285       MBARY=0   
3286       KFDA=0    
3287       IF(KF1A.LE.10) THEN   
3288         IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)   
3289      &  MBARY=1 
3290         IF(KF2A.GT.10) MBARY=2  
3291         IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A  
3292       ELSE  
3293         MBARY=2 
3294         IF(KF1A.LE.10000) KFDA=KF1A 
3295       ENDIF 
3296     
3297 C...Possibility of process diquark -> meson + new diquark.  
3298       IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN  
3299         KFLDA=MOD(KFDA/1000,10) 
3300         KFLDB=MOD(KFDA/100,10)  
3301         KFLDS=MOD(KFDA,10)  
3302         WTDQ=PARS0  
3303         IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1    
3304         IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2    
3305         IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M) 
3306         IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1 
3307         IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN    
3308       ENDIF 
3309     
3310 C...Flavour for meson, possibly with new flavour.   
3311       IF(MBARY.LE.0) THEN   
3312         KFS=ISIGN(1,KFL1)   
3313         IF(MBARY.EQ.0) THEN 
3314           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)   
3315           KFLA=MAX(KF1A,KF2A+IABS(KFL3))    
3316           KFLB=MIN(KF1A,KF2A+IABS(KFL3))    
3317           IF(KFLA.NE.KF1A) KFS=-KFS 
3318     
3319 C...Splitting of diquark into meson plus new diquark.   
3320         ELSE    
3321           KFL1A=MOD(KF1A/1000,10)   
3322           KFL1B=MOD(KF1A/100,10)    
3323   110     KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A) 
3324           KFL1E=KFL1A+KFL1B-KFL1D   
3325           IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.   
3326      &    RLU(0).LT.PARDM)) THEN    
3327             KFL1D=KFL1A+KFL1B-KFL1D 
3328             KFL1E=KFL1A+KFL1B-KFL1E 
3329           ENDIF 
3330           KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))   
3331           IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).    
3332      &    OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))    
3333      &    GOTO 110  
3334           KFLDS=3   
3335           IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1    
3336           KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+  
3337      &    KFLDS,-KFL1)  
3338           KFLA=MAX(KFL1D,KFL3A) 
3339           KFLB=MIN(KFL1D,KFL3A) 
3340           IF(KFLA.NE.KFL1D) KFS=-KFS    
3341         ENDIF   
3342     
3343 C...Form meson, with spin and flavour mixing for diagonal states.   
3344         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0)) 
3345         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0)) 
3346         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0)) 
3347         IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN   
3348           IF(RLU(0).LT.PARJ(14)) KMUL=2 
3349         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN 
3350           RMUL=RLU(0)   
3351           IF(RMUL.LT.PARJ(15)) KMUL=3   
3352           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4    
3353           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5   
3354         ENDIF   
3355         KFLS=3  
3356         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1   
3357         IF(KMUL.EQ.5) KFLS=5    
3358         IF(KFLA.NE.KFLB) THEN   
3359           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA 
3360         ELSE    
3361           RMIX=RLU(0)   
3362           IMIX=2*KFLA+10*KMUL   
3363           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+   
3364      &    INT(RMIX+PARF(IMIX)))+KFLS    
3365           IF(KFLA.GE.4) KF=110*KFLA+KFLS    
3366         ENDIF   
3367         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)    
3368         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF) 
3369     
3370 C...Generate diquark flavour.   
3371       ELSE  
3372   120   IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN   
3373           KFLA=KF1A 
3374   130     KFLB=1+INT((2.+PAR2*PAR3)*RLU(0)) 
3375           KFLC=1+INT((2.+PAR2*PAR3)*RLU(0)) 
3376           KFLDS=1   
3377           IF(KFLB.GE.KFLC) KFLDS=3  
3378           IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130 
3379           IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130    
3380           KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1) 
3381     
3382 C...Take diquark flavour from input.    
3383         ELSEIF(KF1A.LE.10) THEN 
3384           KFLA=KF1A 
3385           KFLB=MOD(KF2A/1000,10)    
3386           KFLC=MOD(KF2A/100,10) 
3387           KFLDS=MOD(KF2A,10)    
3388     
3389 C...Generate (or take from input) quark to go with diquark. 
3390         ELSE    
3391           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)    
3392           KFLA=KF2A+IABS(KFL3)  
3393           KFLB=MOD(KF1A/1000,10)    
3394           KFLC=MOD(KF1A/100,10) 
3395           KFLDS=MOD(KF1A,10)    
3396         ENDIF   
3397     
3398 C...SU(6) factors for formation of baryon. Try again if fails.  
3399         KBARY=KFLDS 
3400         IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5 
3401         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1 
3402         WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)   
3403         IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN   
3404           WTDQ=PARS0    
3405           IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1    
3406           IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2    
3407           IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)   
3408           IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))  
3409           IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM) 
3410         ENDIF   
3411         IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120 
3412     
3413 C...Form baryon. Distinguish Lambda- and Sigmalike baryons. 
3414         KFLD=MAX(KFLA,KFLB,KFLC)    
3415         KFLF=MIN(KFLA,KFLB,KFLC)    
3416         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF   
3417         KFLS=2  
3418         IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.  
3419      &  PARF(60+KBARY)) KFLS=4  
3420         KFLL=0  
3421         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN    
3422           IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1    
3423           IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0)) 
3424           IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0)) 
3425         ENDIF   
3426         IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)    
3427         IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)    
3428       ENDIF 
3429       RETURN    
3430     
3431 C...Use tabulated probabilities to select new flavour and hadron.   
3432   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN 
3433         KT3L=1  
3434         KT3U=6  
3435       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN  
3436         KT3L=1  
3437         KT3U=6  
3438       ELSEIF(KTAB2.EQ.0) THEN   
3439         KT3L=1  
3440         KT3U=22 
3441       ELSE  
3442         KT3L=KTAB2  
3443         KT3U=KTAB2  
3444       ENDIF 
3445       RFL=0.    
3446       DO 150 KTS=0,2    
3447       DO 150 KT3=KT3L,KT3U  
3448       RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3) 
3449   150 CONTINUE  
3450       RFL=RLU(0)*RFL    
3451       DO 160 KTS=0,2    
3452       KTABS=KTS 
3453       DO 160 KT3=KT3L,KT3U  
3454       KTAB3=KT3 
3455       RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3) 
3456   160 IF(RFL.LE.0.) GOTO 170    
3457   170 CONTINUE  
3458     
3459 C...Reconstruct flavour of produced quark/diquark.  
3460       IF(KTAB3.LE.6) THEN   
3461         KFL3A=KTAB3 
3462         KFL3B=0 
3463         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13)) 
3464       ELSE  
3465         KFL3A=1 
3466         IF(KTAB3.GE.8) KFL3A=2  
3467         IF(KTAB3.GE.11) KFL3A=3 
3468         IF(KTAB3.GE.16) KFL3A=4 
3469         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2   
3470         KFL3=1000*KFL3A+100*KFL3B+1 
3471         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=  
3472      &  KFL3+2  
3473         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))  
3474       ENDIF 
3475     
3476 C...Reconstruct meson code. 
3477       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.  
3478      &KFL3B.NE.0)) THEN 
3479         RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+  
3480      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))  
3481         KF=110+2*KTABS+1    
3482         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1 
3483         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+    
3484      &  25*KTABS)) KF=330+2*KTABS+1 
3485       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN    
3486         KFLA=MAX(KTAB1,KTAB3)   
3487         KFLB=MIN(KTAB1,KTAB3)   
3488         KFS=ISIGN(1,KFL1)   
3489         IF(KFLA.NE.KF1A) KFS=-KFS   
3490         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA  
3491       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN    
3492         KFS=ISIGN(1,KFL1)   
3493         IF(KFL1A.EQ.KFL3A) THEN 
3494           KFLA=MAX(KFL1B,KFL3B) 
3495           KFLB=MIN(KFL1B,KFL3B) 
3496           IF(KFLA.NE.KFL1B) KFS=-KFS    
3497         ELSEIF(KFL1A.EQ.KFL3B) THEN 
3498           KFLA=KFL3A    
3499           KFLB=KFL1B    
3500           KFS=-KFS  
3501         ELSEIF(KFL1B.EQ.KFL3A) THEN 
3502           KFLA=KFL1A    
3503           KFLB=KFL3B    
3504         ELSEIF(KFL1B.EQ.KFL3B) THEN 
3505           KFLA=MAX(KFL1A,KFL3A) 
3506           KFLB=MIN(KFL1A,KFL3A) 
3507           IF(KFLA.NE.KFL1A) KFS=-KFS    
3508         ELSE    
3509           CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')  
3510           GOTO 100  
3511         ENDIF   
3512         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA  
3513     
3514 C...Reconstruct baryon code.    
3515       ELSE  
3516         IF(KTAB1.GE.7) THEN 
3517           KFLA=KFL3A    
3518           KFLB=KFL1A    
3519           KFLC=KFL1B    
3520         ELSE    
3521           KFLA=KFL1A    
3522           KFLB=KFL3A    
3523           KFLC=KFL3B    
3524         ENDIF   
3525         KFLD=MAX(KFLA,KFLB,KFLC)    
3526         KFLF=MIN(KFLA,KFLB,KFLC)    
3527         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF   
3528         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)  
3529         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)    
3530       ENDIF 
3531     
3532 C...Check that constructed flavour code is an allowed one.  
3533       IF(KFL2.NE.0) KFL3=0  
3534       KC=LUCOMP(KF) 
3535       IF(KC.EQ.0) THEN  
3536         CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '// 
3537      &  'failed')   
3538         GOTO 100    
3539       ENDIF 
3540     
3541       RETURN    
3542       END   
3543     
3544 C*********************************************************************  
3545     
3546       SUBROUTINE LUPTDI(KFL,PX,PY)  
3547     
3548 C...Purpose: to generate transverse momentum according to a Gaussian.   
3549       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
3550       SAVE 
3551     
3552 C...Generate p_T and azimuthal angle, gives p_x and p_y.    
3553       KFLA=IABS(KFL)    
3554       PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0)))) 
3555       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT  
3556       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0. 
3557       PHI=PARU(2)*RLU(0)    
3558       PX=PT*COS(PHI)    
3559       PY=PT*SIN(PHI)    
3560     
3561       RETURN    
3562       END   
3563     
3564 C*********************************************************************  
3565     
3566       SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z) 
3567     
3568 C...Purpose: to generate the longitudinal splitting variable z. 
3569       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
3570       SAVE /LUDAT1/ 
3571     
3572 C...Check if heavy flavour fragmentation.   
3573       KFLA=IABS(KFL1)   
3574       KFLB=IABS(KFL2)   
3575       ZDIVC=0.
3576       ZDIV=0.
3577       fint=0.
3578       KFLH=KFLA 
3579       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10) 
3580     
3581 C...Lund symmetric scaling function: determine parameters of shape. 
3582       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3)) THEN   
3583         FA=PARJ(41) 
3584         IF(MSTJ(91).EQ.1) FA=PARJ(43)   
3585         IF(KFLB.GE.10) FA=FA+PARJ(45)   
3586         FB=PARJ(42)*PR  
3587         IF(MSTJ(91).EQ.1) FB=PARJ(44)*PR    
3588         FC=1.   
3589         IF(KFLA.GE.10) FC=FC-PARJ(45)   
3590         IF(KFLB.GE.10) FC=FC+PARJ(45)   
3591         MC=1    
3592         IF(ABS(FC-1.).GT.0.01) MC=2 
3593     
3594 C...Determine position of maximum. Special cases for a = 0 or a = c.    
3595         IF(FA.LT.0.02) THEN 
3596           MA=1  
3597           ZMAX=1.   
3598           IF(FC.GT.FB) ZMAX=FB/FC   
3599         ELSEIF(ABS(FC-FA).LT.0.01) THEN 
3600           MA=2  
3601           ZMAX=FB/(FB+FC)   
3602         ELSE    
3603           MA=3  
3604           ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)    
3605           IF(ZMAX.GT.0.99.AND.FB.GT.100.) ZMAX=1.-FA/FB 
3606         ENDIF   
3607     
3608 C...Subdivide z range if distribution very peaked near endpoint.    
3609         MMAX=2  
3610         IF(ZMAX.LT.0.1) THEN    
3611           MMAX=1    
3612           ZDIV=2.75*ZMAX    
3613           IF(MC.EQ.1) THEN  
3614             FINT=1.-LOG(ZDIV)   
3615           ELSE  
3616             ZDIVC=ZDIV**(1.-FC) 
3617             FINT=1.+(1.-1./ZDIVC)/(FC-1.)   
3618           ENDIF 
3619         ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN  
3620           MMAX=3    
3621           FSCB=SQRT(4.+(FC/FB)**2)  
3622           ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))  
3623           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)    
3624           ZDIV=MIN(ZMAX,MAX(0.,ZDIV))   
3625           FINT=1.+FB*(1.-ZDIV)  
3626         ENDIF   
3627     
3628 C...Choice of z, preweighted for peaks at low or high z.    
3629   100   Z=RLU(0)    
3630         FPRE=1. 
3631         IF(MMAX.EQ.1) THEN  
3632           IF(FINT*RLU(0).LE.1.) THEN    
3633             Z=ZDIV*Z    
3634           ELSEIF(MC.EQ.1) THEN  
3635             Z=ZDIV**Z   
3636             FPRE=ZDIV/Z 
3637           ELSE  
3638             Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC)) 
3639             FPRE=(ZDIV/Z)**FC   
3640           ENDIF 
3641         ELSEIF(MMAX.EQ.3) THEN  
3642           IF(FINT*RLU(0).LE.1.) THEN    
3643             Z=ZDIV+LOG(Z)/FB    
3644             FPRE=EXP(FB*(Z-ZDIV))   
3645           ELSE  
3646             Z=ZDIV+Z*(1.-ZDIV)  
3647           ENDIF 
3648         ENDIF   
3649     
3650 C...Weighting according to correct formula. 
3651         IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100    
3652         FVAL=(ZMAX/Z)**FC*EXP(FB*(1./ZMAX-1./Z))    
3653         IF(MA.GE.2) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL    
3654         IF(FVAL.LT.RLU(0)*FPRE) GOTO 100    
3655     
3656 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.  
3657       ELSE  
3658         FC=PARJ(50+MAX(1,KFLH)) 
3659         IF(MSTJ(91).EQ.1) FC=PARJ(59)   
3660   110   Z=RLU(0)    
3661         IF(FC.GE.0..AND.FC.LE.1.) THEN  
3662           IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)  
3663         ELSEIF(FC.GT.-1.) THEN  
3664           IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110 
3665         ELSE    
3666           IF(FC.GT.0.) Z=1.-Z**(1./FC)  
3667           IF(FC.LT.0.) Z=Z**(-1./FC)    
3668         ENDIF   
3669       ENDIF 
3670     
3671       RETURN    
3672       END   
3673     
3674 C*********************************************************************  
3675     
3676       SUBROUTINE LUSHOW(IP1,IP2,QMAX)   
3677     
3678 C...Purpose: to generate timelike parton showers from given partons.    
3679       IMPLICIT DOUBLE PRECISION(D)  
3680       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3681       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
3682       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
3683       DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),  
3684      &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4)   
3685       SAVE
3686 
3687 C...Initialization of cutoff masses etc.    
3688       IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.  
3689      &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN   
3690       PMTH(1,21)=ULMASS(21) 
3691       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)   
3692       PMTH(3,21)=2.*PMTH(2,21)  
3693       PMTH(4,21)=PMTH(3,21) 
3694       PMTH(5,21)=PMTH(3,21) 
3695       PMTH(1,22)=ULMASS(22) 
3696       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)   
3697       PMTH(3,22)=2.*PMTH(2,22)  
3698       PMTH(4,22)=PMTH(3,22) 
3699       PMTH(5,22)=PMTH(3,22) 
3700       PMQTH1=PARJ(82)   
3701       IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))   
3702       PMQTH2=PMTH(2,21) 
3703       IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))   
3704       DO 100 IF=1,8 
3705       PMTH(1,IF)=ULMASS(IF) 
3706       PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2) 
3707       PMTH(3,IF)=PMTH(2,IF)+PMQTH2  
3708       PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)    
3709   100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)    
3710       PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2  
3711       ALAMS=PARJ(81)**2 
3712       ALFM=LOG(PT2MIN/ALAMS)    
3713     
3714 C...Store positions of shower initiating partons.   
3715       M3JC=0    
3716       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN 
3717         NPA=1   
3718         IPA(1)=IP1  
3719       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-   
3720      &MSTU(32))) THEN   
3721         NPA=2   
3722         IPA(1)=IP1  
3723         IPA(2)=IP2  
3724       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.  
3725      &AND.IP2.GE.-3) THEN   
3726         NPA=IABS(IP2)   
3727         DO 110 I=1,NPA  
3728   110   IPA(I)=IP1+I-1  
3729       ELSE  
3730         CALL LUERRM(12, 
3731      &  '(LUSHOW:) failed to reconstruct showering system') 
3732         IF(MSTU(21).GE.1) RETURN    
3733       ENDIF 
3734     
3735 C...Check on phase space available for emission.    
3736       IREJ=0    
3737       DO 120 J=1,5  
3738   120 PS(J)=0.  
3739       PM=0. 
3740       DO 130 I=1,NPA    
3741       KFLA(I)=IABS(K(IPA(I),2)) 
3742       PMA(I)=P(IPA(I),5)    
3743       IF(KFLA(I).NE.0.AND.(KFLA(I).LE.8.OR.KFLA(I).EQ.21))  
3744      &PMA(I)=PMTH(3,KFLA(I))    
3745       PM=PM+PMA(I)  
3746       IF(KFLA(I).EQ.0.OR.(KFLA(I).GT.8.AND.KFLA(I).NE.21).OR.   
3747      &PMA(I).GT.QMAX) IREJ=IREJ+1   
3748       DO 130 J=1,4  
3749   130 PS(J)=PS(J)+P(IPA(I),J)   
3750       IF(IREJ.EQ.NPA) RETURN    
3751       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))   
3752       IF(NPA.EQ.1) PS(5)=PS(4)  
3753       IF(PS(5).LE.PM+PMQTH1) RETURN 
3754       IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN   
3755         IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.  
3756      &  KFLA(2).LE.8) M3JC=1    
3757         IF(MSTJ(47).GE.2) M3JC=1    
3758       ENDIF 
3759     
3760 C...Define imagined single initiator of shower for parton system.   
3761       NS=N  
3762       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN  
3763         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')   
3764         IF(MSTU(21).GE.1) RETURN    
3765       ENDIF 
3766       IF(NPA.GE.2) THEN 
3767         K(N+1,1)=11 
3768         K(N+1,2)=21 
3769         K(N+1,3)=0  
3770         K(N+1,4)=0  
3771         K(N+1,5)=0  
3772         P(N+1,1)=0. 
3773         P(N+1,2)=0. 
3774         P(N+1,3)=0. 
3775         P(N+1,4)=PS(5)  
3776         P(N+1,5)=PS(5)  
3777         V(N+1,5)=PS(5)**2   
3778         N=N+1   
3779       ENDIF 
3780     
3781 C...Loop over partons that may branch.  
3782       NEP=NPA   
3783       IM=NS 
3784       IF(NPA.EQ.1) IM=NS-1  
3785   140 IM=IM+1   
3786       IF(N.GT.NS) THEN  
3787         IF(IM.GT.N) GOTO 380    
3788         KFLM=IABS(K(IM,2))  
3789         IF(KFLM.EQ.0.OR.(KFLM.GT.8.AND.KFLM.NE.21)) GOTO 140    
3790         IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140    
3791         IGM=K(IM,3) 
3792       ELSE  
3793         IGM=-1  
3794       ENDIF 
3795       IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN  
3796         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')   
3797         IF(MSTU(21).GE.1) RETURN    
3798       ENDIF 
3799     
3800 C...Position of aunt (sister to branching parton).  
3801 C...Origin and flavour of daughters.    
3802       IAU=0 
3803       IF(IGM.GT.0) THEN 
3804         IF(K(IM-1,3).EQ.IGM) IAU=IM-1   
3805         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1 
3806       ENDIF 
3807       IF(IGM.GE.0) THEN 
3808         K(IM,4)=N+1 
3809         DO 150 I=1,NEP  
3810   150   K(N+I,3)=IM 
3811       ELSE  
3812         K(N+1,3)=IPA(1) 
3813       ENDIF 
3814       IF(IGM.LE.0) THEN 
3815         DO 160 I=1,NEP  
3816   160   K(N+I,2)=K(IPA(I),2)    
3817       ELSEIF(KFLM.NE.21) THEN   
3818         K(N+1,2)=K(IM,2)    
3819         K(N+2,2)=K(IM,5)    
3820       ELSEIF(K(IM,5).EQ.21) THEN    
3821         K(N+1,2)=21 
3822         K(N+2,2)=21 
3823       ELSE  
3824         K(N+1,2)=K(IM,5)    
3825         K(N+2,2)=-K(IM,5)   
3826       ENDIF 
3827     
3828 C...Reset flags on daughers and tries made. 
3829       DO 170 IP=1,NEP   
3830       K(N+IP,1)=3   
3831       K(N+IP,4)=0   
3832       K(N+IP,5)=0   
3833       KFLD(IP)=IABS(K(N+IP,2))  
3834       ITRY(IP)=0    
3835       ISL(IP)=0 
3836       ISI(IP)=0 
3837   170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1 
3838       ISLM=0    
3839     
3840 C...Maximum virtuality of daughters.    
3841       IF(IGM.LE.0) THEN 
3842         DO 180 I=1,NPA  
3843         IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)- 
3844      &  PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)  
3845         P(N+I,5)=MIN(QMAX,PS(5))    
3846         IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))    
3847   180   IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)    
3848       ELSE  
3849         IF(MSTJ(43).LE.2) PEM=V(IM,2)   
3850         IF(MSTJ(43).GE.3) PEM=P(IM,4)   
3851         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)   
3852         P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)  
3853         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)  
3854       ENDIF 
3855       DO 190 I=1,NEP    
3856       PMSD(I)=P(N+I,5)  
3857       IF(ISI(I).EQ.1) THEN  
3858         IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))    
3859       ENDIF 
3860   190 V(N+I,5)=P(N+I,5)**2  
3861     
3862 C...Choose one of the daughters for evolution.  
3863   200 INUM=0    
3864       IF(NEP.EQ.1) INUM=1   
3865       DO 210 I=1,NEP    
3866   210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I  
3867       DO 220 I=1,NEP    
3868       IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN   
3869         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I  
3870       ENDIF 
3871   220 CONTINUE  
3872       IF(INUM.EQ.0) THEN    
3873         RMAX=0. 
3874         DO 230 I=1,NEP  
3875         IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN  
3876           RPM=P(N+I,5)/PMSD(I)  
3877           IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN  
3878             RMAX=RPM    
3879             INUM=I  
3880           ENDIF 
3881         ENDIF   
3882   230   CONTINUE    
3883       ENDIF 
3884     
3885 C...Store information on choice of evolving daughter.   
3886       INUM=MAX(1,INUM)  
3887       IEP(1)=N+INUM 
3888       DO 240 I=2,NEP    
3889       IEP(I)=IEP(I-1)+1 
3890   240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1    
3891       DO 250 I=1,NEP    
3892   250 KFL(I)=IABS(K(IEP(I),2))  
3893       ITRY(INUM)=ITRY(INUM)+1   
3894       IF(ITRY(INUM).GT.200) THEN    
3895         CALL LUERRM(14,'(LUSHOW:) caught in infinite loop') 
3896         IF(MSTU(21).GE.1) RETURN    
3897       ENDIF 
3898       Z=0.5 
3899       IF(KFL(1).EQ.0.OR.(KFL(1).GT.8.AND.KFL(1).NE.21)) GOTO 300    
3900       IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300    
3901     
3902 C...Calculate allowed z range.  
3903       IF(NEP.EQ.1) THEN 
3904         PMED=PS(4)  
3905       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN    
3906         PMED=P(IM,5)    
3907       ELSE  
3908         IF(INUM.EQ.1) PMED=V(IM,1)*PEM  
3909         IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM 
3910       ENDIF 
3911       IF(MOD(MSTJ(43),2).EQ.1) THEN 
3912         ZC=PMTH(2,21)/PMED  
3913         ZCE=PMTH(2,22)/PMED 
3914       ELSE  
3915         ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))    
3916         IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2  
3917         ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))   
3918         IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2    
3919       ENDIF 
3920       ZC=MIN(ZC,0.491)  
3921       ZCE=MIN(ZCE,0.491)    
3922       IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.  
3923      &MIN(ZC,ZCE).GT.0.49)) THEN    
3924         P(IEP(1),5)=PMTH(1,KFL(1))  
3925         V(IEP(1),5)=P(IEP(1),5)**2  
3926         GOTO 300    
3927       ENDIF 
3928     
3929 C...Integral of Altarelli-Parisi z kernel for QCD.  
3930       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN   
3931         FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)    
3932       ELSEIF(MSTJ(49).EQ.0) THEN    
3933         FBR=(8./3.)*LOG((1.-ZC)/ZC) 
3934     
3935 C...Integral of Altarelli-Parisi z kernel for scalar gluon. 
3936       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN   
3937         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC) 
3938       ELSEIF(MSTJ(49).EQ.1) THEN    
3939         FBR=(1.-2.*ZC)/3.   
3940         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR   
3941     
3942 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. 
3943       ELSEIF(KFL(1).EQ.21) THEN 
3944         FBR=6.*MSTJ(45)*(0.5-ZC)    
3945       ELSE  
3946         FBR=2.*LOG((1.-ZC)/ZC)  
3947       ENDIF 
3948     
3949 C...Integral of Altarelli-Parisi kernel for photon emission.    
3950       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) 
3951      &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)  
3952     
3953 C...Inner veto algorithm starts. Find maximum mass for evolution.   
3954   260 PMS=V(IEP(1),5)   
3955       IF(IGM.GE.0) THEN 
3956         PM2=0.  
3957         DO 270 I=2,NEP  
3958         PM=P(IEP(I),5)  
3959         IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=   
3960      &  PMTH(2,KFL(I))  
3961   270   PM2=PM2+PM  
3962         PMS=MIN(PMS,(P(IM,5)-PM2)**2)   
3963       ENDIF 
3964     
3965 C...Select mass for daughter in QCD evolution.  
3966       B0=27./6. 
3967       DO 280 IF=4,MSTJ(45)  
3968   280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6. 
3969       IF(MSTJ(44).LE.0) THEN    
3970         PMSQCD=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))  
3971       ELSEIF(MSTJ(44).EQ.1) THEN    
3972         PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))    
3973       ELSE  
3974         PMSQCD=PMS*RLU(0)**(ALFM*B0/FBR)    
3975       ENDIF 
3976       IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD= 
3977      &PMTH(2,KFL(1))**2 
3978       V(IEP(1),5)=PMSQCD    
3979       MCE=1 
3980     
3981 C...Select mass for daughter in QED evolution.  
3982       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN    
3983         PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE))) 
3984         IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=  
3985      &  PMTH(2,KFL(1))**2   
3986         IF(PMSQED.GT.PMSQCD) THEN   
3987           V(IEP(1),5)=PMSQED    
3988           MCE=2 
3989         ENDIF   
3990       ENDIF 
3991     
3992 C...Check whether daughter mass below cutoff.   
3993       P(IEP(1),5)=SQRT(V(IEP(1),5)) 
3994       IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN    
3995         P(IEP(1),5)=PMTH(1,KFL(1))  
3996         V(IEP(1),5)=P(IEP(1),5)**2  
3997         GOTO 300    
3998       ENDIF 
3999     
4000 C...Select z value of branching: q -> qgamma.   
4001       IF(MCE.EQ.2) THEN 
4002         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)    
4003         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260   
4004         K(IEP(1),5)=22  
4005     
4006 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.  
4007       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN   
4008         Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)   
4009         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260   
4010         K(IEP(1),5)=21  
4011       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN    
4012         Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)  
4013         IF(RLU(0).GT.0.5) Z=1.-Z    
4014         IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260 
4015         K(IEP(1),5)=21  
4016       ELSEIF(MSTJ(49).NE.1) THEN    
4017         Z=ZC+(1.-2.*ZC)*RLU(0)  
4018         IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260   
4019         KFLB=1+INT(MSTJ(45)*RLU(0)) 
4020         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)  
4021         IF(PMQ.GE.1.) GOTO 260  
4022         PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)   
4023         IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.   
4024      &  RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260    
4025         K(IEP(1),5)=KFLB    
4026     
4027 C...Ditto for scalar gluon model.   
4028       ELSEIF(KFL(1).NE.21) THEN 
4029         Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))  
4030         K(IEP(1),5)=21  
4031       ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN  
4032         Z=ZC+(1.-2.*ZC)*RLU(0)  
4033         K(IEP(1),5)=21  
4034       ELSE  
4035         Z=ZC+(1.-2.*ZC)*RLU(0)  
4036         KFLB=1+INT(MSTJ(45)*RLU(0)) 
4037         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)  
4038         IF(PMQ.GE.1.) GOTO 260  
4039         K(IEP(1),5)=KFLB    
4040       ENDIF 
4041       IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN   
4042         IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260 
4043         IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260 
4044       ENDIF 
4045     
4046 C...Check if z consistent with chosen m.    
4047       IF(KFL(1).EQ.21) THEN 
4048         KFLGD1=IABS(K(IEP(1),5))    
4049         KFLGD2=KFLGD1   
4050       ELSE  
4051         KFLGD1=KFL(1)   
4052         KFLGD2=IABS(K(IEP(1),5))    
4053       ENDIF 
4054       IF(NEP.EQ.1) THEN 
4055         PED=PS(4)   
4056       ELSEIF(NEP.GE.3) THEN 
4057         PED=P(IEP(1),4) 
4058       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN    
4059         PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)    
4060       ELSE  
4061         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM   
4062         IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM  
4063       ENDIF 
4064       IF(MOD(MSTJ(43),2).EQ.1) THEN 
4065         PMQTH3=0.5*PARJ(82) 
4066         IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)    
4067         PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)  
4068         PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)  
4069         ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-  
4070      &  4.*PMQ1*PMQ2))) 
4071         ZH=1.+PMQ1-PMQ2 
4072       ELSE  
4073         ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))  
4074         ZH=1.   
4075       ENDIF 
4076       ZL=0.5*(ZH-ZD)    
4077       ZU=0.5*(ZH+ZD)    
4078       IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260   
4079       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL* 
4080      &(1.-ZU))) 
4081       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))    
4082     
4083 C...Three-jet matrix element correction.    
4084       IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN   
4085         X1=Z*(1.+V(IEP(1),5)/V(NS+1,5)) 
4086         X2=1.-V(IEP(1),5)/V(NS+1,5) 
4087         X3=(1.-X1)+(1.-X2)  
4088         IF(MCE.EQ.2) THEN   
4089           KI1=K(IPA(INUM),2)    
4090           KI2=K(IPA(3-INUM),2)  
4091           QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3. 
4092           QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3. 
4093           WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+ 
4094      &    QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)    
4095           WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)  
4096         ELSEIF(MSTJ(49).NE.1) THEN  
4097           WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+  
4098      &    (1.-X2)/X3*(X2/(2.-X1))**2    
4099           WME=X1**2+X2**2   
4100         ELSE    
4101           WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)   
4102           WME=X3**2 
4103         ENDIF   
4104         IF(WME.LT.RLU(0)*WSHOW) GOTO 260    
4105     
4106 C...Impose angular ordering by rejection of nonordered emission.    
4107       ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN  
4108         MAOM=1  
4109         ZM=V(IM,1)  
4110         IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1) 
4111         THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5) 
4112         IAOM=IM 
4113   290   IF(K(IAOM,5).EQ.22) THEN    
4114           IAOM=K(IAOM,3)    
4115           IF(K(IAOM,3).LE.NS) MAOM=0    
4116           IF(MAOM.EQ.1) GOTO 290    
4117         ENDIF   
4118         IF(MAOM.EQ.1) THEN  
4119           THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)    
4120           IF(THE2ID.LT.THE2IM) GOTO 260 
4121         ENDIF   
4122       ENDIF 
4123     
4124 C...Impose user-defined maximum angle at first branching.   
4125       IF(MSTJ(48).EQ.1) THEN    
4126         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN  
4127           THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)  
4128           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260 
4129         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN    
4130           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)  
4131           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260 
4132         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN    
4133           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)  
4134           IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260 
4135         ENDIF   
4136       ENDIF 
4137     
4138 C...End of inner veto algorithm. Check if only one leg evolved so far.  
4139   300 V(IEP(1),1)=Z 
4140       ISL(1)=0  
4141       ISL(2)=0  
4142       IF(NEP.EQ.1) GOTO 330 
4143       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200  
4144       DO 310 I=1,NEP    
4145       IF(ITRY(I).EQ.0.AND.KFLD(I).GT.0.AND.(KFLD(I).LE.8.OR.KFLD(I).EQ. 
4146      &21)) THEN 
4147         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200    
4148       ENDIF 
4149   310 CONTINUE  
4150     
4151 C...Check if chosen multiplet m1,m2,z1,z2 is physical.  
4152       IF(NEP.EQ.3) THEN 
4153         PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))    
4154         PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))    
4155         PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))    
4156         PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-   
4157      &  PA1S**2-PA2S**2-PA3S**2)/PA1S   
4158         IF(PTS.LE.0.) GOTO 200  
4159       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN    
4160         DO 320 I1=N+1,N+2   
4161         KFLDA=IABS(K(I1,2)) 
4162         IF(KFLDA.EQ.0.OR.(KFLDA.GT.8.AND.KFLDA.NE.21)) GOTO 320 
4163         IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320   
4164         IF(KFLDA.EQ.21) THEN    
4165           KFLGD1=IABS(K(I1,5))  
4166           KFLGD2=KFLGD1 
4167         ELSE    
4168           KFLGD1=KFLDA  
4169           KFLGD2=IABS(K(I1,5))  
4170         ENDIF   
4171         I2=2*N+3-I1 
4172         IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN  
4173           PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) 
4174         ELSE    
4175           IF(I1.EQ.N+1) ZM=V(IM,1)  
4176           IF(I1.EQ.N+2) ZM=1.-V(IM,1)   
4177           PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-  
4178      &    4.*V(N+1,5)*V(N+2,5)) 
4179           PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)    
4180         ENDIF   
4181         IF(MOD(MSTJ(43),2).EQ.1) THEN   
4182           PMQTH3=0.5*PARJ(82)   
4183           IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)  
4184           PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)    
4185           PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)    
4186           ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-    
4187      &    4.*PMQ1*PMQ2)))   
4188           ZH=1.+PMQ1-PMQ2   
4189         ELSE    
4190           ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))    
4191           ZH=1. 
4192         ENDIF   
4193         ZL=0.5*(ZH-ZD)  
4194         ZU=0.5*(ZH+ZD)  
4195         IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1 
4196         IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1 
4197         IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))   
4198         IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))   
4199   320   CONTINUE    
4200         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN  
4201           ISL(3-ISLM)=0 
4202           ISLM=3-ISLM   
4203         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN    
4204           ZDR1=MAX(0.,V(N+1,3)/V(N+1,4)-1.) 
4205           ZDR2=MAX(0.,V(N+2,3)/V(N+2,4)-1.) 
4206           IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0   
4207           IF(ISL(1).EQ.1) ISL(2)=0  
4208           IF(ISL(1).EQ.0) ISLM=1    
4209           IF(ISL(2).EQ.0) ISLM=2    
4210         ENDIF   
4211         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200 
4212       ENDIF 
4213       IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.    
4214      &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN 
4215         PMQ1=V(N+1,5)/V(IM,5)   
4216         PMQ2=V(N+2,5)/V(IM,5)   
4217         ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-  
4218      &  4.*PMQ1*PMQ2))) 
4219         ZH=1.+PMQ1-PMQ2 
4220         ZL=0.5*(ZH-ZD)  
4221         ZU=0.5*(ZH+ZD)  
4222         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200 
4223       ENDIF 
4224     
4225 C...Accepted branch. Construct four-momentum for initial partons.   
4226   330 MAZIP=0   
4227       MAZIC=0   
4228       IF(NEP.EQ.1) THEN 
4229         P(N+1,1)=0. 
4230         P(N+1,2)=0. 
4231         P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-   
4232      &  P(N+1,5)))) 
4233         P(N+1,4)=P(IPA(1),4)    
4234         V(N+1,2)=P(N+1,4)   
4235       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN    
4236         PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)    
4237         P(N+1,1)=0. 
4238         P(N+1,2)=0. 
4239         P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))  
4240         P(N+1,4)=PED1   
4241         P(N+2,1)=0. 
4242         P(N+2,2)=0. 
4243         P(N+2,3)=-P(N+1,3)  
4244         P(N+2,4)=P(IM,5)-PED1   
4245         V(N+1,2)=P(N+1,4)   
4246         V(N+2,2)=P(N+2,4)   
4247       ELSEIF(NEP.EQ.3) THEN 
4248         P(N+1,1)=0. 
4249         P(N+1,2)=0. 
4250         P(N+1,3)=SQRT(MAX(0.,PA1S)) 
4251         P(N+2,1)=SQRT(PTS)  
4252         P(N+2,2)=0. 
4253         P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)  
4254         P(N+3,1)=-P(N+2,1)  
4255         P(N+3,2)=0. 
4256         P(N+3,3)=-(P(N+1,3)+P(N+2,3))   
4257         V(N+1,2)=P(N+1,4)   
4258         V(N+2,2)=P(N+2,4)   
4259         V(N+3,2)=P(N+3,4)   
4260     
4261 C...Construct transverse momentum for ordinary branching in shower. 
4262       ELSE  
4263         ZM=V(IM,1)  
4264         PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))   
4265         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)    
4266         IF(PZM.LE.0.) THEN  
4267           PTS=0.    
4268         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN   
4269           PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)- 
4270      &    ZM*V(N+2,5))-0.25*PMLS)/PZM**2    
4271         ELSE    
4272           PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2  
4273         ENDIF   
4274         PT=SQRT(MAX(0.,PTS))    
4275     
4276 C...Find coefficient of azimuthal asymmetry due to gluon polarization.  
4277         HAZIP=0.    
4278         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.    
4279      &  AND.IAU.NE.0) THEN  
4280           IF(K(IGM,3).NE.0) MAZIP=1 
4281           ZAU=V(IGM,1)  
4282           IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)   
4283           IF(MAZIP.EQ.0) ZAU=0. 
4284           IF(K(IGM,2).NE.21) THEN   
4285             HAZIP=2.*ZAU/(1.+ZAU**2)    
4286           ELSE  
4287             HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2    
4288           ENDIF 
4289           IF(K(N+1,2).NE.21) THEN   
4290             HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM)) 
4291           ELSE  
4292             HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2 
4293           ENDIF 
4294         ENDIF   
4295     
4296 C...Find coefficient of azimuthal asymmetry due to soft gluon   
4297 C...interference.   
4298         HAZIC=0.    
4299         IF(MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.K(N+2,2).EQ.21).    
4300      &  AND.IAU.NE.0) THEN  
4301           IF(K(IGM,3).NE.0) MAZIC=N+1   
4302           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2    
4303           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.   
4304      &    ZM.GT.0.5) MAZIC=N+2  
4305           IF(K(IAU,2).EQ.22) MAZIC=0    
4306           ZS=ZM 
4307           IF(MAZIC.EQ.N+2) ZS=1.-ZM 
4308           ZGM=V(IGM,1)  
4309           IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)   
4310           IF(MAZIC.EQ.0) ZGM=1. 
4311           HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))  
4312           HAZIC=MIN(0.95,HAZIC) 
4313         ENDIF   
4314       ENDIF 
4315     
4316 C...Construct kinematics for ordinary branching in shower.  
4317   340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN    
4318         IF(MOD(MSTJ(43),2).EQ.1) THEN   
4319           P(N+1,4)=PEM*V(IM,1)  
4320         ELSE    
4321           P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ 
4322      &    SQRT(PMLS)*ZM)/V(IM,5)    
4323         ENDIF   
4324         PHI=PARU(2)*RLU(0)  
4325         P(N+1,1)=PT*COS(PHI)    
4326         P(N+1,2)=PT*SIN(PHI)    
4327         IF(PZM.GT.0.) THEN  
4328           P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM  
4329         ELSE    
4330           P(N+1,3)=0.   
4331         ENDIF   
4332         P(N+2,1)=-P(N+1,1)  
4333         P(N+2,2)=-P(N+1,2)  
4334         P(N+2,3)=PZM-P(N+1,3)   
4335         P(N+2,4)=PEM-P(N+1,4)   
4336         IF(MSTJ(43).LE.2) THEN  
4337           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)  
4338           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)  
4339         ENDIF   
4340       ENDIF 
4341     
4342 C...Rotate and boost daughters. 
4343       IF(IGM.GT.0) THEN 
4344         IF(MSTJ(43).LE.2) THEN  
4345           BEX=P(IGM,1)/P(IGM,4) 
4346           BEY=P(IGM,2)/P(IGM,4) 
4347           BEZ=P(IGM,3)/P(IGM,4) 
4348           GA=P(IGM,4)/P(IGM,5)  
4349           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-   
4350      &    P(IM,4))  
4351         ELSE    
4352           BEX=0.    
4353           BEY=0.    
4354           BEZ=0.    
4355           GA=1. 
4356           GABEP=0.  
4357         ENDIF   
4358         THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+   
4359      &  (P(IM,2)+GABEP*BEY)**2))    
4360         PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) 
4361         DO 350 I=N+1,N+2    
4362         DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ 
4363      &  SIN(THE)*COS(PHI)*P(I,3)    
4364         DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ 
4365      &  SIN(THE)*SIN(PHI)*P(I,3)    
4366         DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)  
4367         DP(4)=P(I,4)    
4368         DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)   
4369         DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))    
4370         P(I,1)=DP(1)+DGABP*BEX  
4371         P(I,2)=DP(2)+DGABP*BEY  
4372         P(I,3)=DP(3)+DGABP*BEZ  
4373   350   P(I,4)=GA*(DP(4)+DBP)   
4374       ENDIF 
4375     
4376 C...Weight with azimuthal distribution, if required.    
4377       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN 
4378         DO 360 J=1,3    
4379         DPT(1,J)=P(IM,J)    
4380         DPT(2,J)=P(IAU,J)   
4381   360   DPT(3,J)=P(N+1,J)   
4382         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)  
4383         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)  
4384         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2    
4385         DO 370 J=1,3    
4386         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM    
4387   370   DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM    
4388         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)  
4389         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)  
4390         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN 
4391           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ 
4392      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))    
4393           IF(MAZIP.NE.0) THEN   
4394             IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))   
4395      &      GOTO 340    
4396           ENDIF 
4397           IF(MAZIC.NE.0) THEN   
4398             IF(MAZIC.EQ.N+2) CAD=-CAD   
4399             IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).    
4400      &      LT.RLU(0)) GOTO 340 
4401           ENDIF 
4402         ENDIF   
4403       ENDIF 
4404     
4405 C...Continue loop over partons that may branch, until none left.    
4406       IF(IGM.GE.0) K(IM,1)=14   
4407       N=N+NEP   
4408       NEP=2 
4409       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN  
4410         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')   
4411         IF(MSTU(21).GE.1) N=NS  
4412         IF(MSTU(21).GE.1) RETURN    
4413       ENDIF 
4414       GOTO 140  
4415     
4416 C...Set information on imagined shower initiator.   
4417   380 IF(NPA.GE.2) THEN 
4418         K(NS+1,1)=11    
4419         K(NS+1,2)=94    
4420         K(NS+1,3)=IP1   
4421         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2   
4422         K(NS+1,4)=NS+2  
4423         K(NS+1,5)=NS+1+NPA  
4424         IIM=1   
4425       ELSE  
4426         IIM=0   
4427       ENDIF 
4428     
4429 C...Reconstruct string drawing information. 
4430       DO 390 I=NS+1+IIM,N   
4431       IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN    
4432         K(I,1)=1    
4433       ELSEIF(K(I,1).LE.10) THEN 
4434         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) 
4435         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) 
4436       ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN 
4437         ID1=MOD(K(I,4),MSTU(5)) 
4438         IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1   
4439         ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 
4440         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 
4441         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 
4442         K(ID1,4)=K(ID1,4)+MSTU(5)*I 
4443         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2   
4444         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1   
4445         K(ID2,5)=K(ID2,5)+MSTU(5)*I 
4446       ELSE  
4447         ID1=MOD(K(I,4),MSTU(5)) 
4448         ID2=ID1+1   
4449         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 
4450         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 
4451         K(ID1,4)=K(ID1,4)+MSTU(5)*I 
4452         K(ID1,5)=K(ID1,5)+MSTU(5)*I 
4453         K(ID2,4)=0  
4454         K(ID2,5)=0  
4455       ENDIF 
4456   390 CONTINUE  
4457     
4458 C...Transformation from CM frame.   
4459       IF(NPA.GE.2) THEN 
4460         BEX=PS(1)/PS(4) 
4461         BEY=PS(2)/PS(4) 
4462         BEZ=PS(3)/PS(4) 
4463         GA=PS(4)/PS(5)  
4464         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))  
4465      &  /(1.+GA)-P(IPA(1),4))   
4466       ELSE  
4467         BEX=0.  
4468         BEY=0.  
4469         BEZ=0.  
4470         GABEP=0.    
4471       ENDIF 
4472       THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)    
4473      &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))   
4474       PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)   
4475       IF(NPA.EQ.3) THEN 
4476         CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*  
4477      &  SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*   
4478      &  BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+   
4479      &  GABEP*BEY)) 
4480         CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)  
4481       ENDIF 
4482       DBEX=DBLE(BEX)    
4483       DBEY=DBLE(BEY)    
4484       DBEZ=DBLE(BEZ)    
4485       CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)    
4486     
4487 C...Decay vertex of shower. 
4488       DO 400 I=NS+1,N   
4489       DO 400 J=1,5  
4490   400 V(I,J)=V(IP1,J)   
4491     
4492 C...Delete trivial shower, else connect initiators. 
4493       IF(N.EQ.NS+NPA+IIM) THEN  
4494         N=NS    
4495       ELSE  
4496         DO 410 IP=1,NPA 
4497         K(IPA(IP),1)=14 
4498         K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP 
4499         K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP 
4500         K(NS+IIM+IP,3)=IPA(IP)  
4501         IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1  
4502         K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)   
4503   410   K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)   
4504       ENDIF 
4505     
4506       RETURN    
4507       END   
4508     
4509 C*********************************************************************  
4510     
4511       SUBROUTINE LUBOEI(NSAV)   
4512     
4513 C...Purpose: to modify event so as to approximately take into account   
4514 C...Bose-Einstein effects according to a simple phenomenological    
4515 C...parametrization.    
4516       IMPLICIT DOUBLE PRECISION(D)  
4517       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4518       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4519       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)    
4520       SAVE  
4521       DATA KFBE/211,-211,111,321,-321,130,310,221,331/  
4522     
4523 C...Boost event to overall CM frame. Calculate CM energy.   
4524       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN   
4525       DO 100 J=1,4  
4526   100 DPS(J)=0. 
4527       DO 120 I=1,N  
4528       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120  
4529       DO 110 J=1,4  
4530   110 DPS(J)=DPS(J)+P(I,J)  
4531   120 CONTINUE  
4532       CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),  
4533      &-DPS(3)/DPS(4))   
4534       PECM=0.   
4535       DO 130 I=1,N  
4536   130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4) 
4537     
4538 C...Reserve copy of particles by species at end of record.  
4539       NBE(0)=N+MSTU(3)  
4540       DO 160 IBE=1,MIN(9,MSTJ(51))  
4541       NBE(IBE)=NBE(IBE-1)   
4542       DO 150 I=NSAV+1,N 
4543       IF(K(I,2).NE.KFBE(IBE)) GOTO 150  
4544       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150  
4545       IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN   
4546         CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')   
4547         RETURN  
4548       ENDIF 
4549       NBE(IBE)=NBE(IBE)+1   
4550       K(NBE(IBE),1)=I   
4551       DO 140 J=1,3  
4552   140 P(NBE(IBE),J)=0.  
4553   150 CONTINUE  
4554   160 CONTINUE  
4555     
4556 C...Tabulate integral for subsequent momentum shift.    
4557       DO 210 IBE=1,MIN(9,MSTJ(51))  
4558       IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180   
4559       IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).   
4560      &LE.1) GOTO 180    
4561       IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),    
4562      &NBE(7)-NBE(6)).LE.1) GOTO 180 
4563       IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180    
4564       IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)  
4565       IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)  
4566       IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)  
4567       IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)  
4568       QDEL=0.1*MIN(PMHQ,PARJ(93))   
4569       IF(MSTJ(51).EQ.1) THEN    
4570         NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))    
4571         BEEX=EXP(0.5*QDEL/PARJ(93)) 
4572         BERT=EXP(-QDEL/PARJ(93))    
4573       ELSE  
4574         NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))    
4575       ENDIF 
4576       DO 170 IBIN=1,NBIN    
4577       QBIN=QDEL*(IBIN-0.5)  
4578       BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)    
4579       IF(MSTJ(51).EQ.1) THEN    
4580         BEEX=BEEX*BERT  
4581         BEI(IBIN)=BEI(IBIN)*BEEX    
4582       ELSE  
4583         BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)    
4584       ENDIF 
4585   170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1) 
4586     
4587 C...Loop through particle pairs and find old relative momentum. 
4588   180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1    
4589       I1=K(I1M,1)   
4590       DO 200 I2M=I1M+1,NBE(IBE) 
4591       I2=K(I2M,1)   
4592       Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+  
4593      &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)    
4594       QOLD=SQRT(Q2OLD)  
4595     
4596 C...Calculate new relative momentum.    
4597       IF(QOLD.LT.0.5*QDEL) THEN 
4598         QMOV=QOLD/3.    
4599       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN  
4600         RBIN=QOLD/QDEL  
4601         IBIN=RBIN   
4602         RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)  
4603         QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*  
4604      &  SQRT(Q2OLD+PMHQ**2)/Q2OLD   
4605       ELSE  
4606         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD    
4607       ENDIF 
4608       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)   
4609     
4610 C...Calculate and save shift to be performed on three-momenta.  
4611       HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)    
4612       HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2    
4613       HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))   
4614       DO 190 J=1,3  
4615       PD=HA*(P(I2,J)-P(I1,J))   
4616       P(I1M,J)=P(I1M,J)+PD  
4617   190 P(I2M,J)=P(I2M,J)-PD  
4618   200 CONTINUE  
4619   210 CONTINUE  
4620     
4621 C...Shift momenta and recalculate energies. 
4622       DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))   
4623       I=K(IM,1) 
4624       DO 220 J=1,3  
4625   220 P(I,J)=P(I,J)+P(IM,J) 
4626   230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)  
4627     
4628 C...Rescale all momenta for energy conservation.    
4629       PES=0.    
4630       PQS=0.    
4631       DO 240 I=1,N  
4632       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240  
4633       PES=PES+P(I,4)    
4634       PQS=PQS+P(I,5)**2/P(I,4)  
4635   240 CONTINUE  
4636       FAC=(PECM-PQS)/(PES-PQS)  
4637       DO 260 I=1,N  
4638       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260  
4639       DO 250 J=1,3  
4640   250 P(I,J)=FAC*P(I,J) 
4641       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)  
4642   260 CONTINUE  
4643     
4644 C...Boost back to correct reference frame.  
4645       CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))  
4646     
4647       RETURN    
4648       END   
4649     
4650 C*********************************************************************  
4651     
4652       FUNCTION ULMASS(KF)   
4653     
4654 C...Purpose: to give the mass of a particle/parton. 
4655       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4656       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4657       SAVE 
4658    
4659 C...Reset variables. Compressed code.   
4660       ULMASS=0. 
4661       KFA=IABS(KF)  
4662       KC=LUCOMP(KF) 
4663       IF(KC.EQ.0) RETURN    
4664       PARF(106)=PMAS(6,1)   
4665       PARF(107)=PMAS(7,1)   
4666       PARF(108)=PMAS(8,1)   
4667     
4668 C...Guarantee use of constituent masses for internal checks.    
4669       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN   
4670         ULMASS=PARF(100+KFA)    
4671         IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))   
4672     
4673 C...Masses that can be read directly off table. 
4674       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN  
4675         ULMASS=PMAS(KC,1)   
4676     
4677 C...Find constituent partons and their masses.  
4678       ELSE  
4679         KFLA=MOD(KFA/1000,10)   
4680         KFLB=MOD(KFA/100,10)    
4681         KFLC=MOD(KFA/10,10) 
4682         KFLS=MOD(KFA,10)    
4683         KFLR=MOD(KFA/10000,10)  
4684         PMA=PARF(100+KFLA)  
4685         PMB=PARF(100+KFLB)  
4686         PMC=PARF(100+KFLC)  
4687     
4688 C...Construct masses for various meson, diquark and baryon cases.   
4689         IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN  
4690           IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC) 
4691           IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)  
4692           ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL 
4693         ELSEIF(KFLA.EQ.0) THEN  
4694           KMUL=2    
4695           IF(KFLS.EQ.1) KMUL=3  
4696           IF(KFLR.EQ.2) KMUL=4  
4697           IF(KFLS.EQ.5) KMUL=5  
4698           ULMASS=PARF(113+KMUL)+PMB+PMC 
4699         ELSEIF(KFLC.EQ.0) THEN  
4700           IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB) 
4701           IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)  
4702           ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL   
4703           IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB  
4704           IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)- 
4705      &    2.*PARF(112)/3.)  
4706         ELSE    
4707           IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN   
4708             PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)    
4709           ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN   
4710             PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)   
4711           ELSEIF(KFLS.EQ.2) THEN    
4712             PMSPL=-3./(PMB*PMC) 
4713           ELSE  
4714             PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)    
4715           ENDIF 
4716           ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL 
4717         ENDIF   
4718       ENDIF 
4719     
4720 C...Optional mass broadening according to truncated Breit-Wigner    
4721 C...(either in m or in m^2).    
4722       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN 
4723         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN    
4724           ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*  
4725      &    ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))   
4726         ELSE    
4727           PM0=ULMASS    
4728           PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/    
4729      &    (PM0*PMAS(KC,2))) 
4730           PMUPP=ATAN((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))   
4731           ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+   
4732      &    (PMUPP-PMLOW)*RLU(0))))   
4733         ENDIF   
4734       ENDIF 
4735       MSTJ(93)=0    
4736     
4737       RETURN    
4738       END   
4739     
4740 C*********************************************************************  
4741     
4742       SUBROUTINE LUNAME(KF,CHAU)    
4743     
4744 C...Purpose: to give the particle/parton name as a character string.    
4745       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4746       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4747       COMMON/LUDAT4/CHAF(500)   
4748       CHARACTER CHAF*8  
4749       CHARACTER CHAU*16 
4750       SAVE
4751     
4752 C...Initial values. Charge. Subdivide code. 
4753       CHAU=' '  
4754       KFA=IABS(KF)  
4755       KC=LUCOMP(KF) 
4756       IF(KC.EQ.0) RETURN    
4757       KQ=LUCHGE(KF) 
4758       KFLA=MOD(KFA/1000,10) 
4759       KFLB=MOD(KFA/100,10)  
4760       KFLC=MOD(KFA/10,10)   
4761       KFLS=MOD(KFA,10)  
4762       KFLR=MOD(KFA/10000,10)    
4763     
4764 C...Read out root name and spin for simple particle.    
4765       IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN 
4766         CHAU=CHAF(KC)   
4767         LEN=0   
4768         DO 100 LEM=1,8  
4769   100   IF(CHAU(LEM:LEM).NE.' ') LEN=LEM    
4770     
4771 C...Construct root name for diquark. Add on spin.   
4772       ELSEIF(KFLC.EQ.0) THEN    
4773         CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)  
4774         IF(KFLS.EQ.1) CHAU(3:4)='_0'    
4775         IF(KFLS.EQ.3) CHAU(3:4)='_1'    
4776         LEN=4   
4777     
4778 C...Construct root name for heavy meson. Add on spin and heavy flavour. 
4779       ELSEIF(KFLA.EQ.0) THEN    
4780         IF(KFLB.EQ.5) CHAU(1:1)='B' 
4781         IF(KFLB.EQ.6) CHAU(1:1)='T' 
4782         IF(KFLB.EQ.7) CHAU(1:1)='L' 
4783         IF(KFLB.EQ.8) CHAU(1:1)='H' 
4784         LEN=1   
4785         IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN    
4786         ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN    
4787           CHAU(2:2)='*' 
4788           LEN=2 
4789         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN    
4790           CHAU(2:3)='_1'    
4791           LEN=3 
4792         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN    
4793           CHAU(2:4)='*_0'   
4794           LEN=4 
4795         ELSEIF(KFLR.EQ.2) THEN  
4796           CHAU(2:4)='*_1'   
4797           LEN=4 
4798         ELSEIF(KFLS.EQ.5) THEN  
4799           CHAU(2:4)='*_2'   
4800           LEN=4 
4801         ENDIF   
4802         IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN  
4803           CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)    
4804           LEN=LEN+2 
4805         ELSEIF(KFLC.GE.3) THEN  
4806           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1) 
4807           LEN=LEN+1 
4808         ENDIF   
4809     
4810 C...Construct root name and spin for heavy baryon.  
4811       ELSE  
4812         IF(KFLB.LE.2.AND.KFLC.LE.2) THEN    
4813           CHAU='Sigma ' 
4814           IF(KFLC.GT.KFLB) CHAU='Lambda'    
4815           IF(KFLS.EQ.4) CHAU='Sigma*'   
4816           LEN=5 
4817           IF(CHAU(6:6).NE.' ') LEN=6    
4818         ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN 
4819           CHAU='Xi '    
4820           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi''' 
4821           IF(KFLS.EQ.4) CHAU='Xi*'  
4822           LEN=2 
4823           IF(CHAU(3:3).NE.' ') LEN=3    
4824         ELSE    
4825           CHAU='Omega ' 
4826           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''  
4827           IF(KFLS.EQ.4) CHAU='Omega*'   
4828           LEN=5 
4829           IF(CHAU(6:6).NE.' ') LEN=6    
4830         ENDIF   
4831     
4832 C...Add on heavy flavour content for heavy baryon.  
4833         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)  
4834         LEN=LEN+2   
4835         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN 
4836           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)    
4837           LEN=LEN+2 
4838         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN 
4839           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1) 
4840           LEN=LEN+1 
4841         ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN 
4842           CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)    
4843           LEN=LEN+2 
4844         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN 
4845           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1) 
4846           LEN=LEN+1 
4847         ENDIF   
4848       ENDIF 
4849     
4850 C...Add on bar sign for antiparticle (where necessary). 
4851       IF(KF.GT.0.OR.LEN.EQ.0) THEN  
4852       ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN  
4853       ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN   
4854       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN 
4855       ELSEIF(MSTU(15).LE.1) THEN    
4856         CHAU(LEN+1:LEN+1)='~'   
4857         LEN=LEN+1   
4858       ELSE  
4859         CHAU(LEN+1:LEN+3)='bar' 
4860         LEN=LEN+3   
4861       ENDIF 
4862     
4863 C...Add on charge where applicable (conventional cases skipped).    
4864       IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'    
4865       IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'   
4866       IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+' 
4867       IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'    
4868       IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN  
4869       ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN   
4870       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND. 
4871      &KFLB.NE.1) THEN   
4872       ELSEIF(KQ.EQ.0) THEN  
4873         CHAU(LEN+1:LEN+1)='0'   
4874       ENDIF 
4875     
4876       RETURN    
4877       END   
4878     
4879 C*********************************************************************  
4880     
4881       FUNCTION LUCHGE(KF)   
4882     
4883 C...Purpose: to give three times the charge for a particle/parton.  
4884       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4885       SAVE 
4886     
4887 C...Initial values. Simple case of direct readout.  
4888       LUCHGE=0  
4889       KFA=IABS(KF)  
4890       KC=LUCOMP(KFA)    
4891       IF(KC.EQ.0) THEN  
4892       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN  
4893         LUCHGE=KCHG(KC,1)   
4894     
4895 C...Construction from quark content for heavy meson, diquark, baryon.   
4896       ELSEIF(MOD(KFA/1000,10).EQ.0) THEN    
4897         LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*    
4898      &  (-1)**MOD(KFA/100,10)   
4899       ELSEIF(MOD(KFA/10,10).EQ.0) THEN  
4900         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1) 
4901       ELSE  
4902         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+    
4903      &  KCHG(MOD(KFA/10,10),1)  
4904       ENDIF 
4905     
4906 C...Add on correct sign.    
4907       LUCHGE=LUCHGE*ISIGN(1,KF) 
4908     
4909       RETURN    
4910       END   
4911     
4912 C*********************************************************************  
4913     
4914       FUNCTION LUCOMP(KF)   
4915     
4916 C...Purpose: to compress the standard KF codes for use in mass and decay    
4917 C...arrays; also to check whether a given code actually is defined. 
4918       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4919       SAVE 
4920     
4921 C...Subdivide KF code into constituent pieces.  
4922       LUCOMP=0  
4923       KFA=IABS(KF)  
4924       KFLA=MOD(KFA/1000,10) 
4925       KFLB=MOD(KFA/100,10)  
4926       KFLC=MOD(KFA/10,10)   
4927       KFLS=MOD(KFA,10)  
4928       KFLR=MOD(KFA/10000,10)    
4929     
4930 C...Simple cases: direct translation or special codes.  
4931       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN    
4932       ELSEIF(KFA.LE.100) THEN   
4933         LUCOMP=KFA  
4934         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0   
4935       ELSEIF(KFLS.EQ.0) THEN    
4936         IF(KF.EQ.130) LUCOMP=221    
4937         IF(KF.EQ.310) LUCOMP=222    
4938         IF(KFA.EQ.210) LUCOMP=281   
4939         IF(KFA.EQ.2110) LUCOMP=282  
4940         IF(KFA.EQ.2210) LUCOMP=283  
4941     
4942 C...Mesons. 
4943       ELSEIF(KFA-10000*KFLR.LT.1000) THEN   
4944         IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN   
4945         ELSEIF(KFLB.LT.KFLC) THEN   
4946         ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN   
4947         ELSEIF(KFLB.EQ.KFLC) THEN   
4948           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN  
4949             LUCOMP=110+KFLB 
4950           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN  
4951             LUCOMP=130+KFLB 
4952           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN  
4953             LUCOMP=150+KFLB 
4954           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN  
4955             LUCOMP=170+KFLB 
4956           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN  
4957             LUCOMP=190+KFLB 
4958           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN  
4959             LUCOMP=210+KFLB 
4960           ENDIF 
4961         ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN    
4962           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN  
4963             LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC   
4964           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN  
4965             LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC   
4966           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN  
4967             LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC   
4968           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN  
4969             LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC   
4970           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN  
4971             LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC   
4972           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN  
4973             LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC   
4974           ENDIF 
4975         ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).  
4976      &  OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN  
4977           LUCOMP=80+KFLB    
4978         ENDIF   
4979     
4980 C...Diquarks.   
4981       ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN   
4982         IF(KFLS.NE.1.AND.KFLS.NE.3) THEN    
4983         ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN    
4984         ELSEIF(KFLA.LT.KFLB) THEN   
4985         ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN 
4986         ELSE    
4987           LUCOMP=90 
4988         ENDIF   
4989     
4990 C...Spin 1/2 baryons.   
4991       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN  
4992         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN   
4993         ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN   
4994         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN    
4995           LUCOMP=80+KFLA    
4996         ELSEIF(KFLB.LT.KFLC) THEN   
4997           LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB  
4998         ELSE    
4999           LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC  
5000         ENDIF   
5001     
5002 C...Spin 3/2 baryons.   
5003       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN  
5004         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN   
5005         ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN   
5006         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN 
5007           LUCOMP=80+KFLA    
5008         ELSE    
5009           LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC  
5010         ENDIF   
5011       ENDIF 
5012     
5013       RETURN    
5014       END   
5015     
5016 C*********************************************************************  
5017     
5018       SUBROUTINE LUERRM(MERR,CHMESS)    
5019     
5020 C...Purpose: to inform user of errors in program execution. 
5021       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5022       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5023       CHARACTER CHMESS*(*)  
5024       SAVE
5025     
5026 C...Write first few warnings, then be silent.   
5027       IF(MERR.LE.10) THEN   
5028         MSTU(27)=MSTU(27)+1 
5029         MSTU(28)=MERR   
5030         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000) 
5031      &  MERR,MSTU(31),CHMESS    
5032     
5033 C...Write first few errors, then be silent or stop program. 
5034       ELSEIF(MERR.LE.20) THEN   
5035         MSTU(23)=MSTU(23)+1 
5036         MSTU(24)=MERR-10    
5037         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100) 
5038      &  MERR-10,MSTU(31),CHMESS 
5039         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN 
5040           WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS  
5041           WRITE(MSTU(11),1200)  
5042           IF(MERR.NE.17) CALL LULIST(2) 
5043           STOP  
5044         ENDIF   
5045     
5046 C...Stop program in case of irreparable error.  
5047       ELSE  
5048         WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS    
5049         STOP    
5050       ENDIF 
5051     
5052 C...Formats for output. 
5053  1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,  
5054      &' LUEXEC calls:'/5X,A)    
5055  1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,   
5056      &' LUEXEC calls:'/5X,A)    
5057  1200 FORMAT(5X,'Execution will be stopped after listing of last ', 
5058      &'event!') 
5059  1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6, 
5060      &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')    
5061     
5062       RETURN    
5063       END   
5064     
5065 C*********************************************************************  
5066     
5067       FUNCTION ULALPS(Q2)   
5068     
5069 C...Purpose: to give the value of alpha_strong. 
5070       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5071       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5072       SAVE 
5073     
5074 C...Constant alpha_strong trivial.  
5075       IF(MSTU(111).LE.0) THEN   
5076         ULALPS=PARU(111)    
5077         MSTU(118)=MSTU(112) 
5078         PARU(117)=0.    
5079         PARU(118)=PARU(111) 
5080         RETURN  
5081       ENDIF 
5082     
5083 C...Find effective Q2, number of flavours and Lambda.   
5084       Q2EFF=Q2  
5085       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))    
5086       NF=MSTU(112)  
5087       ALAM2=PARU(112)**2    
5088   100 IF(NF.GT.MAX(2,MSTU(113))) THEN   
5089         Q2THR=PARU(113)*PMAS(NF,1)**2   
5090         IF(Q2EFF.LT.Q2THR) THEN 
5091           NF=NF-1   
5092           ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))   
5093           GOTO 100  
5094         ENDIF   
5095       ENDIF 
5096   110 IF(NF.LT.MIN(8,MSTU(114))) THEN   
5097         Q2THR=PARU(113)*PMAS(NF+1,1)**2 
5098         IF(Q2EFF.GT.Q2THR) THEN 
5099           NF=NF+1   
5100           ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))   
5101           GOTO 110  
5102         ENDIF   
5103       ENDIF 
5104       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2  
5105       PARU(117)=SQRT(ALAM2) 
5106     
5107 C...Evaluate first or second order alpha_strong.    
5108       B0=(33.-2.*NF)/6. 
5109       ALGQ=LOG(Q2EFF/ALAM2) 
5110       IF(MSTU(111).EQ.1) THEN   
5111         ULALPS=PARU(2)/(B0*ALGQ)    
5112       ELSE  
5113         B1=(153.-19.*NF)/6. 
5114         ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ)) 
5115       ENDIF 
5116       MSTU(118)=NF  
5117       PARU(118)=ULALPS  
5118     
5119       RETURN    
5120       END   
5121     
5122 C*********************************************************************  
5123     
5124       FUNCTION ULANGL(X,Y)  
5125     
5126 C...Purpose: to reconstruct an angle from given x and y coordinates.    
5127       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5128       SAVE  
5129     
5130       ULANGL=0. 
5131       R=SQRT(X**2+Y**2) 
5132       IF(R.LT.1E-20) RETURN 
5133       IF(ABS(X)/R.LT.0.8) THEN  
5134         ULANGL=SIGN(ACOS(X/R),Y)    
5135       ELSE  
5136         ULANGL=ASIN(Y/R)    
5137         IF(X.LT.0..AND.ULANGL.GE.0.) THEN   
5138           ULANGL=PARU(1)-ULANGL 
5139         ELSEIF(X.LT.0.) THEN    
5140           ULANGL=-PARU(1)-ULANGL    
5141         ENDIF   
5142       ENDIF 
5143     
5144       RETURN    
5145       END   
5146     
5147 C*********************************************************************  
5148     
5149       SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)    
5150     
5151 C...Purpose: to perform rotations and boosts.   
5152       IMPLICIT DOUBLE PRECISION(D)  
5153       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5154       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5155       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)    
5156       SAVE
5157     
5158 C...Find range of rotation/boost. Convert boost to double precision.    
5159       IMIN=1    
5160       IF(MSTU(1).GT.0) IMIN=MSTU(1) 
5161       IMAX=N    
5162       IF(MSTU(2).GT.0) IMAX=MSTU(2) 
5163       DBX=BEX   
5164       DBY=BEY   
5165       DBZ=BEZ   
5166       GOTO 100  
5167     
5168 C...Entry for specific range and double precision boost.    
5169       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)  
5170       IMIN=IMI  
5171       IF(IMIN.LE.0) IMIN=1  
5172       IMAX=IMA  
5173       IF(IMAX.LE.0) IMAX=N  
5174       DBX=DBEX  
5175       DBY=DBEY  
5176       DBZ=DBEZ  
5177     
5178 C...Check range of rotation/boost.  
5179   100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN   
5180         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory') 
5181         RETURN  
5182       ENDIF 
5183     
5184 C...Rotate, typically from z axis to direction (theta,phi). 
5185       IF(THE**2+PHI**2.GT.1E-20) THEN   
5186         ROT(1,1)=COS(THE)*COS(PHI)  
5187         ROT(1,2)=-SIN(PHI)  
5188         ROT(1,3)=SIN(THE)*COS(PHI)  
5189         ROT(2,1)=COS(THE)*SIN(PHI)  
5190         ROT(2,2)=COS(PHI)   
5191         ROT(2,3)=SIN(THE)*SIN(PHI)  
5192         ROT(3,1)=-SIN(THE)  
5193         ROT(3,2)=0. 
5194         ROT(3,3)=COS(THE)   
5195         DO 130 I=IMIN,IMAX  
5196         IF(K(I,1).LE.0) GOTO 130    
5197         DO 110 J=1,3    
5198         PR(J)=P(I,J)    
5199   110   VR(J)=V(I,J)    
5200         DO 120 J=1,3    
5201         P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) 
5202   120   V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3) 
5203   130   CONTINUE    
5204       ENDIF 
5205     
5206 C...Boost, typically from rest to momentum/energy=beta. 
5207       IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN    
5208         DB=SQRT(DBX**2+DBY**2+DBZ**2)   
5209         IF(DB.GT.0.99999999D0) THEN 
5210 C...Rescale boost vector if too close to unity. 
5211           CALL LUERRM(3,'(LUROBO:) boost vector too large') 
5212           DBX=DBX*(0.99999999D0/DB) 
5213           DBY=DBY*(0.99999999D0/DB) 
5214           DBZ=DBZ*(0.99999999D0/DB) 
5215           DB=0.99999999D0   
5216         ENDIF   
5217         DGA=1D0/SQRT(1D0-DB**2) 
5218         DO 150 I=IMIN,IMAX  
5219         IF(K(I,1).LE.0) GOTO 150    
5220         DO 140 J=1,4    
5221         DP(J)=P(I,J)    
5222   140   DV(J)=V(I,J)    
5223         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)   
5224         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) 
5225         P(I,1)=DP(1)+DGABP*DBX  
5226         P(I,2)=DP(2)+DGABP*DBY  
5227         P(I,3)=DP(3)+DGABP*DBZ  
5228         P(I,4)=DGA*(DP(4)+DBP)  
5229         DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)   
5230         DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4)) 
5231         V(I,1)=DV(1)+DGABV*DBX  
5232         V(I,2)=DV(2)+DGABV*DBY  
5233         V(I,3)=DV(3)+DGABV*DBZ  
5234         V(I,4)=DGA*(DV(4)+DBV)  
5235   150   CONTINUE    
5236       ENDIF 
5237     
5238       RETURN    
5239       END   
5240     
5241 C*********************************************************************  
5242 C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST
5243 C       THE FOUR MOMENTUM ONLY
5244 C*********************************************************************
5245     
5246       SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)    
5247     
5248 C...Purpose: to perform rotations and boosts.   
5249       IMPLICIT DOUBLE PRECISION(D)  
5250       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5251       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5252       DIMENSION ROT(3,3),PR(3),DP(4)    
5253       SAVE
5254     
5255 C...Find range of rotation/boost. Convert boost to double precision.    
5256       IMIN=1    
5257       IF(MSTU(1).GT.0) IMIN=MSTU(1) 
5258       IMAX=N    
5259       IF(MSTU(2).GT.0) IMAX=MSTU(2) 
5260       DBX=BEX   
5261       DBY=BEY   
5262       DBZ=BEZ   
5263     
5264 C...Check range of rotation/boost.  
5265       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN   
5266         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory') 
5267         RETURN  
5268       ENDIF 
5269     
5270 C...Rotate, typically from z axis to direction (theta,phi). 
5271       IF(THE**2+PHI**2.GT.1E-20) THEN   
5272         ROT(1,1)=COS(THE)*COS(PHI)  
5273         ROT(1,2)=-SIN(PHI)  
5274         ROT(1,3)=SIN(THE)*COS(PHI)  
5275         ROT(2,1)=COS(THE)*SIN(PHI)  
5276         ROT(2,2)=COS(PHI)   
5277         ROT(2,3)=SIN(THE)*SIN(PHI)  
5278         ROT(3,1)=-SIN(THE)  
5279         ROT(3,2)=0. 
5280         ROT(3,3)=COS(THE)   
5281         DO 130 I=IMIN,IMAX  
5282         IF(K(I,1).LE.0) GOTO 130    
5283         DO 110 J=1,3    
5284   110   PR(J)=P(I,J)   
5285         DO 120 J=1,3    
5286   120   P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) 
5287   130   CONTINUE    
5288       ENDIF 
5289     
5290 C...Boost, typically from rest to momentum/energy=beta. 
5291       IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN    
5292         DB=SQRT(DBX**2+DBY**2+DBZ**2)   
5293         IF(DB.GT.0.99999999D0) THEN 
5294 C...Rescale boost vector if too close to unity. 
5295           CALL LUERRM(3,'(LUROBO:) boost vector too large') 
5296           DBX=DBX*(0.99999999D0/DB) 
5297           DBY=DBY*(0.99999999D0/DB) 
5298           DBZ=DBZ*(0.99999999D0/DB) 
5299           DB=0.99999999D0   
5300         ENDIF   
5301         DGA=1D0/SQRT(1D0-DB**2) 
5302         DO 150 I=IMIN,IMAX  
5303         IF(K(I,1).LE.0) GOTO 150    
5304         DO 140 J=1,4    
5305   140   DP(J)=P(I,J)    
5306         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)   
5307         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) 
5308         P(I,1)=DP(1)+DGABP*DBX  
5309         P(I,2)=DP(2)+DGABP*DBY  
5310         P(I,3)=DP(3)+DGABP*DBZ  
5311         P(I,4)=DGA*(DP(4)+DBP)  
5312   150   CONTINUE    
5313       ENDIF 
5314     
5315       RETURN    
5316       END   
5317     
5318 C*********************************************************************  
5319     
5320       SUBROUTINE LUEDIT(MEDIT)  
5321     
5322 C...Purpose: to perform global manipulations on the event record,   
5323 C...in particular to exclude unstable or undetectable partons/particles.    
5324       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5325       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5326       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5327       DIMENSION NS(2),PTS(2),PLS(2) 
5328       SAVE    
5329 
5330 C...Remove unwanted partons/particles.  
5331       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN    
5332         IMAX=N  
5333         IF(MSTU(2).GT.0) IMAX=MSTU(2)   
5334         I1=MAX(1,MSTU(1))-1 
5335         DO 110 I=MAX(1,MSTU(1)),IMAX    
5336         IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110    
5337         IF(MEDIT.EQ.1) THEN 
5338           IF(K(I,1).GT.10) GOTO 110 
5339         ELSEIF(MEDIT.EQ.2) THEN 
5340           IF(K(I,1).GT.10) GOTO 110 
5341           KC=LUCOMP(K(I,2)) 
5342           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)   
5343      &    GOTO 110  
5344         ELSEIF(MEDIT.EQ.3) THEN 
5345           IF(K(I,1).GT.10) GOTO 110 
5346           KC=LUCOMP(K(I,2)) 
5347           IF(KC.EQ.0) GOTO 110  
5348           IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110  
5349         ELSEIF(MEDIT.EQ.5) THEN 
5350           IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110 
5351           KC=LUCOMP(K(I,2)) 
5352           IF(KC.EQ.0) GOTO 110  
5353           IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110 
5354         ENDIF   
5355     
5356 C...Pack remaining partons/particles. Origin no longer known.   
5357         I1=I1+1 
5358         DO 100 J=1,5    
5359         K(I1,J)=K(I,J)  
5360         P(I1,J)=P(I,J)  
5361   100   V(I1,J)=V(I,J)  
5362         K(I1,3)=0   
5363   110   CONTINUE    
5364         N=I1    
5365     
5366 C...Selective removal of class of entries. New position of retained.    
5367       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN  
5368         I1=0    
5369         DO 120 I=1,N    
5370         K(I,3)=MOD(K(I,3),MSTU(5))  
5371         IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120    
5372         IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120    
5373         IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.    
5374      &  K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120    
5375         IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.    
5376      &  K(I,2).EQ.94)) GOTO 120 
5377         IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120   
5378         I1=I1+1 
5379         K(I,3)=K(I,3)+MSTU(5)*I1    
5380   120   CONTINUE    
5381     
5382 C...Find new event history information and replace old. 
5383         DO 140 I=1,N    
5384         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140 
5385         ID=I    
5386   130   IM=MOD(K(ID,3),MSTU(5)) 
5387         IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN    
5388           IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND. 
5389      &    K(IM,2).NE.94) THEN   
5390             ID=IM   
5391             GOTO 130    
5392           ENDIF 
5393         ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN    
5394           IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN  
5395             ID=IM   
5396             GOTO 130    
5397           ENDIF 
5398         ENDIF   
5399         K(I,3)=MSTU(5)*(K(I,3)/MSTU(5)) 
5400         IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)   
5401         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN  
5402           IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)= 
5403      &    K(K(I,4),3)/MSTU(5)   
5404           IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)= 
5405      &    K(K(I,5),3)/MSTU(5)   
5406         ELSE    
5407           KCM=MOD(K(I,4)/MSTU(5),MSTU(5))   
5408           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)  
5409           KCD=MOD(K(I,4),MSTU(5))   
5410           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)  
5411           K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD 
5412           KCM=MOD(K(I,5)/MSTU(5),MSTU(5))   
5413           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)  
5414           KCD=MOD(K(I,5),MSTU(5))   
5415           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)  
5416           K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD 
5417         ENDIF   
5418   140   CONTINUE    
5419     
5420 C...Pack remaining entries. 
5421         I1=0    
5422         DO 160 I=1,N    
5423         IF(K(I,3)/MSTU(5).EQ.0) GOTO 160    
5424         I1=I1+1 
5425         DO 150 J=1,5    
5426         K(I1,J)=K(I,J)  
5427         P(I1,J)=P(I,J)  
5428   150   V(I1,J)=V(I,J)  
5429         K(I1,3)=MOD(K(I1,3),MSTU(5))    
5430   160   CONTINUE    
5431         N=I1    
5432     
5433 C...Save top entries at bottom of LUJETS commonblock.   
5434       ELSEIF(MEDIT.EQ.21) THEN  
5435         IF(2*N.GE.MSTU(4)) THEN 
5436           CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS') 
5437           RETURN    
5438         ENDIF   
5439         DO 170 I=1,N    
5440         DO 170 J=1,5    
5441         K(MSTU(4)-I,J)=K(I,J)   
5442         P(MSTU(4)-I,J)=P(I,J)   
5443   170   V(MSTU(4)-I,J)=V(I,J)   
5444         MSTU(32)=N  
5445     
5446 C...Restore bottom entries of commonblock LUJETS to top.    
5447       ELSEIF(MEDIT.EQ.22) THEN  
5448         DO 180 I=1,MSTU(32) 
5449         DO 180 J=1,5    
5450         K(I,J)=K(MSTU(4)-I,J)   
5451         P(I,J)=P(MSTU(4)-I,J)   
5452   180   V(I,J)=V(MSTU(4)-I,J)   
5453         N=MSTU(32)  
5454     
5455 C...Mark primary entries at top of commonblock LUJETS as untreated. 
5456       ELSEIF(MEDIT.EQ.23) THEN  
5457         I1=0    
5458         DO 190 I=1,N    
5459         KH=K(I,3)   
5460         IF(KH.GE.1) THEN    
5461           IF(K(KH,1).GT.20) KH=0    
5462         ENDIF   
5463         IF(KH.NE.0) GOTO 200    
5464         I1=I1+1 
5465   190   IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10  
5466   200   N=I1    
5467     
5468 C...Place largest axis along z axis and second largest in xy plane. 
5469       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN   
5470         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),   
5471      &  P(MSTU(61),2)),0D0,0D0,0D0) 
5472         CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),  
5473      &  P(MSTU(61),1)),0.,0D0,0D0,0D0)  
5474         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1), 
5475      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)   
5476         IF(MEDIT.EQ.31) RETURN  
5477     
5478 C...Rotate to put slim jet along +z axis.   
5479         DO 210 IS=1,2   
5480         NS(IS)=0    
5481         PTS(IS)=0.  
5482   210   PLS(IS)=0.  
5483         DO 220 I=1,N    
5484         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 220    
5485         IF(MSTU(41).GE.2) THEN  
5486           KC=LUCOMP(K(I,2)) 
5487           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.    
5488      &    KC.EQ.18) GOTO 220    
5489           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) 
5490      &    GOTO 220  
5491         ENDIF   
5492         IS=2.-SIGN(0.5,P(I,3))  
5493         NS(IS)=NS(IS)+1 
5494         PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)   
5495   220   CONTINUE    
5496         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)  
5497      &  CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0) 
5498     
5499 C...Rotate to put second largest jet into -z,+x quadrant.   
5500         DO 230 I=1,N    
5501         IF(P(I,3).GE.0.) GOTO 230   
5502         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230    
5503         IF(MSTU(41).GE.2) THEN  
5504           KC=LUCOMP(K(I,2)) 
5505           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.    
5506      &    KC.EQ.18) GOTO 230    
5507           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) 
5508      &    GOTO 230  
5509         ENDIF   
5510         IS=2.-SIGN(0.5,P(I,1))  
5511         PLS(IS)=PLS(IS)-P(I,3)  
5512   230   CONTINUE    
5513         IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),    
5514      &  0D0,0D0,0D0)    
5515       ENDIF 
5516     
5517       RETURN    
5518       END   
5519     
5520 C*********************************************************************  
5521     
5522       SUBROUTINE LULIST(MLIST)  
5523     
5524 C...Purpose: to give program heading, or list an event, or particle 
5525 C...data, or current parameter values.  
5526       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5527       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5528       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5529       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
5530       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4 
5531       DIMENSION PS(6)   
5532       SAVE
5533       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
5534      &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/    
5535 
5536       CHMO(1)=CHMO(1)    
5537 C...Initialization printout: version number and date of last change.    
5538 C      IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN  
5539 C        WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185), 
5540 C     &  CHMO(MSTU(184)),MSTU(183)   
5541 C        MSTU(12)=0  
5542 C        IF(MLIST.EQ.0) RETURN   
5543 C      ENDIF 
5544     
5545 C...List event data, including additional lines after N.    
5546       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN    
5547         IF(MLIST.EQ.1) WRITE(MSTU(11),1100) 
5548         IF(MLIST.EQ.2) WRITE(MSTU(11),1200) 
5549         IF(MLIST.EQ.3) WRITE(MSTU(11),1300) 
5550         LMX=12  
5551         IF(MLIST.GE.2) LMX=16   
5552         ISTR=0  
5553         IMAX=N  
5554         IF(MSTU(2).GT.0) IMAX=MSTU(2)   
5555         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))  
5556         IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120  
5557     
5558 C...Get particle name, pad it and check it is not too long. 
5559         CALL LUNAME(K(I,2),CHAP)    
5560         LEN=0   
5561         DO 100 LEM=1,16 
5562   100   IF(CHAP(LEM:LEM).NE.' ') LEN=LEM    
5563         MDL=(K(I,1)+19)/10  
5564         LDL=0   
5565         IF(MDL.EQ.2.OR.MDL.GE.8) THEN   
5566           CHAC=CHAP 
5567           IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'  
5568         ELSE    
5569           LDL=1 
5570           IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2    
5571           IF(LEN.EQ.0) THEN 
5572             CHAC=CHDL(MDL)(1:2*LDL)//' '    
5573           ELSE  
5574             CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))// 
5575      &      CHDL(MDL)(LDL+1:2*LDL)//' ' 
5576             IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'  
5577           ENDIF 
5578         ENDIF   
5579     
5580 C...Add information on string connection.   
5581         IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)  
5582      &  THEN    
5583           KC=LUCOMP(K(I,2)) 
5584           KCC=0 
5585           IF(KC.NE.0) KCC=KCHG(KC,2)    
5586           IF(KCC.NE.0.AND.ISTR.EQ.0) THEN   
5587             ISTR=1  
5588             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'    
5589           ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN   
5590             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'    
5591           ELSEIF(KCC.NE.0) THEN 
5592             ISTR=0  
5593             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'    
5594           ENDIF 
5595         ENDIF   
5596     
5597 C...Write data for particle/jet.    
5598         IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN    
5599           WRITE(MSTU(11),1400) I,CHAC(1:12),(K(I,J1),J1=1,3),   
5600      &    (P(I,J2),J2=1,5)  
5601         ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN   
5602           WRITE(MSTU(11),1500) I,CHAC(1:12),(K(I,J1),J1=1,3),   
5603      &    (P(I,J2),J2=1,5)  
5604         ELSEIF(MLIST.EQ.1) THEN 
5605           WRITE(MSTU(11),1600) I,CHAC(1:12),(K(I,J1),J1=1,3),   
5606      &    (P(I,J2),J2=1,5)  
5607         ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.    
5608      &  K(I,1).EQ.14)) THEN 
5609           WRITE(MSTU(11),1700) I,CHAC,(K(I,J1),J1=1,3), 
5610      &    K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),   
5611      &    K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),   
5612      &    (P(I,J2),J2=1,5)  
5613         ELSE    
5614           WRITE(MSTU(11),1800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5) 
5615         ENDIF   
5616         IF(MLIST.EQ.3) WRITE(MSTU(11),1900) (V(I,J),J=1,5)  
5617     
5618 C...Insert extra separator lines specified by user. 
5619         IF(MSTU(70).GE.1) THEN  
5620           ISEP=0    
5621           DO 110 J=1,MIN(10,MSTU(70))   
5622   110     IF(I.EQ.MSTU(70+J)) ISEP=1    
5623           IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000) 
5624           IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100) 
5625         ENDIF   
5626   120   CONTINUE    
5627     
5628 C...Sum of charges and momenta. 
5629         DO 130 J=1,6    
5630   130   PS(J)=PLU(0,J)  
5631         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN 
5632           WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)  
5633         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN    
5634           WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)  
5635         ELSEIF(MLIST.EQ.1) THEN 
5636           WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)  
5637         ELSE    
5638           WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)  
5639         ENDIF   
5640     
5641 C...Give simple list of KF codes defined in program.    
5642       ELSEIF(MLIST.EQ.11) THEN  
5643         WRITE(MSTU(11),2600)    
5644         DO 140 KF=1,40  
5645         CALL LUNAME(KF,CHAP)    
5646         CALL LUNAME(-KF,CHAN)   
5647         IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),2700) KF,CHAP    
5648   140   IF(CHAN.NE.' ') WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5649         DO 150 KFLS=1,3,2   
5650         DO 150 KFLA=1,8 
5651         DO 150 KFLB=1,KFLA-(3-KFLS)/2   
5652         KF=1000*KFLA+100*KFLB+KFLS  
5653         CALL LUNAME(KF,CHAP)    
5654         CALL LUNAME(-KF,CHAN)   
5655   150   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5656         DO 170 KMUL=0,5 
5657         KFLS=3  
5658         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1   
5659         IF(KMUL.EQ.5) KFLS=5    
5660         KFLR=0  
5661         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1   
5662         IF(KMUL.EQ.4) KFLR=2    
5663         DO 170 KFLB=1,8 
5664         DO 160 KFLC=1,KFLB-1    
5665         KF=10000*KFLR+100*KFLB+10*KFLC+KFLS 
5666         CALL LUNAME(KF,CHAP)    
5667         CALL LUNAME(-KF,CHAN)   
5668   160   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5669         KF=10000*KFLR+110*KFLB+KFLS 
5670         CALL LUNAME(KF,CHAP)    
5671   170   WRITE(MSTU(11),2700) KF,CHAP    
5672         KF=130  
5673         CALL LUNAME(KF,CHAP)    
5674         WRITE(MSTU(11),2700) KF,CHAP    
5675         KF=310  
5676         CALL LUNAME(KF,CHAP)    
5677         WRITE(MSTU(11),2700) KF,CHAP    
5678         DO 190 KFLSP=1,3    
5679         KFLS=2+2*(KFLSP/3)  
5680         DO 190 KFLA=1,8 
5681         DO 190 KFLB=1,KFLA  
5682         DO 180 KFLC=1,KFLB  
5683         IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180  
5684         IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180    
5685         IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS   
5686         IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS   
5687         CALL LUNAME(KF,CHAP)    
5688         CALL LUNAME(-KF,CHAN)   
5689         WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5690   180   CONTINUE    
5691   190   CONTINUE    
5692     
5693 C...List parton/particle data table. Check whether to be listed.    
5694       ELSEIF(MLIST.EQ.12) THEN  
5695         WRITE(MSTU(11),2800)    
5696         MSTJ24=MSTJ(24) 
5697         MSTJ(24)=0  
5698         KFMAX=20883 
5699         IF(MSTU(2).NE.0) KFMAX=MSTU(2)  
5700         DO 220 KF=MAX(1,MSTU(1)),KFMAX  
5701         KC=LUCOMP(KF)   
5702         IF(KC.EQ.0) GOTO 220    
5703         IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220  
5704         IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10), 
5705      &  MOD(KF/100,10)).GT.MSTU(14)) GOTO 220   
5706     
5707 C...Find particle name and mass. Print information. 
5708         CALL LUNAME(KF,CHAP)    
5709         IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220  
5710         CALL LUNAME(-KF,CHAN)   
5711         PM=ULMASS(KF)   
5712         WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2), 
5713      &  KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)   
5714     
5715 C...Particle decay: channel number, branching ration, matrix element,   
5716 C...decay products. 
5717         IF(KF.GT.100.AND.KC.LE.100) GOTO 220    
5718         DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1   
5719         DO 200 J=1,5    
5720   200   CALL LUNAME(KFDP(IDC,J),CHAD(J))    
5721   210   WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC), 
5722      &  (CHAD(J),J=1,5) 
5723   220   CONTINUE    
5724         MSTJ(24)=MSTJ24 
5725     
5726 C...List parameter value table. 
5727       ELSEIF(MLIST.EQ.13) THEN  
5728         WRITE(MSTU(11),3100)    
5729         DO 230 I=1,200  
5730   230   WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)  
5731       ENDIF 
5732     
5733 C...Format statements for output on unit MSTU(11) (by default 6).   
5734 C 1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/ 
5735 C     &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)  
5736  1100 FORMAT(///28X,'Event listing (summary)'//4X,'I  particle/jet KS', 
5737      &5X,'KF orig    p_x      p_y      p_z       E        m'/)  
5738  1200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',   
5739      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',   
5740      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)  
5741  1300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',    
5742      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)', 
5743      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,   
5744      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)    
5745  1400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)  
5746  1500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)  
5747  1600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)  
5748  1700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)    
5749  1800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)    
5750  1900 FORMAT(66X,5(1X,F12.3))   
5751  2000 FORMAT(1X,78('='))    
5752  2100 FORMAT(1X,130('='))   
5753  2200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)  
5754  2300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)  
5755  2400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)  
5756  2500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',   
5757      &5F13.5)   
5758  2600 FORMAT(///20X,'List of KF codes in program'/) 
5759  2700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16) 
5760  2800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,   
5761      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,    
5762      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',    
5763      &1X,'ME',3X,'Br.rat.',4X,'decay products') 
5764  2900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),  
5765      &2X,F12.5,3X,I2)   
5766  3000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)    
5767  3100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',   
5768      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')  
5769  3200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)  
5770     
5771       RETURN    
5772       END   
5773     
5774 C*********************************************************************  
5775     
5776       SUBROUTINE LUUPDA(MUPDA,LFN)  
5777     
5778 C...Purpose: to facilitate the updating of particle and decay data. 
5779       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5780       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5781       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
5782       COMMON/LUDAT4/CHAF(500)   
5783       CHARACTER CHAF*8  
5784       CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,   
5785      &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12  
5786       SAVE
5787       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',  
5788      &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',  
5789      &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',  
5790      &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/  
5791     
5792 C...Write information on file for editing.  
5793       IF(MSTU(12).GE.1) CALL LULIST(0)  
5794       IF(MUPDA.EQ.1) THEN   
5795         DO 110 KC=1,MSTU(6) 
5796         WRITE(LFN,1000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),   
5797      &  (PMAS(KC,J2),J2=1,4),MDCY(KC,1) 
5798         DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1   
5799   100   WRITE(LFN,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),  
5800      &  (KFDP(IDC,J),J=1,5) 
5801   110   CONTINUE    
5802     
5803 C...Reset variables and read information from edited file.  
5804       ELSEIF(MUPDA.EQ.2) THEN   
5805         DO 120 I=1,MSTU(7)  
5806         MDME(I,1)=1 
5807         MDME(I,2)=0 
5808         BRAT(I)=0.  
5809         DO 120 J=1,5    
5810   120   KFDP(I,J)=0 
5811         KC=0    
5812         IDC=0   
5813         NDC=0   
5814   130   READ(LFN,1200,END=140) CHINL    
5815         IF(CHINL(2:5).NE.'    ') THEN   
5816           CHKC=CHINL(2:5)   
5817           IF(KC.NE.0) THEN  
5818             MDCY(KC,2)=0    
5819             IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC   
5820             MDCY(KC,3)=NDC  
5821           ENDIF 
5822           READ(CHKC,1300) KC    
5823           IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,  
5824      &    '(LUUPDA:) Read KC code illegal, KC ='//CHKC) 
5825           READ(CHINL,1000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),   
5826      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)   
5827           NDC=0 
5828         ELSE    
5829           IDC=IDC+1 
5830           NDC=NDC+1 
5831           IF(IDC.GE.MSTU(7)) CALL LUERRM(27,    
5832      &    '(LUUPDA:) Decay data arrays full by KC ='//CHKC) 
5833           READ(CHINL,1100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),   
5834      &    (KFDP(IDC,J),J=1,5)   
5835         ENDIF   
5836         GOTO 130    
5837   140   MDCY(KC,2)=0    
5838         IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC   
5839         MDCY(KC,3)=NDC  
5840     
5841 C...Perform possible tests that new information is consistent.  
5842         MSTJ24=MSTJ(24) 
5843         MSTJ(24)=0  
5844         DO 170 KC=1,MSTU(6) 
5845         WRITE(CHKC,1300) KC 
5846         IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),  
5847      &  PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,   
5848      &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)  
5849         BRSUM=0.    
5850         DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1   
5851         IF(MDME(IDC,2).GT.80) GOTO 160  
5852         KQ=KCHG(KC,1)   
5853         PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)  
5854         MERR=0  
5855         DO 150 J=1,5    
5856         KP=KFDP(IDC,J)  
5857         IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN  
5858         ELSEIF(LUCOMP(KP).EQ.0) THEN    
5859           MERR=3    
5860         ELSE    
5861           KQ=KQ-LUCHGE(KP)  
5862           PMS=PMS-ULMASS(KP)    
5863         ENDIF   
5864   150   CONTINUE    
5865         IF(KQ.NE.0) MERR=MAX(2,MERR)    
5866         IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND. 
5867      &  (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.  
5868      &  MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)   
5869         IF(MERR.EQ.3) CALL LUERRM(17,   
5870      &  '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)   
5871         IF(MERR.EQ.2) CALL LUERRM(17,   
5872      &  '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)    
5873         IF(MERR.EQ.1) CALL LUERRM(7,    
5874      &  '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)    
5875         BRSUM=BRSUM+BRAT(IDC)   
5876   160   CONTINUE    
5877         WRITE(CHTMP,1500) BRSUM 
5878         IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL   
5879      &  LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)// 
5880      &  ' for KC ='//CHKC)  
5881   170   CONTINUE    
5882         MSTJ(24)=MSTJ24 
5883     
5884 C...Initialize writing of DATA statements for inclusion in program. 
5885       ELSEIF(MUPDA.EQ.3) THEN   
5886         DO 240 IVAR=1,19    
5887         NDIM=MSTU(6)    
5888         IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)  
5889         NLIN=1  
5890         CHLIN=' '   
5891         CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/' 
5892         LLIN=35 
5893         CHOLD='START'   
5894     
5895 C...Loop through variables for conversion to characters.    
5896         DO 220 IDIM=1,NDIM  
5897         IF(IVAR.EQ.1) WRITE(CHTMP,1400) KCHG(IDIM,1)    
5898         IF(IVAR.EQ.2) WRITE(CHTMP,1400) KCHG(IDIM,2)    
5899         IF(IVAR.EQ.3) WRITE(CHTMP,1400) KCHG(IDIM,3)    
5900         IF(IVAR.EQ.4) WRITE(CHTMP,1500) PMAS(IDIM,1)    
5901         IF(IVAR.EQ.5) WRITE(CHTMP,1500) PMAS(IDIM,2)    
5902         IF(IVAR.EQ.6) WRITE(CHTMP,1500) PMAS(IDIM,3)    
5903         IF(IVAR.EQ.7) WRITE(CHTMP,1500) PMAS(IDIM,4)    
5904         IF(IVAR.EQ.8) WRITE(CHTMP,1400) MDCY(IDIM,1)    
5905         IF(IVAR.EQ.9) WRITE(CHTMP,1400) MDCY(IDIM,2)    
5906         IF(IVAR.EQ.10) WRITE(CHTMP,1400) MDCY(IDIM,3)   
5907         IF(IVAR.EQ.11) WRITE(CHTMP,1400) MDME(IDIM,1)   
5908         IF(IVAR.EQ.12) WRITE(CHTMP,1400) MDME(IDIM,2)   
5909         IF(IVAR.EQ.13) WRITE(CHTMP,1500) BRAT(IDIM) 
5910         IF(IVAR.EQ.14) WRITE(CHTMP,1400) KFDP(IDIM,1)   
5911         IF(IVAR.EQ.15) WRITE(CHTMP,1400) KFDP(IDIM,2)   
5912         IF(IVAR.EQ.16) WRITE(CHTMP,1400) KFDP(IDIM,3)   
5913         IF(IVAR.EQ.17) WRITE(CHTMP,1400) KFDP(IDIM,4)   
5914         IF(IVAR.EQ.18) WRITE(CHTMP,1400) KFDP(IDIM,5)   
5915         IF(IVAR.EQ.19) CHTMP=CHAF(IDIM) 
5916     
5917 C...Length of variable, trailing decimal zeros, quotation marks.    
5918         LLOW=1  
5919         LHIG=1  
5920         DO 180 LL=1,12  
5921         IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL    
5922   180   IF(CHTMP(LL:LL).NE.' ') LHIG=LL 
5923         CHNEW=CHTMP(LLOW:LHIG)//' ' 
5924         LNEW=1+LHIG-LLOW    
5925         IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN    
5926           LNEW=LNEW+1   
5927   190     LNEW=LNEW-1   
5928           IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190  
5929           IF(LNEW.EQ.1) CHNEW(1:2)='0.' 
5930           IF(LNEW.EQ.1) LNEW=2  
5931         ELSEIF(IVAR.EQ.19) THEN 
5932           DO 200 LL=LNEW,1,-1   
5933           IF(CHNEW(LL:LL).EQ.'''') THEN 
5934             CHTMP=CHNEW 
5935             CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11) 
5936             LNEW=LNEW+1 
5937           ENDIF 
5938   200     CONTINUE  
5939           CHTMP=CHNEW   
5940           CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//'''' 
5941           LNEW=LNEW+2   
5942         ENDIF   
5943     
5944 C...Form composite character string, often including repetition counter.    
5945         IF(CHNEW.NE.CHOLD) THEN 
5946           NRPT=1    
5947           CHOLD=CHNEW   
5948           CHCOM=CHNEW   
5949           LCOM=LNEW 
5950         ELSE    
5951           LRPT=LNEW+1   
5952           IF(NRPT.GE.2) LRPT=LNEW+3 
5953           IF(NRPT.GE.10) LRPT=LNEW+4    
5954           IF(NRPT.GE.100) LRPT=LNEW+5   
5955           IF(NRPT.GE.1000) LRPT=LNEW+6  
5956           LLIN=LLIN-LRPT    
5957           NRPT=NRPT+1   
5958           WRITE(CHTMP,1400) NRPT    
5959           LRPT=1    
5960           IF(NRPT.GE.10) LRPT=2 
5961           IF(NRPT.GE.100) LRPT=3    
5962           IF(NRPT.GE.1000) LRPT=4   
5963           CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)    
5964           LCOM=LRPT+1+LNEW  
5965         ENDIF   
5966     
5967 C...Add characters to end of line, to new line (after storing old line),    
5968 C...or to new block of lines (after writing old block). 
5969         IF(LLIN+LCOM.LE.70) THEN    
5970           CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','  
5971           LLIN=LLIN+LCOM+1  
5972         ELSEIF(NLIN.LE.19) THEN 
5973           CHLIN(LLIN+1:72)=' '  
5974           CHBLK(NLIN)=CHLIN 
5975           NLIN=NLIN+1   
5976           CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//',' 
5977           LLIN=6+LCOM+1 
5978         ELSE    
5979           CHLIN(LLIN:72)='/'//' '   
5980           CHBLK(NLIN)=CHLIN 
5981           WRITE(CHTMP,1400) IDIM-NRPT   
5982           CHBLK(1)(30:33)=CHTMP(9:12)   
5983           DO 210 ILIN=1,NLIN    
5984   210     WRITE(LFN,1600) CHBLK(ILIN)   
5985           NLIN=1    
5986           CHLIN=' ' 
5987           CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I=    ,    )/'//  
5988      &    CHCOM(1:LCOM)//','    
5989           WRITE(CHTMP,1400) IDIM-NRPT+1 
5990           CHLIN(25:28)=CHTMP(9:12)  
5991           LLIN=35+LCOM+1    
5992         ENDIF   
5993   220   CONTINUE    
5994     
5995 C...Write final block of lines. 
5996         CHLIN(LLIN:72)='/'//' ' 
5997         CHBLK(NLIN)=CHLIN   
5998         WRITE(CHTMP,1400) NDIM  
5999         CHBLK(1)(30:33)=CHTMP(9:12) 
6000         DO 230 ILIN=1,NLIN  
6001   230   WRITE(LFN,1600) CHBLK(ILIN) 
6002   240   CONTINUE    
6003       ENDIF 
6004     
6005 C...Formats for reading and writing particle data.  
6006  1000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)    
6007  1100 FORMAT(5X,2I5,F12.5,5I8)  
6008  1200 FORMAT(A80)   
6009  1300 FORMAT(I4)    
6010  1400 FORMAT(I12)   
6011  1500 FORMAT(F12.5) 
6012  1600 FORMAT(A72)   
6013     
6014       RETURN    
6015       END   
6016     
6017 C*********************************************************************  
6018     
6019       FUNCTION KLU(I,J) 
6020     
6021 C...Purpose: to provide various integer-valued event related data.  
6022       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6023       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6024       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6025       SAVE 
6026     
6027 C...Default value. For I=0 number of entries, number of stable entries  
6028 C...or 3 times total charge.    
6029       KLU=0 
6030       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN 
6031       ELSEIF(I.EQ.0.AND.J.EQ.1) THEN    
6032         KLU=N   
6033       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN    
6034         DO 100 I1=1,N   
6035         IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+1 
6036         IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+  
6037      &  LUCHGE(K(I1,2)) 
6038   100   CONTINUE    
6039       ELSEIF(I.EQ.0) THEN   
6040     
6041 C...For I > 0 direct readout of K matrix or charge. 
6042       ELSEIF(J.LE.5) THEN   
6043         KLU=K(I,J)  
6044       ELSEIF(J.EQ.6) THEN   
6045         KLU=LUCHGE(K(I,2))  
6046     
6047 C...Status (existing/fragmented/decayed), parton/hadron separation. 
6048       ELSEIF(J.LE.8) THEN   
6049         IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLU=1  
6050         IF(J.EQ.8) KLU=KLU*K(I,2)   
6051       ELSEIF(J.LE.12) THEN  
6052         KFA=IABS(K(I,2))    
6053         KC=LUCOMP(KFA)  
6054         KQ=0    
6055         IF(KC.NE.0) KQ=KCHG(KC,2)   
6056         IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLU=K(I,2)   
6057         IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLU=K(I,2)  
6058         IF(J.EQ.11) KLU=KC  
6059         IF(J.EQ.12) KLU=KQ*ISIGN(1,K(I,2))  
6060     
6061 C...Heaviest flavour in hadron/diquark. 
6062       ELSEIF(J.EQ.13) THEN  
6063         KFA=IABS(K(I,2))    
6064         KLU=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)   
6065         IF(KFA.LT.10) KLU=KFA   
6066         IF(MOD(KFA/1000,10).NE.0) KLU=MOD(KFA/1000,10)  
6067         KLU=KLU*ISIGN(1,K(I,2)) 
6068     
6069 C...Particle history: generation, ancestor, rank.   
6070       ELSEIF(J.LE.16) THEN  
6071         I2=I    
6072         I1=I    
6073   110   KLU=KLU+1   
6074         I3=I2   
6075         I2=I1   
6076         I1=K(I1,3)  
6077         IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110 
6078         IF(J.EQ.15) KLU=I2  
6079         IF(J.EQ.16) THEN    
6080           KLU=0 
6081           DO 120 I1=I2+1,I3 
6082   120     IF(K(I1,3).EQ.I2.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) KLU=KLU+1    
6083         ENDIF   
6084     
6085 C...Particle coming from collapsing jet system or not.  
6086       ELSEIF(J.EQ.17) THEN  
6087         I1=I    
6088   130   KLU=KLU+1   
6089         I3=I1   
6090         I1=K(I1,3)  
6091         I0=MAX(1,I1)    
6092         KC=LUCOMP(K(I0,2))  
6093         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN    
6094           IF(KLU.EQ.1) KLU=-1   
6095           IF(KLU.GT.1) KLU=0    
6096           RETURN    
6097         ENDIF   
6098         IF(KCHG(KC,2).EQ.0) GOTO 130    
6099         IF(K(I1,1).NE.12) KLU=0 
6100         IF(K(I1,1).NE.12) RETURN    
6101         I2=I1   
6102   140   I2=I2+1 
6103         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 140  
6104         K3M=K(I3-1,3)   
6105         IF(K3M.GE.I1.AND.K3M.LE.I2) KLU=0   
6106         K3P=K(I3+1,3)   
6107         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLU=0   
6108     
6109 C...Number of decay products. Colour flow.  
6110       ELSEIF(J.EQ.18) THEN  
6111         IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLU=MAX(0,K(I,5)-K(I,4)+1) 
6112         IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLU=0    
6113       ELSEIF(J.LE.22) THEN  
6114         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN    
6115         IF(J.EQ.19) KLU=MOD(K(I,4)/MSTU(5),MSTU(5)) 
6116         IF(J.EQ.20) KLU=MOD(K(I,5)/MSTU(5),MSTU(5)) 
6117         IF(J.EQ.21) KLU=MOD(K(I,4),MSTU(5)) 
6118         IF(J.EQ.22) KLU=MOD(K(I,5),MSTU(5)) 
6119       ELSE  
6120       ENDIF 
6121     
6122       RETURN    
6123       END   
6124     
6125 C*********************************************************************  
6126     
6127       FUNCTION PLU(I,J) 
6128     
6129 C...Purpose: to provide various real-valued event related data. 
6130       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6131       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6132       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6133       DIMENSION PSUM(4) 
6134       SAVE 
6135  
6136 C...Set default value. For I = 0 sum of momenta or charges, 
6137 C...or invariant mass of system.    
6138       PLU=0.    
6139       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN 
6140       ELSEIF(I.EQ.0.AND.J.LE.4) THEN    
6141         DO 100 I1=1,N   
6142   100   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)  
6143       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN    
6144         DO 110 J1=1,4   
6145         PSUM(J1)=0. 
6146         DO 110 I1=1,N   
6147   110   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)   
6148         PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))   
6149       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN    
6150         DO 120 I1=1,N   
6151   120   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.   
6152       ELSEIF(I.EQ.0) THEN   
6153     
6154 C...Direct readout of P matrix. 
6155       ELSEIF(J.LE.5) THEN   
6156         PLU=P(I,J)  
6157     
6158 C...Charge, total momentum, transverse momentum, transverse mass.   
6159       ELSEIF(J.LE.12) THEN  
6160         IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.    
6161         IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2  
6162         IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2   
6163         IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2    
6164         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)  
6165     
6166 C...Theta and phi angle in radians or degrees.  
6167       ELSEIF(J.LE.16) THEN  
6168         IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))    
6169         IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))   
6170         IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1) 
6171     
6172 C...True rapidity, rapidity with pion mass, pseudorapidity. 
6173       ELSEIF(J.LE.19) THEN  
6174         PMR=0.  
6175         IF(J.EQ.17) PMR=P(I,5)  
6176         IF(J.EQ.18) PMR=ULMASS(211) 
6177         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)    
6178         PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), 
6179      &  1E20)),P(I,3))  
6180     
6181 C...Energy and momentum fractions (only to be used in CM frame).    
6182       ELSEIF(J.LE.25) THEN  
6183         IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) 
6184         IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)  
6185         IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)   
6186         IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)  
6187         IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)    
6188         IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)    
6189       ENDIF 
6190     
6191       RETURN    
6192       END   
6193     
6194 C*********************************************************************  
6195     
6196       SUBROUTINE LUSPHE(SPH,APL)    
6197     
6198 C...Purpose: to perform sphericity tensor analysis to give sphericity,  
6199 C...aplanarity and the related event axes.  
6200       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6201       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6202       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6203       DIMENSION SM(3,3),SV(3,3) 
6204       SAVE
6205     
6206 C...Calculate matrix to be diagonalized.    
6207       NP=0  
6208       DO 100 J1=1,3 
6209       DO 100 J2=J1,3    
6210   100 SM(J1,J2)=0.  
6211       PS=0. 
6212       DO 120 I=1,N  
6213       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120  
6214       IF(MSTU(41).GE.2) THEN    
6215         KC=LUCOMP(K(I,2))   
6216         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.  
6217      &  KC.EQ.18) GOTO 120  
6218         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)   
6219      &  GOTO 120    
6220       ENDIF 
6221       NP=NP+1   
6222       PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)    
6223       PWT=1.    
6224       IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)    
6225       DO 110 J1=1,3 
6226       DO 110 J2=J1,3    
6227   110 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)   
6228       PS=PS+PWT*PA**2   
6229   120 CONTINUE  
6230     
6231 C...Very low multiplicities (0 or 1) not considered.    
6232       IF(NP.LE.1) THEN  
6233         CALL LUERRM(8,'(LUSPHE:) too few particles for analysis')   
6234         SPH=-1. 
6235         APL=-1. 
6236         RETURN  
6237       ENDIF 
6238       DO 130 J1=1,3 
6239       DO 130 J2=J1,3    
6240   130 SM(J1,J2)=SM(J1,J2)/PS    
6241     
6242 C...Find eigenvalues to matrix (third degree equation). 
6243       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-   
6244      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.   
6245       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*  
6246      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.    
6247       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.) 
6248       P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)    
6249       P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)   
6250       P(N+2,4)=1.-P(N+1,4)-P(N+3,4) 
6251       IF(P(N+2,4).LT.1E-5) THEN 
6252         CALL LUERRM(8,'(LUSPHE:) all particles back-to-back')   
6253         SPH=-1. 
6254         APL=-1. 
6255         RETURN  
6256       ENDIF 
6257     
6258 C...Find first and last eigenvector by solving equation system. 
6259       DO 170 I=1,3,2    
6260       DO 140 J1=1,3 
6261       SV(J1,J1)=SM(J1,J1)-P(N+I,4)  
6262       DO 140 J2=J1+1,3  
6263       SV(J1,J2)=SM(J1,J2)   
6264   140 SV(J2,J1)=SM(J1,J2)   
6265       SMAX=0.   
6266       DO 150 J1=1,3 
6267       DO 150 J2=1,3 
6268       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 150   
6269       JA=J1 
6270       JB=J2 
6271       SMAX=ABS(SV(J1,J2))   
6272   150 CONTINUE  
6273       SMAX=0.   
6274       DO 160 J3=JA+1,JA+2   
6275       J1=J3-3*((J3-1)/3)    
6276       RL=SV(J1,JB)/SV(JA,JB)    
6277       DO 160 J2=1,3 
6278       SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)  
6279       IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 160   
6280       JC=J1 
6281       SMAX=ABS(SV(J1,J2))   
6282   160 CONTINUE  
6283       JB1=JB+1-3*(JB/3) 
6284       JB2=JB+2-3*((JB+1)/3) 
6285       P(N+I,JB1)=-SV(JC,JB2)    
6286       P(N+I,JB2)=SV(JC,JB1) 
6287       P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/ 
6288      &SV(JA,JB) 
6289       PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)  
6290       SGN=(-1.)**INT(RLU(0)+0.5)    
6291       DO 170 J=1,3  
6292   170 P(N+I,J)=SGN*P(N+I,J)/PA  
6293     
6294 C...Middle axis orthogonal to other two. Fill other codes.  
6295       SGN=(-1.)**INT(RLU(0)+0.5)    
6296       P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))    
6297       P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))    
6298       P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))    
6299       DO 180 I=1,3  
6300       K(N+I,1)=31   
6301       K(N+I,2)=95   
6302       K(N+I,3)=I    
6303       K(N+I,4)=0    
6304       K(N+I,5)=0    
6305       P(N+I,5)=0.   
6306       DO 180 J=1,5  
6307   180 V(I,J)=0. 
6308     
6309 C...Select storing option. Calculate sphericity and aplanarity. 
6310       MSTU(61)=N+1  
6311       MSTU(62)=NP   
6312       IF(MSTU(43).LE.1) MSTU(3)=3   
6313       IF(MSTU(43).GE.2) N=N+3   
6314       SPH=1.5*(P(N+2,4)+P(N+3,4))   
6315       APL=1.5*P(N+3,4)  
6316     
6317       RETURN    
6318       END   
6319     
6320 C*********************************************************************  
6321     
6322       SUBROUTINE LUTHRU(THR,OBL)    
6323     
6324 C...Purpose: to perform thrust analysis to give thrust, oblateness  
6325 C...and the related event axes. 
6326       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6327       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6328       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6329       DIMENSION TDI(3),TPR(3)   
6330       SAVE
6331 
6332 C...Take copy of particles that are to be considered in thrust analysis.    
6333       NP=0  
6334       PS=0. 
6335       DO 100 I=1,N  
6336       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100  
6337       IF(MSTU(41).GE.2) THEN    
6338         KC=LUCOMP(K(I,2))   
6339         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.  
6340      &  KC.EQ.18) GOTO 100  
6341         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)   
6342      &  GOTO 100    
6343       ENDIF 
6344       IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN   
6345         CALL LUERRM(11,'(LUTHRU:) no more memory left in LUJETS')   
6346         THR=-2. 
6347         OBL=-2. 
6348         RETURN  
6349       ENDIF 
6350       NP=NP+1   
6351       K(N+NP,1)=23  
6352       P(N+NP,1)=P(I,1)  
6353       P(N+NP,2)=P(I,2)  
6354       P(N+NP,3)=P(I,3)  
6355       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) 
6356       P(N+NP,5)=1.  
6357       IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)  
6358       PS=PS+P(N+NP,4)*P(N+NP,5) 
6359   100 CONTINUE  
6360     
6361 C...Very low multiplicities (0 or 1) not considered.    
6362       IF(NP.LE.1) THEN  
6363         CALL LUERRM(8,'(LUTHRU:) too few particles for analysis')   
6364         THR=-1. 
6365         OBL=-1. 
6366         RETURN  
6367       ENDIF 
6368     
6369 C...Loop over thrust and major. T axis along z direction in latter case.    
6370       DO 280 ILD=1,2    
6371       IF(ILD.EQ.2) THEN 
6372         K(N+NP+1,1)=31  
6373         PHI=ULANGL(P(N+NP+1,1),P(N+NP+1,2)) 
6374         CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0) 
6375         THE=ULANGL(P(N+NP+1,3),P(N+NP+1,1)) 
6376         CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0) 
6377       ENDIF 
6378     
6379 C...Find and order particles with highest p (pT for major). 
6380       DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4 
6381   110 P(ILF,4)=0.   
6382       DO 150 I=N+1,N+NP 
6383       IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2) 
6384       DO 120 ILF=N+NP+MSTU(44)+3,N+NP+4,-1  
6385       IF(P(I,4).LE.P(ILF,4)) GOTO 130   
6386       DO 120 J=1,5  
6387   120 P(ILF+1,J)=P(ILF,J)   
6388       ILF=N+NP+3    
6389   130 DO 140 J=1,5  
6390   140 P(ILF+1,J)=P(I,J) 
6391   150 CONTINUE  
6392     
6393 C...Find and order initial axes with highest thrust (major).    
6394       DO 160 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15   
6395   160 P(ILG,4)=0.   
6396       NC=2**(MIN(MSTU(44),NP)-1)    
6397       DO 220 ILC=1,NC   
6398       DO 170 J=1,3  
6399   170 TDI(J)=0. 
6400       DO 180 ILF=1,MIN(MSTU(44),NP) 
6401       SGN=P(N+NP+ILF+3,5)   
6402       IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN    
6403       DO 180 J=1,4-ILD  
6404   180 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J) 
6405       TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2 
6406       DO 190 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1 
6407       IF(TDS.LE.P(ILG,4)) GOTO 200  
6408       DO 190 J=1,4  
6409   190 P(ILG+1,J)=P(ILG,J)   
6410       ILG=N+NP+MSTU(44)+4   
6411   200 DO 210 J=1,3  
6412   210 P(ILG+1,J)=TDI(J) 
6413       P(ILG+1,4)=TDS    
6414   220 CONTINUE  
6415     
6416 C...Iterate direction of axis until stable maximum. 
6417       P(N+NP+ILD,4)=0.  
6418       ILG=0 
6419   230 ILG=ILG+1 
6420       THP=0.    
6421   240 THPS=THP  
6422       DO 250 J=1,3  
6423       IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)  
6424       IF(THP.GT.1E-10) TDI(J)=TPR(J)    
6425   250 TPR(J)=0. 
6426       DO 260 I=N+1,N+NP 
6427       SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))    
6428       DO 260 J=1,4-ILD  
6429   260 TPR(J)=TPR(J)+SGN*P(I,J)  
6430       THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS    
6431       IF(THP.GE.THPS+PARU(48)) GOTO 240 
6432     
6433 C...Save good axis. Try new initial axis until a number of tries agree. 
6434       IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 230  
6435       IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN    
6436         IAGR=0  
6437         SGN=(-1.)**INT(RLU(0)+0.5)  
6438         DO 270 J=1,3    
6439   270   P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)   
6440         P(N+NP+ILD,4)=THP   
6441         P(N+NP+ILD,5)=0.    
6442       ENDIF 
6443       IAGR=IAGR+1   
6444   280 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 230   
6445     
6446 C...Find minor axis and value by orthogonality. 
6447       SGN=(-1.)**INT(RLU(0)+0.5)    
6448       P(N+NP+3,1)=-SGN*P(N+NP+2,2)  
6449       P(N+NP+3,2)=SGN*P(N+NP+2,1)   
6450       P(N+NP+3,3)=0.    
6451       THP=0.    
6452       DO 290 I=N+1,N+NP 
6453   290 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2)) 
6454       P(N+NP+3,4)=THP/PS    
6455       P(N+NP+3,5)=0.    
6456     
6457 C...Fill axis information. Rotate back to original coordinate system.   
6458       DO 300 ILD=1,3    
6459       K(N+ILD,1)=31 
6460       K(N+ILD,2)=96 
6461       K(N+ILD,3)=ILD    
6462       K(N+ILD,4)=0  
6463       K(N+ILD,5)=0  
6464       DO 300 J=1,5  
6465       P(N+ILD,J)=P(N+NP+ILD,J)  
6466   300 V(N+ILD,J)=0. 
6467       CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)  
6468     
6469 C...Select storing option. Calculate thurst and oblateness. 
6470       MSTU(61)=N+1  
6471       MSTU(62)=NP   
6472       IF(MSTU(43).LE.1) MSTU(3)=3   
6473       IF(MSTU(43).GE.2) N=N+3   
6474       THR=P(N+1,4)  
6475       OBL=P(N+2,4)-P(N+3,4) 
6476     
6477       RETURN    
6478       END   
6479     
6480 C*********************************************************************  
6481     
6482       SUBROUTINE LUCLUS(NJET)   
6483     
6484 C...Purpose: to subdivide the particle content of an event into 
6485 C...jets/clusters.  
6486       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6487       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6488       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6489       DIMENSION PS(5)   
6490 C      SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM   
6491       INTEGER NSAV,NP,NPRE,NREM
6492       SAVE
6493 
6494 C...Functions: distance measure in pT or (pseudo)mass.  
6495       R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-  
6496      &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2   
6497       R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*   
6498      &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))   
6499     
6500 C...If first time, reset. If reentering, skip preliminaries.    
6501       IF(MSTU(48).LE.0) THEN    
6502         NP=0    
6503         DO 100 J=1,5    
6504   100   PS(J)=0.    
6505         PSS=0.  
6506       ELSE  
6507         NJET=NSAV   
6508         IF(MSTU(43).GE.2) N=N-NJET  
6509         DO 110 I=N+1,N+NJET 
6510   110   P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)  
6511         IF(MSTU(46).LE.3) R2ACC=PARU(44)**2 
6512         IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2   
6513         NLOOP=0 
6514         GOTO 290    
6515       ENDIF 
6516     
6517 C...Find which particles are to be considered in cluster search.    
6518       DO 140 I=1,N  
6519       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140  
6520       IF(MSTU(41).GE.2) THEN    
6521         KC=LUCOMP(K(I,2))   
6522         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.  
6523      &  KC.EQ.18) GOTO 140  
6524         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)   
6525      &  GOTO 140    
6526       ENDIF 
6527       IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN 
6528         CALL LUERRM(11,'(LUCLUS:) no more memory left in LUJETS')   
6529         NJET=-1 
6530         RETURN  
6531       ENDIF 
6532     
6533 C...Take copy of these particles, with space left for jets later on.    
6534       NP=NP+1   
6535       K(N+NP,3)=I   
6536       DO 120 J=1,5  
6537   120 P(N+NP,J)=P(I,J)  
6538       IF(MSTU(42).EQ.0) P(N+NP,5)=0.    
6539       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)  
6540       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)    
6541       P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) 
6542       DO 130 J=1,4  
6543   130 PS(J)=PS(J)+P(N+NP,J) 
6544       PSS=PSS+P(N+NP,5) 
6545   140 CONTINUE  
6546       DO 150 I=N+1,N+NP 
6547       K(I+NP,3)=K(I,3)  
6548       DO 150 J=1,5  
6549   150 P(I+NP,J)=P(I,J)  
6550       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))   
6551     
6552 C...Very low multiplicities not considered. 
6553       IF(NP.LT.MSTU(47)) THEN   
6554         CALL LUERRM(8,'(LUCLUS:) too few particles for analysis')   
6555         NJET=-1 
6556         RETURN  
6557       ENDIF 
6558     
6559 C...Find precluster configuration. If too few jets, make harder cuts.   
6560       NLOOP=0   
6561       IF(MSTU(46).LE.3) R2ACC=PARU(44)**2   
6562       IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2 
6563       RINIT=1.25*PARU(43)   
6564       IF(NP.LE.MSTU(47)+2) RINIT=0. 
6565   160 RINIT=0.8*RINIT   
6566       NPRE=0    
6567       NREM=NP   
6568       DO 170 I=N+NP+1,N+2*NP    
6569   170 K(I,4)=0  
6570     
6571 C...Sum up small momentum region. Jet if enough absolute momentum.  
6572       IF(MSTU(46).LE.2) THEN    
6573         DO 180 J=1,4    
6574   180   P(N+1,J)=0. 
6575         DO 200 I=N+NP+1,N+2*NP  
6576         IF(P(I,5).GT.2.*RINIT) GOTO 200 
6577         NREM=NREM-1 
6578         K(I,4)=1    
6579         DO 190 J=1,4    
6580   190   P(N+1,J)=P(N+1,J)+P(I,J)    
6581   200   CONTINUE    
6582         P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)  
6583         IF(P(N+1,5).GT.2.*RINIT) NPRE=1 
6584         IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160    
6585       ENDIF 
6586     
6587 C...Find fastest remaining particle.    
6588   210 NPRE=NPRE+1   
6589       PMAX=0.   
6590       DO 220 I=N+NP+1,N+2*NP    
6591       IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 220    
6592       IMAX=I    
6593       PMAX=P(I,5)   
6594   220 CONTINUE  
6595       DO 230 J=1,5  
6596   230 P(N+NPRE,J)=P(IMAX,J) 
6597       NREM=NREM-1   
6598       K(IMAX,4)=NPRE    
6599     
6600 C...Sum up precluster around it according to pT separation. 
6601       IF(MSTU(46).LE.2) THEN    
6602         DO 250 I=N+NP+1,N+2*NP  
6603         IF(K(I,4).NE.0) GOTO 250    
6604         R2=R2T(I,IMAX)  
6605         IF(R2.GT.RINIT**2) GOTO 250 
6606         NREM=NREM-1 
6607         K(I,4)=NPRE 
6608         DO 240 J=1,4    
6609   240   P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)  
6610   250   CONTINUE    
6611         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)  
6612     
6613 C...Sum up precluster around it according to mass separation.   
6614       ELSE  
6615   260   IMIN=0  
6616         R2MIN=RINIT**2  
6617         DO 270 I=N+NP+1,N+2*NP  
6618         IF(K(I,4).NE.0) GOTO 270    
6619         R2=R2M(I,N+NPRE)    
6620         IF(R2.GE.R2MIN) GOTO 270    
6621         IMIN=I  
6622         R2MIN=R2    
6623   270   CONTINUE    
6624         IF(IMIN.NE.0) THEN  
6625           DO 280 J=1,4  
6626   280     P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J) 
6627           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)    
6628           NREM=NREM-1   
6629           K(IMIN,4)=NPRE    
6630           GOTO 260  
6631         ENDIF   
6632       ENDIF 
6633     
6634 C...Check if more preclusters to be found. Start over if too few.   
6635       IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160  
6636       IF(NREM.GT.0) GOTO 210    
6637       NJET=NPRE 
6638     
6639 C...Reassign all particles to nearest jet. Sum up new jet momenta.  
6640   290 TSAV=0.   
6641       PSJT=0.   
6642   300 IF(MSTU(46).LE.1) THEN    
6643         DO 310 I=N+1,N+NJET 
6644         DO 310 J=1,4    
6645   310   V(I,J)=0.   
6646         DO 340 I=N+NP+1,N+2*NP  
6647         R2MIN=PSS**2    
6648         DO 320 IJET=N+1,N+NJET  
6649         IF(P(IJET,5).LT.RINIT) GOTO 320 
6650         R2=R2T(I,IJET)  
6651         IF(R2.GE.R2MIN) GOTO 320    
6652         IMIN=IJET   
6653         R2MIN=R2    
6654   320   CONTINUE    
6655         K(I,4)=IMIN-N   
6656         DO 330 J=1,4    
6657   330   V(IMIN,J)=V(IMIN,J)+P(I,J)  
6658   340   CONTINUE    
6659         PSJT=0. 
6660         DO 360 I=N+1,N+NJET 
6661         DO 350 J=1,4    
6662   350   P(I,J)=V(I,J)   
6663         P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)  
6664   360   PSJT=PSJT+P(I,5)    
6665       ENDIF 
6666     
6667 C...Find two closest jets.  
6668       R2MIN=2.*R2ACC    
6669       DO 370 ITRY1=N+1,N+NJET-1 
6670       DO 370 ITRY2=ITRY1+1,N+NJET   
6671       IF(MSTU(46).LE.2) R2=R2T(ITRY1,ITRY2) 
6672       IF(MSTU(46).GE.3) R2=R2M(ITRY1,ITRY2) 
6673       IF(R2.GE.R2MIN) GOTO 370  
6674       IMIN1=ITRY1   
6675       IMIN2=ITRY2   
6676       R2MIN=R2  
6677   370 CONTINUE  
6678     
6679 C...If allowed, join two closest jets and start over.   
6680       IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN  
6681         IREC=MIN(IMIN1,IMIN2)   
6682         IDEL=MAX(IMIN1,IMIN2)   
6683         DO 380 J=1,4    
6684   380   P(IREC,J)=P(IMIN1,J)+P(IMIN2,J) 
6685         P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)  
6686         DO 390 I=IDEL+1,N+NJET  
6687         DO 390 J=1,5    
6688   390   P(I-1,J)=P(I,J) 
6689         IF(MSTU(46).GE.2) THEN  
6690           DO 400 I=N+NP+1,N+2*NP    
6691           IORI=N+K(I,4) 
6692           IF(IORI.EQ.IDEL) K(I,4)=IREC-N    
6693   400     IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1  
6694         ENDIF   
6695         NJET=NJET-1 
6696         GOTO 290    
6697     
6698 C...Divide up broad jet if empty cluster in list of final ones. 
6699       ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN    
6700         DO 410 I=N+1,N+NJET 
6701   410   K(I,5)=0    
6702         DO 420 I=N+NP+1,N+2*NP  
6703   420   K(N+K(I,4),5)=K(N+K(I,4),5)+1   
6704         IEMP=0  
6705         DO 430 I=N+1,N+NJET 
6706   430   IF(K(I,5).EQ.0) IEMP=I  
6707         IF(IEMP.NE.0) THEN  
6708           NLOOP=NLOOP+1 
6709           ISPL=0    
6710           R2MAX=0.  
6711           DO 440 I=N+NP+1,N+2*NP    
6712           IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 440    
6713           IJET=N+K(I,4) 
6714           R2=R2T(I,IJET)    
6715           IF(R2.LE.R2MAX) GOTO 440  
6716           ISPL=I    
6717           R2MAX=R2  
6718   440     CONTINUE  
6719           IF(ISPL.NE.0) THEN    
6720             IJET=N+K(ISPL,4)    
6721             DO 450 J=1,4    
6722             P(IEMP,J)=P(ISPL,J) 
6723   450       P(IJET,J)=P(IJET,J)-P(ISPL,J)   
6724             P(IEMP,5)=P(ISPL,5) 
6725             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)  
6726             IF(NLOOP.LE.2) GOTO 290 
6727           ENDIF 
6728         ENDIF   
6729       ENDIF 
6730     
6731 C...If generalized thrust has not yet converged, continue iteration.    
6732       IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))    
6733      &THEN  
6734         TSAV=PSJT/PSS   
6735         GOTO 300    
6736       ENDIF 
6737     
6738 C...Reorder jets according to energy.   
6739       DO 460 I=N+1,N+NJET   
6740       DO 460 J=1,5  
6741   460 V(I,J)=P(I,J) 
6742       DO 490 INEW=N+1,N+NJET    
6743       PEMAX=0.  
6744       DO 470 ITRY=N+1,N+NJET    
6745       IF(V(ITRY,4).LE.PEMAX) GOTO 470   
6746       IMAX=ITRY 
6747       PEMAX=V(ITRY,4)   
6748   470 CONTINUE  
6749       K(INEW,1)=31  
6750       K(INEW,2)=97  
6751       K(INEW,3)=INEW-N  
6752       K(INEW,4)=0   
6753       DO 480 J=1,5  
6754   480 P(INEW,J)=V(IMAX,J)   
6755       V(IMAX,4)=-1. 
6756   490 K(IMAX,5)=INEW    
6757     
6758 C...Clean up particle-jet assignments and jet information.  
6759       DO 500 I=N+NP+1,N+2*NP    
6760       IORI=K(N+K(I,4),5)    
6761       K(I,4)=IORI-N 
6762       IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N   
6763       K(IORI,4)=K(IORI,4)+1 
6764   500 CONTINUE  
6765       IEMP=0    
6766       PSJT=0.   
6767       DO 520 I=N+1,N+NJET   
6768       K(I,5)=0  
6769       PSJT=PSJT+P(I,5)  
6770       P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))  
6771       DO 510 J=1,5  
6772   510 V(I,J)=0. 
6773   520 IF(K(I,4).EQ.0) IEMP=I    
6774     
6775 C...Select storing option. Output variables. Check for failure. 
6776       MSTU(61)=N+1  
6777       MSTU(62)=NP   
6778       MSTU(63)=NPRE 
6779       PARU(61)=PS(5)    
6780       PARU(62)=PSJT/PSS 
6781       PARU(63)=SQRT(R2MIN)  
6782       IF(NJET.LE.1) PARU(63)=0. 
6783       IF(IEMP.NE.0) THEN    
6784         CALL LUERRM(8,'(LUCLUS:) failed to reconstruct as requested')   
6785         NJET=-1 
6786       ENDIF 
6787       IF(MSTU(43).LE.1) MSTU(3)=NJET    
6788       IF(MSTU(43).GE.2) N=N+NJET    
6789       NSAV=NJET 
6790     
6791       RETURN    
6792       END   
6793     
6794 C*********************************************************************  
6795     
6796       SUBROUTINE LUCELL(NJET)   
6797     
6798 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET    
6799 C...coordinate frame, as used for calorimeters at hadron colliders. 
6800       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6801       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6802       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6803       SAVE 
6804     
6805 C...Loop over all particles. Find cell that was hit by given particle.  
6806       NCE2=2*MSTU(51)*MSTU(52)  
6807       PTLRAT=1./SINH(PARU(51))**2   
6808       NP=0  
6809       NC=N  
6810       DO 110 I=1,N  
6811       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110  
6812       IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110  
6813       IF(MSTU(41).GE.2) THEN    
6814         KC=LUCOMP(K(I,2))   
6815         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.  
6816      &  KC.EQ.18) GOTO 110  
6817         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)   
6818      &  GOTO 110    
6819       ENDIF 
6820       NP=NP+1   
6821       PT=SQRT(P(I,1)**2+P(I,2)**2)  
6822       ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))  
6823       IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))   
6824       PHI=ULANGL(P(I,1),P(I,2)) 
6825       IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))    
6826       IETPH=MSTU(52)*IETA+IPHI  
6827     
6828 C...Add to cell already hit, or book new cell.  
6829       DO 100 IC=N+1,NC  
6830       IF(IETPH.EQ.K(IC,3)) THEN 
6831         K(IC,4)=K(IC,4)+1   
6832         P(IC,5)=P(IC,5)+PT  
6833         GOTO 110    
6834       ENDIF 
6835   100 CONTINUE  
6836       IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN 
6837         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')   
6838         NJET=-2 
6839         RETURN  
6840       ENDIF 
6841       NC=NC+1   
6842       K(NC,3)=IETPH 
6843       K(NC,4)=1 
6844       K(NC,5)=2 
6845       P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))   
6846       P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))    
6847       P(NC,5)=PT    
6848   110 CONTINUE  
6849     
6850 C...Smear true bin content by calorimeter resolution.   
6851       IF(MSTU(53).GE.1) THEN    
6852         DO 130 IC=N+1,NC    
6853         PEI=P(IC,5) 
6854         IF(MSTU(53).EQ.2) PEI=P(IC,5)/COSH(P(IC,1)) 
6855   120   PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLU(0)))*PEI)*  
6856      &  COS(PARU(2)*RLU(0)) 
6857         IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120   
6858         P(IC,5)=PEF 
6859   130   IF(MSTU(53).EQ.2) P(IC,5)=PEF*COSH(P(IC,1)) 
6860       ENDIF 
6861     
6862 C...Find initiator cell: the one with highest pT of not yet used ones.  
6863       NJ=NC 
6864   140 ETMAX=0.  
6865       DO 150 IC=N+1,NC  
6866       IF(K(IC,5).NE.2) GOTO 150 
6867       IF(P(IC,5).LE.ETMAX) GOTO 150 
6868       ICMAX=IC  
6869       ETA=P(IC,1)   
6870       PHI=P(IC,2)   
6871       ETMAX=P(IC,5) 
6872   150 CONTINUE  
6873       IF(ETMAX.LT.PARU(52)) GOTO 210    
6874       IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN 
6875         CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')   
6876         NJET=-2 
6877         RETURN  
6878       ENDIF 
6879       K(ICMAX,5)=1  
6880       NJ=NJ+1   
6881       K(NJ,4)=0 
6882       K(NJ,5)=1 
6883       P(NJ,1)=ETA   
6884       P(NJ,2)=PHI   
6885       P(NJ,3)=0.    
6886       P(NJ,4)=0.    
6887       P(NJ,5)=0.    
6888     
6889 C...Sum up unused cells within required distance of initiator.  
6890       DO 160 IC=N+1,NC  
6891       IF(K(IC,5).EQ.0) GOTO 160 
6892       IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 160 
6893       DPHIA=ABS(P(IC,2)-PHI)    
6894       IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 160  
6895       PHIC=P(IC,2)  
6896       IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)  
6897       IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 160    
6898       K(IC,5)=-K(IC,5)  
6899       K(NJ,4)=K(NJ,4)+K(IC,4)   
6900       P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)   
6901       P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC  
6902       P(NJ,5)=P(NJ,5)+P(IC,5)   
6903   160 CONTINUE  
6904     
6905 C...Reject cluster below minimum ET, else accept.   
6906       IF(P(NJ,5).LT.PARU(53)) THEN  
6907         NJ=NJ-1 
6908         DO 170 IC=N+1,NC    
6909   170   IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)   
6910       ELSEIF(MSTU(54).LE.2) THEN    
6911         P(NJ,3)=P(NJ,3)/P(NJ,5) 
6912         P(NJ,4)=P(NJ,4)/P(NJ,5) 
6913         IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),   
6914      &  P(NJ,4))    
6915         DO 180 IC=N+1,NC    
6916   180   IF(K(IC,1).LT.0) K(IC,1)=0  
6917       ELSE  
6918         DO 190 J=1,4    
6919   190   P(NJ,J)=0.  
6920         DO 200 IC=N+1,NC    
6921         IF(K(IC,5).GE.0) GOTO 200   
6922         P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))    
6923         P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))    
6924         P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))   
6925         P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))   
6926         K(IC,5)=0   
6927   200   CONTINUE    
6928       ENDIF 
6929       GOTO 140  
6930     
6931 C...Arrange clusters in falling ET sequence.    
6932   210 DO 230 I=1,NJ-NC  
6933       ETMAX=0.  
6934       DO 220 IJ=NC+1,NJ 
6935       IF(K(IJ,5).EQ.0) GOTO 220 
6936       IF(P(IJ,5).LT.ETMAX) GOTO 220 
6937       IJMAX=IJ  
6938       ETMAX=P(IJ,5) 
6939   220 CONTINUE  
6940       K(IJMAX,5)=0  
6941       K(N+I,1)=31   
6942       K(N+I,2)=98   
6943       K(N+I,3)=I    
6944       K(N+I,4)=K(IJMAX,4)   
6945       K(N+I,5)=0    
6946       DO 230 J=1,5  
6947       P(N+I,J)=P(IJMAX,J)   
6948   230 V(N+I,J)=0.   
6949       NJET=NJ-NC    
6950     
6951 C...Convert to massless or massive four-vectors.    
6952       IF(MSTU(54).EQ.2) THEN    
6953         DO 240 I=N+1,N+NJET 
6954         ETA=P(I,3)  
6955         P(I,1)=P(I,5)*COS(P(I,4))   
6956         P(I,2)=P(I,5)*SIN(P(I,4))   
6957         P(I,3)=P(I,5)*SINH(ETA) 
6958         P(I,4)=P(I,5)*COSH(ETA) 
6959   240   P(I,5)=0.   
6960       ELSEIF(MSTU(54).GE.3) THEN    
6961         DO 250 I=N+1,N+NJET 
6962   250   P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))    
6963       ENDIF 
6964     
6965 C...Information about storage.  
6966       MSTU(61)=N+1  
6967       MSTU(62)=NP   
6968       MSTU(63)=NC-N 
6969       IF(MSTU(43).LE.1) MSTU(3)=NJET    
6970       IF(MSTU(43).GE.2) N=N+NJET    
6971     
6972       RETURN    
6973       END   
6974     
6975 C*********************************************************************  
6976     
6977       SUBROUTINE LUJMAS(PMH,PML)    
6978     
6979 C...Purpose: to determine, approximately, the two jet masses that   
6980 C...minimize the sum m_H|2 + m_L|2, a la Clavelli and Wyler.    
6981       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6982       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6983       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6984       DIMENSION SM(3,3),SAX(3),PS(3,5)  
6985       SAVE
6986 
6987 C...Reset.  
6988       NP=0  
6989       DO 110 J1=1,3 
6990       DO 100 J2=J1,3    
6991   100 SM(J1,J2)=0.  
6992       DO 110 J2=1,4 
6993   110 PS(J1,J2)=0.  
6994       PSS=0.    
6995     
6996 C...Take copy of particles that are to be considered in mass analysis.  
6997       DO 150 I=1,N  
6998       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150  
6999       IF(MSTU(41).GE.2) THEN    
7000         KC=LUCOMP(K(I,2))   
7001         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.  
7002      &  KC.EQ.18) GOTO 150  
7003         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)   
7004      &  GOTO 150    
7005       ENDIF 
7006       IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN 
7007         CALL LUERRM(11,'(LUJMAS:) no more memory left in LUJETS')   
7008         PMH=-2. 
7009         PML=-2. 
7010         RETURN  
7011       ENDIF 
7012       NP=NP+1   
7013       DO 120 J=1,5  
7014   120 P(N+NP,J)=P(I,J)  
7015       IF(MSTU(42).EQ.0) P(N+NP,5)=0.    
7016       IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)  
7017       P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)    
7018     
7019 C...Fill information in sphericity tensor and total momentum vector.    
7020       DO 130 J1=1,3 
7021       DO 130 J2=J1,3    
7022   130 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)   
7023       PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)   
7024       DO 140 J=1,4  
7025   140 PS(3,J)=PS(3,J)+P(N+NP,J) 
7026   150 CONTINUE  
7027     
7028 C...Very low multiplicities (0 or 1) not considered.    
7029       IF(NP.LE.1) THEN  
7030         CALL LUERRM(8,'(LUJMAS:) too few particles for analysis')   
7031         PMH=-1. 
7032         PML=-1. 
7033         RETURN  
7034       ENDIF 
7035       PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))    
7036     
7037 C...Find largest eigenvalue to matrix (third degree equation).  
7038       DO 160 J1=1,3 
7039       DO 160 J2=J1,3    
7040   160 SM(J1,J2)=SM(J1,J2)/PSS   
7041       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-   
7042      &SM(1,3)**2-SM(2,3)**2)/3.-1./9.   
7043       SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*  
7044      &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.    
7045       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.) 
7046       SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP) 
7047     
7048 C...Find largest eigenvector by solving equation system.    
7049       DO J1=1,3 
7050       SM(J1,J1)=SM(J1,J1)-SMA
7051 C     CMSSW change: added if to stay in array bounds
7052       IF(J1<3) THEN
7053       DO J2=J1+1,3  
7054       SM(J2,J1)=SM(J1,J2)
7055       ENDDO
7056       ENDIF
7057       ENDDO
7058       SMAX=0.   
7059       DO 180 J1=1,3 
7060       DO 180 J2=1,3 
7061       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 180   
7062       JA=J1 
7063       JB=J2 
7064       SMAX=ABS(SM(J1,J2))   
7065   180 CONTINUE  
7066       SMAX=0.   
7067       DO 190 J3=JA+1,JA+2   
7068       J1=J3-3*((J3-1)/3)    
7069       RL=SM(J1,JB)/SM(JA,JB)    
7070       DO 190 J2=1,3 
7071       SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)  
7072       IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 190   
7073       JC=J1 
7074       SMAX=ABS(SM(J1,J2))   
7075   190 CONTINUE  
7076       JB1=JB+1-3*(JB/3) 
7077       JB2=JB+2-3*((JB+1)/3) 
7078       SAX(JB1)=-SM(JC,JB2)  
7079       SAX(JB2)=SM(JC,JB1)   
7080       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)  
7081     
7082 C...Divide particles into two initial clusters by hemisphere.   
7083       DO 200 I=N+1,N+NP 
7084       PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)    
7085       IS=1  
7086       IF(PSAX.LT.0.) IS=2   
7087       K(I,3)=IS 
7088       DO 200 J=1,4  
7089   200 PS(IS,J)=PS(IS,J)+P(I,J)  
7090       PMS=(PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+    
7091      &(PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2) 
7092     
7093 C...Reassign one particle at a time; find maximum decrease of m|2 sum.  
7094   210 PMD=0.    
7095       IM=0  
7096       DO 220 J=1,4  
7097   220 PS(3,J)=PS(1,J)-PS(2,J)   
7098       DO 230 I=N+1,N+NP 
7099       PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)   
7100       IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)   
7101       IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)   
7102       IF(PMDI.LT.PMD) THEN  
7103         PMD=PMDI    
7104         IM=I    
7105       ENDIF 
7106   230 CONTINUE  
7107     
7108 C...Loop back if significant reduction in sum of m|2.   
7109       IF(PMD.LT.-PARU(48)*PMS) THEN 
7110         PMS=PMS+PMD 
7111         IS=K(IM,3)  
7112         DO 240 J=1,4    
7113         PS(IS,J)=PS(IS,J)-P(IM,J)   
7114   240   PS(3-IS,J)=PS(3-IS,J)+P(IM,J)   
7115         K(IM,3)=3-IS    
7116         GOTO 210    
7117       ENDIF 
7118     
7119 C...Final masses and output.    
7120       MSTU(61)=N+1  
7121       MSTU(62)=NP   
7122       PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)) 
7123       PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)) 
7124       PMH=MAX(PS(1,5),PS(2,5))  
7125       PML=MIN(PS(1,5),PS(2,5))  
7126     
7127       RETURN    
7128       END   
7129     
7130 C*********************************************************************  
7131     
7132       SUBROUTINE LUFOWO(H10,H20,H30,H40)    
7133     
7134 C...Purpose: to calculate the first few Fox-Wolfram moments.    
7135       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7136       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
7137       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
7138       SAVE 
7139     
7140 C...Copy momenta for particles and calculate H0.    
7141       NP=0  
7142       H0=0. 
7143       HD=0. 
7144       DO 110 I=1,N  
7145       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110  
7146       IF(MSTU(41).GE.2) THEN    
7147         KC=LUCOMP(K(I,2))   
7148         IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.  
7149      &  KC.EQ.18) GOTO 110  
7150         IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)   
7151      &  GOTO 110    
7152       ENDIF 
7153       IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN   
7154         CALL LUERRM(11,'(LUFOWO:) no more memory left in LUJETS')   
7155         H10=-1. 
7156         H20=-1. 
7157         H30=-1. 
7158         H40=-1. 
7159         RETURN  
7160       ENDIF 
7161       NP=NP+1   
7162       DO 100 J=1,3  
7163   100 P(N+NP,J)=P(I,J)  
7164       P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) 
7165       H0=H0+P(N+NP,4)   
7166       HD=HD+P(N+NP,4)**2    
7167   110 CONTINUE  
7168       H0=H0**2  
7169     
7170 C...Very low multiplicities (0 or 1) not considered.    
7171       IF(NP.LE.1) THEN  
7172         CALL LUERRM(8,'(LUFOWO:) too few particles for analysis')   
7173         H10=-1. 
7174         H20=-1. 
7175         H30=-1. 
7176         H40=-1. 
7177         RETURN  
7178       ENDIF 
7179     
7180 C...Calculate H1 - H4.  
7181       H10=0.    
7182       H20=0.    
7183       H30=0.    
7184       H40=0.    
7185       DO 120 I1=N+1,N+NP    
7186       DO 120 I2=I1+1,N+NP   
7187       CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/   
7188      &(P(I1,4)*P(I2,4)) 
7189       H10=H10+P(I1,4)*P(I2,4)*CTHE  
7190       H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5) 
7191       H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)    
7192       H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)    
7193   120 CONTINUE  
7194     
7195 C...Calculate H1/H0 - H4/H0. Output.    
7196       MSTU(61)=N+1  
7197       MSTU(62)=NP   
7198       H10=(HD+2.*H10)/H0    
7199       H20=(HD+2.*H20)/H0    
7200       H30=(HD+2.*H30)/H0    
7201       H40=(HD+2.*H40)/H0    
7202     
7203       RETURN    
7204       END   
7205     
7206 C*********************************************************************  
7207     
7208       SUBROUTINE LUTABU(MTABU)  
7209     
7210 C...Purpose: to evaluate various properties of an event, with   
7211 C...statistics accumulated during the course of the run and 
7212 C...printed at the end. 
7213       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7214       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
7215       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
7216       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
7217       DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),   
7218      &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),    
7219      &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),    
7220      &KFDM(8),KFDC(200,0:8),NPDC(200)   
7221 C      SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS, 
7222 C     &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,    
7223 C     &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC 
7224       CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12   
7225       SAVE
7226       DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,   
7227      &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,   
7228      &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./, 
7229      &NEVDC/0/,NKFDC/0/,NREDC/0/    
7230     
7231 C...Reset statistics on initial parton state.   
7232       IF(MTABU.EQ.10) THEN  
7233         NEVIS=0 
7234         NKFIS=0 
7235     
7236 C...Identify and order flavour content of initial state.    
7237       ELSEIF(MTABU.EQ.11) THEN  
7238         NEVIS=NEVIS+1   
7239         KFM1=2*IABS(MSTU(161))  
7240         IF(MSTU(161).GT.0) KFM1=KFM1-1  
7241         KFM2=2*IABS(MSTU(162))  
7242         IF(MSTU(162).GT.0) KFM2=KFM2-1  
7243         KFMN=MIN(KFM1,KFM2) 
7244         KFMX=MAX(KFM1,KFM2) 
7245         DO 100 I=1,NKFIS    
7246         IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN    
7247           IKFIS=-I  
7248           GOTO 110  
7249         ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND. 
7250      &  KFMX.LT.KFIS(I,2))) THEN    
7251           IKFIS=I   
7252           GOTO 110  
7253         ENDIF   
7254   100   CONTINUE    
7255         IKFIS=NKFIS+1   
7256   110   IF(IKFIS.LT.0) THEN 
7257           IKFIS=-IKFIS  
7258         ELSE    
7259           IF(NKFIS.GE.100) RETURN   
7260           DO 120 I=NKFIS,IKFIS,-1   
7261           KFIS(I+1,1)=KFIS(I,1) 
7262           KFIS(I+1,2)=KFIS(I,2) 
7263           DO 120 J=0,10 
7264   120     NPIS(I+1,J)=NPIS(I,J) 
7265           NKFIS=NKFIS+1 
7266           KFIS(IKFIS,1)=KFMN    
7267           KFIS(IKFIS,2)=KFMX    
7268           DO 130 J=0,10 
7269   130     NPIS(IKFIS,J)=0   
7270         ENDIF   
7271         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1   
7272     
7273 C...Count number of partons in initial state.   
7274         NP=0    
7275         DO 150 I=1,N    
7276         IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN    
7277         ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN 
7278         ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)    
7279      &  THEN    
7280         ELSE    
7281           IM=I  
7282   140     IM=K(IM,3)    
7283           IF(IM.LE.0.OR.IM.GT.N) THEN   
7284             NP=NP+1 
7285           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN    
7286             NP=NP+1 
7287           ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN 
7288           ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)    
7289      &    THEN  
7290           ELSE  
7291             GOTO 140    
7292           ENDIF 
7293         ENDIF   
7294   150   CONTINUE    
7295         NPCO=MAX(NP,1)  
7296         IF(NP.GE.6) NPCO=6  
7297         IF(NP.GE.8) NPCO=7  
7298         IF(NP.GE.11) NPCO=8 
7299         IF(NP.GE.16) NPCO=9 
7300         IF(NP.GE.26) NPCO=10    
7301         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1 
7302         MSTU(62)=NP 
7303     
7304 C...Write statistics on initial parton state.   
7305       ELSEIF(MTABU.EQ.12) THEN  
7306         FAC=1./MAX(1,NEVIS) 
7307         WRITE(MSTU(11),1000) NEVIS  
7308         DO 160 I=1,NKFIS    
7309         KFMN=KFIS(I,1)  
7310         IF(KFMN.EQ.0) KFMN=KFIS(I,2)    
7311         KFM1=(KFMN+1)/2 
7312         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1   
7313         CALL LUNAME(KFM1,CHAU)  
7314         CHIS(1)=CHAU(1:12)  
7315         IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'   
7316         KFMX=KFIS(I,2)  
7317         IF(KFIS(I,1).EQ.0) KFMX=0   
7318         KFM2=(KFMX+1)/2 
7319         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2   
7320         CALL LUNAME(KFM2,CHAU)  
7321         CHIS(2)=CHAU(1:12)  
7322         IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'   
7323   160   WRITE(MSTU(11),1100) CHIS(1),CHIS(2),FAC*NPIS(I,0), 
7324      &  (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10) 
7325     
7326 C...Copy statistics on initial parton state into /LUJETS/.  
7327       ELSEIF(MTABU.EQ.13) THEN  
7328         FAC=1./MAX(1,NEVIS) 
7329         DO 170 I=1,NKFIS    
7330         KFMN=KFIS(I,1)  
7331         IF(KFMN.EQ.0) KFMN=KFIS(I,2)    
7332         KFM1=(KFMN+1)/2 
7333         IF(2*KFM1.EQ.KFMN) KFM1=-KFM1   
7334         KFMX=KFIS(I,2)  
7335         IF(KFIS(I,1).EQ.0) KFMX=0   
7336         KFM2=(KFMX+1)/2 
7337         IF(2*KFM2.EQ.KFMX) KFM2=-KFM2   
7338         K(I,1)=32   
7339         K(I,2)=99   
7340         K(I,3)=KFM1 
7341         K(I,4)=KFM2 
7342         K(I,5)=NPIS(I,0)    
7343         DO 170 J=1,5    
7344         P(I,J)=FAC*NPIS(I,J)    
7345   170   V(I,J)=FAC*NPIS(I,J+5)  
7346         N=NKFIS 
7347         DO 180 J=1,5    
7348         K(N+1,J)=0  
7349         P(N+1,J)=0. 
7350   180   V(N+1,J)=0. 
7351         K(N+1,1)=32 
7352         K(N+1,2)=99 
7353         K(N+1,5)=NEVIS  
7354         MSTU(3)=1   
7355     
7356 C...Reset statistics on number of particles/partons.    
7357       ELSEIF(MTABU.EQ.20) THEN  
7358         NEVFS=0 
7359         NPRFS=0 
7360         NFIFS=0 
7361         NCHFS=0 
7362         NKFFS=0 
7363     
7364 C...Identify whether particle/parton is primary or not. 
7365       ELSEIF(MTABU.EQ.21) THEN  
7366         NEVFS=NEVFS+1   
7367         MSTU(62)=0  
7368         DO 230 I=1,N    
7369         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 230    
7370         MSTU(62)=MSTU(62)+1 
7371         KC=LUCOMP(K(I,2))   
7372         MPRI=0  
7373         IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN 
7374           MPRI=1    
7375         ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN  
7376           MPRI=1    
7377         ELSEIF(KC.EQ.0) THEN    
7378         ELSEIF(K(K(I,3),1).EQ.13) THEN  
7379           IM=K(K(I,3),3)    
7380           IF(IM.LE.0.OR.IM.GT.N) THEN   
7381             MPRI=1  
7382           ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN    
7383             MPRI=1  
7384           ENDIF 
7385         ELSEIF(KCHG(KC,2).EQ.0) THEN    
7386           KCM=LUCOMP(K(K(I,3),2))   
7387           IF(KCM.NE.0) THEN 
7388             IF(KCHG(KCM,2).NE.0) MPRI=1 
7389           ENDIF 
7390         ENDIF   
7391         IF(KC.NE.0.AND.MPRI.EQ.1) THEN  
7392           IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1 
7393         ENDIF   
7394         IF(K(I,1).LE.10) THEN   
7395           NFIFS=NFIFS+1 
7396           IF(LUCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1 
7397         ENDIF   
7398     
7399 C...Fill statistics on number of particles/partons in event.    
7400         KFA=IABS(K(I,2))    
7401         KFS=3-ISIGN(1,K(I,2))-MPRI  
7402         DO 190 IP=1,NKFFS   
7403         IF(KFA.EQ.KFFS(IP)) THEN    
7404           IKFFS=-IP 
7405           GOTO 200  
7406         ELSEIF(KFA.LT.KFFS(IP)) THEN    
7407           IKFFS=IP  
7408           GOTO 200  
7409         ENDIF   
7410   190   CONTINUE    
7411         IKFFS=NKFFS+1   
7412   200   IF(IKFFS.LT.0) THEN 
7413           IKFFS=-IKFFS  
7414         ELSE    
7415           IF(NKFFS.GE.400) RETURN   
7416           DO 210 IP=NKFFS,IKFFS,-1  
7417           KFFS(IP+1)=KFFS(IP)   
7418           DO 210 J=1,4  
7419   210     NPFS(IP+1,J)=NPFS(IP,J)   
7420           NKFFS=NKFFS+1 
7421           KFFS(IKFFS)=KFA   
7422           DO 220 J=1,4  
7423   220     NPFS(IKFFS,J)=0   
7424         ENDIF   
7425         NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1   
7426   230   CONTINUE    
7427     
7428 C...Write statistics on particle/parton composition of events.  
7429       ELSEIF(MTABU.EQ.22) THEN  
7430         FAC=1./MAX(1,NEVFS) 
7431         WRITE(MSTU(11),1200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS    
7432         DO 240 I=1,NKFFS    
7433         CALL LUNAME(KFFS(I),CHAU)   
7434         KC=LUCOMP(KFFS(I))  
7435         MDCYF=0 
7436         IF(KC.NE.0) MDCYF=MDCY(KC,1)    
7437   240   WRITE(MSTU(11),1300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),  
7438      &  FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))   
7439     
7440 C...Copy particle/parton composition information into /LUJETS/. 
7441       ELSEIF(MTABU.EQ.23) THEN  
7442         FAC=1./MAX(1,NEVFS) 
7443         DO 260 I=1,NKFFS    
7444         K(I,1)=32   
7445         K(I,2)=99   
7446         K(I,3)=KFFS(I)  
7447         K(I,4)=0    
7448         K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)  
7449         DO 250 J=1,4    
7450         P(I,J)=FAC*NPFS(I,J)    
7451   250   V(I,J)=0.   
7452         P(I,5)=FAC*K(I,5)   
7453   260   V(I,5)=0.   
7454         N=NKFFS 
7455         DO 270 J=1,5    
7456         K(N+1,J)=0  
7457         P(N+1,J)=0. 
7458   270   V(N+1,J)=0. 
7459         K(N+1,1)=32 
7460         K(N+1,2)=99 
7461         K(N+1,5)=NEVFS  
7462         P(N+1,1)=FAC*NPRFS  
7463         P(N+1,2)=FAC*NFIFS  
7464         P(N+1,3)=FAC*NCHFS  
7465         MSTU(3)=1   
7466     
7467 C...Reset factorial moments statistics. 
7468       ELSEIF(MTABU.EQ.30) THEN  
7469         NEVFM=0 
7470         NMUFM=0 
7471         DO 280 IM=1,3   
7472         DO 280 IB=1,10  
7473         DO 280 IP=1,4   
7474         FM1FM(IM,IB,IP)=0.  
7475   280   FM2FM(IM,IB,IP)=0.  
7476     
7477 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.  
7478       ELSEIF(MTABU.EQ.31) THEN  
7479         NEVFM=NEVFM+1   
7480         NLOW=N+MSTU(3)  
7481         NUPP=NLOW   
7482         DO 360 I=1,N    
7483         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360    
7484         IF(MSTU(41).GE.2) THEN  
7485           KC=LUCOMP(K(I,2)) 
7486           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.    
7487      &    KC.EQ.18) GOTO 360    
7488           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) 
7489      &    GOTO 360  
7490         ENDIF   
7491         PMR=0.  
7492         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)  
7493         IF(MSTU(42).GE.2) PMR=P(I,5)    
7494         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)    
7495         YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),    
7496      &  1E20)),P(I,3))  
7497         IF(ABS(YETA).GT.PARU(57)) GOTO 360  
7498         PHI=ULANGL(P(I,1),P(I,2))   
7499         IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))    
7500         IYETA=MAX(0,MIN(511,IYETA)) 
7501         IPHI=512.*(PHI+PARU(1))/PARU(2) 
7502         IPHI=MAX(0,MIN(511,IPHI))   
7503         IYEP=0  
7504         DO 290 IB=0,9   
7505   290   IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))    
7506     
7507 C...Order particles in (pseudo)rapidity and/or azimuth. 
7508         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN 
7509           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS') 
7510           RETURN    
7511         ENDIF   
7512         NUPP=NUPP+1 
7513         IF(NUPP.EQ.NLOW+1) THEN 
7514           K(NUPP,1)=IYETA   
7515           K(NUPP,2)=IPHI    
7516           K(NUPP,3)=IYEP    
7517         ELSE    
7518           DO 300 I1=NUPP-1,NLOW+1,-1    
7519           IF(IYETA.GE.K(I1,1)) GOTO 310 
7520   300     K(I1+1,1)=K(I1,1) 
7521   310     K(I1+1,1)=IYETA   
7522           DO 320 I1=NUPP-1,NLOW+1,-1    
7523           IF(IPHI.GE.K(I1,2)) GOTO 330  
7524   320     K(I1+1,2)=K(I1,2) 
7525   330     K(I1+1,2)=IPHI    
7526           DO 340 I1=NUPP-1,NLOW+1,-1    
7527           IF(IYEP.GE.K(I1,3)) GOTO 350  
7528   340     K(I1+1,3)=K(I1,3) 
7529   350     K(I1+1,3)=IYEP    
7530         ENDIF   
7531   360   CONTINUE    
7532         K(NUPP+1,1)=2**10   
7533         K(NUPP+1,2)=2**10   
7534         K(NUPP+1,3)=4**10   
7535     
7536 C...Calculate sum of factorial moments in event.    
7537         DO 400 IM=1,3   
7538         DO 370 IB=1,10  
7539         DO 370 IP=1,4   
7540   370   FEVFM(IB,IP)=0. 
7541         DO 380 IB=1,10  
7542         IF(IM.LE.2) IBIN=2**(10-IB) 
7543         IF(IM.EQ.3) IBIN=4**(10-IB) 
7544         IAGR=K(NLOW+1,IM)/IBIN  
7545         NAGR=1  
7546         DO 380 I=NLOW+2,NUPP+1  
7547         ICUT=K(I,IM)/IBIN   
7548         IF(ICUT.EQ.IAGR) THEN   
7549           NAGR=NAGR+1   
7550         ELSE    
7551           IF(NAGR.EQ.1) THEN    
7552           ELSEIF(NAGR.EQ.2) THEN    
7553             FEVFM(IB,1)=FEVFM(IB,1)+2.  
7554           ELSEIF(NAGR.EQ.3) THEN    
7555             FEVFM(IB,1)=FEVFM(IB,1)+6.  
7556             FEVFM(IB,2)=FEVFM(IB,2)+6.  
7557           ELSEIF(NAGR.EQ.4) THEN    
7558             FEVFM(IB,1)=FEVFM(IB,1)+12. 
7559             FEVFM(IB,2)=FEVFM(IB,2)+24. 
7560             FEVFM(IB,3)=FEVFM(IB,3)+24. 
7561           ELSE  
7562             FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)  
7563             FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)    
7564             FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)  
7565             FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)* 
7566      &      (NAGR-4.)   
7567           ENDIF 
7568           IAGR=ICUT 
7569           NAGR=1    
7570         ENDIF   
7571   380   CONTINUE    
7572     
7573 C...Add results to total statistics.    
7574         DO 390 IB=10,1,-1   
7575         DO 390 IP=1,4   
7576         IF(FEVFM(1,IP).LT.0.5) THEN 
7577           FEVFM(IB,IP)=0.   
7578         ELSEIF(IM.LE.2) THEN    
7579           FEVFM(IB,IP)=2**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)  
7580         ELSE    
7581           FEVFM(IB,IP)=4**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)  
7582         ENDIF   
7583         FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)    
7584   390   FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2 
7585   400   CONTINUE    
7586         NMUFM=NMUFM+(NUPP-NLOW) 
7587         MSTU(62)=NUPP-NLOW  
7588     
7589 C...Write accumulated statistics on factorial moments.  
7590       ELSEIF(MTABU.EQ.32) THEN  
7591         FAC=1./MAX(1,NEVFM) 
7592         IF(MSTU(42).LE.0) WRITE(MSTU(11),1400) NEVFM,'eta'  
7593         IF(MSTU(42).EQ.1) WRITE(MSTU(11),1400) NEVFM,'ypi'  
7594         IF(MSTU(42).GE.2) WRITE(MSTU(11),1400) NEVFM,'y  '  
7595         DO 420 IM=1,3   
7596         WRITE(MSTU(11),1500)    
7597         DO 420 IB=1,10  
7598         BYETA=2.*PARU(57)   
7599         IF(IM.NE.2) BYETA=BYETA/2**(IB-1)   
7600         BPHI=PARU(2)    
7601         IF(IM.NE.1) BPHI=BPHI/2**(IB-1) 
7602         IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))    
7603         IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))    
7604         DO 410 IP=1,4   
7605         FMOMA(IP)=FAC*FM1FM(IM,IB,IP)   
7606   410   FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))  
7607   420   WRITE(MSTU(11),1600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP), 
7608      &  IP=1,4) 
7609     
7610 C...Copy statistics on factorial moments into /LUJETS/. 
7611       ELSEIF(MTABU.EQ.33) THEN  
7612         FAC=1./MAX(1,NEVFM) 
7613         DO 430 IM=1,3   
7614         DO 430 IB=1,10  
7615         I=10*(IM-1)+IB  
7616         K(I,1)=32   
7617         K(I,2)=99   
7618         K(I,3)=1    
7619         IF(IM.NE.2) K(I,3)=2**(IB-1)    
7620         K(I,4)=1    
7621         IF(IM.NE.1) K(I,4)=2**(IB-1)    
7622         K(I,5)=0    
7623         P(I,1)=2.*PARU(57)/K(I,3)   
7624         V(I,1)=PARU(2)/K(I,4)   
7625         DO 430 IP=1,4   
7626         P(I,IP+1)=FAC*FM1FM(IM,IB,IP)   
7627   430   V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))  
7628         N=30    
7629         DO 440 J=1,5    
7630         K(N+1,J)=0  
7631         P(N+1,J)=0. 
7632   440   V(N+1,J)=0. 
7633         K(N+1,1)=32 
7634         K(N+1,2)=99 
7635         K(N+1,5)=NEVFM  
7636         MSTU(3)=1   
7637     
7638 C...Reset statistics on Energy-Energy Correlation.  
7639       ELSEIF(MTABU.EQ.40) THEN  
7640         NEVEE=0 
7641         DO 450 J=1,25   
7642         FE1EC(J)=0. 
7643         FE2EC(J)=0. 
7644         FE1EC(51-J)=0.  
7645         FE2EC(51-J)=0.  
7646         FE1EA(J)=0. 
7647   450   FE2EA(J)=0. 
7648     
7649 C...Find particles to include, with proper assumed mass.    
7650       ELSEIF(MTABU.EQ.41) THEN  
7651         NEVEE=NEVEE+1   
7652         NLOW=N+MSTU(3)  
7653         NUPP=NLOW   
7654         ECM=0.  
7655         DO 460 I=1,N    
7656         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 460    
7657         IF(MSTU(41).GE.2) THEN  
7658           KC=LUCOMP(K(I,2)) 
7659           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.    
7660      &    KC.EQ.18) GOTO 460    
7661           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) 
7662      &    GOTO 460  
7663         ENDIF   
7664         PMR=0.  
7665         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)  
7666         IF(MSTU(42).GE.2) PMR=P(I,5)    
7667         IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN 
7668           CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS') 
7669           RETURN    
7670         ENDIF   
7671         NUPP=NUPP+1 
7672         P(NUPP,1)=P(I,1)    
7673         P(NUPP,2)=P(I,2)    
7674         P(NUPP,3)=P(I,3)    
7675         P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)    
7676         P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))    
7677         ECM=ECM+P(NUPP,4)   
7678   460   CONTINUE    
7679         IF(NUPP.EQ.NLOW) RETURN 
7680     
7681 C...Analyze Energy-Energy Correlation in event. 
7682         FAC=(2./ECM**2)*50./PARU(1) 
7683         DO 470 J=1,50   
7684   470   FEVEE(J)=0. 
7685         DO 480 I1=NLOW+2,NUPP   
7686         DO 480 I2=NLOW+1,I1-1   
7687         CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ 
7688      &  (P(I1,5)*P(I2,5))   
7689         THE=ACOS(MAX(-1.,MIN(1.,CTHE))) 
7690         ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))  
7691   480   FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4) 
7692         DO 490 J=1,25   
7693         FE1EC(J)=FE1EC(J)+FEVEE(J)  
7694         FE2EC(J)=FE2EC(J)+FEVEE(J)**2   
7695         FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J) 
7696         FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2  
7697         FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))    
7698   490   FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2 
7699         MSTU(62)=NUPP-NLOW  
7700     
7701 C...Write statistics on Energy-Energy Correlation.  
7702       ELSEIF(MTABU.EQ.42) THEN  
7703         FAC=1./MAX(1,NEVEE) 
7704         WRITE(MSTU(11),1700) NEVEE  
7705         DO 500 J=1,25   
7706         FEEC1=FAC*FE1EC(J)  
7707         FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2))) 
7708         FEEC2=FAC*FE1EC(51-J)   
7709         FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))  
7710         FEECA=FAC*FE1EA(J)  
7711         FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2))) 
7712   500   WRITE(MSTU(11),1800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,   
7713      &  FEECA,FEESA 
7714     
7715 C...Copy statistics on Energy-Energy Correlation into /LUJETS/. 
7716       ELSEIF(MTABU.EQ.43) THEN  
7717         FAC=1./MAX(1,NEVEE) 
7718         DO 510 I=1,25   
7719         K(I,1)=32   
7720         K(I,2)=99   
7721         K(I,3)=0    
7722         K(I,4)=0    
7723         K(I,5)=0    
7724         P(I,1)=FAC*FE1EC(I) 
7725         V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))   
7726         P(I,2)=FAC*FE1EC(51-I)  
7727         V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))    
7728         P(I,3)=FAC*FE1EA(I) 
7729         V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))   
7730         P(I,4)=PARU(1)*(I-1)/50.    
7731         P(I,5)=PARU(1)*I/50.    
7732         V(I,4)=3.6*(I-1)    
7733   510   V(I,5)=3.6*I    
7734         N=25    
7735         DO 520 J=1,5    
7736         K(N+1,J)=0  
7737         P(N+1,J)=0. 
7738   520   V(N+1,J)=0. 
7739         K(N+1,1)=32 
7740         K(N+1,2)=99 
7741         K(N+1,5)=NEVEE  
7742         MSTU(3)=1   
7743     
7744 C...Reset statistics on decay channels. 
7745       ELSEIF(MTABU.EQ.50) THEN  
7746         NEVDC=0 
7747         NKFDC=0 
7748         NREDC=0 
7749     
7750 C...Identify and order flavour content of final state.  
7751       ELSEIF(MTABU.EQ.51) THEN  
7752         NEVDC=NEVDC+1   
7753         NDS=0   
7754         DO 550 I=1,N    
7755         IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 550 
7756         NDS=NDS+1   
7757         IF(NDS.GT.8) THEN   
7758           NREDC=NREDC+1 
7759           RETURN    
7760         ENDIF   
7761         KFM=2*IABS(K(I,2))  
7762         IF(K(I,2).LT.0) KFM=KFM-1   
7763         DO 530 IDS=NDS-1,1,-1   
7764         IIN=IDS+1   
7765         IF(KFM.LT.KFDM(IDS)) GOTO 540   
7766   530   KFDM(IDS+1)=KFDM(IDS)   
7767         IIN=1   
7768   540   KFDM(IIN)=KFM   
7769   550   CONTINUE    
7770     
7771 C...Find whether old or new final state.    
7772         DO 570 IDC=1,NKFDC  
7773         IF(NDS.LT.KFDC(IDC,0)) THEN 
7774           IKFDC=IDC 
7775           GOTO 580  
7776         ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN 
7777           DO 560 I=1,NDS    
7778           IF(KFDM(I).LT.KFDC(IDC,I)) THEN   
7779             IKFDC=IDC   
7780             GOTO 580    
7781           ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN   
7782             GOTO 570    
7783           ENDIF 
7784   560     CONTINUE  
7785           IKFDC=-IDC    
7786           GOTO 580  
7787         ENDIF   
7788   570   CONTINUE    
7789         IKFDC=NKFDC+1   
7790   580   IF(IKFDC.LT.0) THEN 
7791           IKFDC=-IKFDC  
7792         ELSEIF(NKFDC.GE.200) THEN   
7793           NREDC=NREDC+1 
7794           RETURN    
7795         ELSE    
7796           DO 590 IDC=NKFDC,IKFDC,-1 
7797           NPDC(IDC+1)=NPDC(IDC) 
7798           DO 590 I=0,8  
7799   590     KFDC(IDC+1,I)=KFDC(IDC,I) 
7800           NKFDC=NKFDC+1 
7801           KFDC(IKFDC,0)=NDS 
7802           DO 600 I=1,NDS    
7803   600     KFDC(IKFDC,I)=KFDM(I) 
7804           NPDC(IKFDC)=0 
7805         ENDIF   
7806         NPDC(IKFDC)=NPDC(IKFDC)+1   
7807     
7808 C...Write statistics on decay channels. 
7809       ELSEIF(MTABU.EQ.52) THEN  
7810         FAC=1./MAX(1,NEVDC) 
7811         WRITE(MSTU(11),1900) NEVDC  
7812         DO 620 IDC=1,NKFDC  
7813         DO 610 I=1,KFDC(IDC,0)  
7814         KFM=KFDC(IDC,I) 
7815         KF=(KFM+1)/2    
7816         IF(2*KF.NE.KFM) KF=-KF  
7817         CALL LUNAME(KF,CHAU)    
7818         CHDC(I)=CHAU(1:12)  
7819   610   IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'   
7820   620   WRITE(MSTU(11),2000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))    
7821         IF(NREDC.NE.0) WRITE(MSTU(11),2100) FAC*NREDC   
7822     
7823 C...Copy statistics on decay channels into /LUJETS/.    
7824       ELSEIF(MTABU.EQ.53) THEN  
7825         FAC=1./MAX(1,NEVDC) 
7826         DO 650 IDC=1,NKFDC  
7827         K(IDC,1)=32 
7828         K(IDC,2)=99 
7829         K(IDC,3)=0  
7830         K(IDC,4)=0  
7831         K(IDC,5)=KFDC(IDC,0)    
7832         DO 630 J=1,5    
7833         P(IDC,J)=0. 
7834   630   V(IDC,J)=0. 
7835         DO 640 I=1,KFDC(IDC,0)  
7836         KFM=KFDC(IDC,I) 
7837         KF=(KFM+1)/2    
7838         IF(2*KF.NE.KFM) KF=-KF  
7839         IF(I.LE.5) P(IDC,I)=KF  
7840   640   IF(I.GE.6) V(IDC,I-5)=KF    
7841   650   V(IDC,5)=FAC*NPDC(IDC)  
7842         N=NKFDC 
7843         DO 660 J=1,5    
7844         K(N+1,J)=0  
7845         P(N+1,J)=0. 
7846   660   V(N+1,J)=0. 
7847         K(N+1,1)=32 
7848         K(N+1,2)=99 
7849         K(N+1,5)=NEVDC  
7850         V(N+1,5)=FAC*NREDC  
7851         MSTU(3)=1   
7852       ENDIF 
7853     
7854 C...Format statements for output on unit MSTU(11) (default 6).  
7855  1000 FORMAT(///20X,'Event statistics - initial state'/ 
7856      &20X,'based on an analysis of ',I6,' events'// 
7857      &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',    
7858      &'according to fragmenting system multiplicity'/   
7859      &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',    
7860      &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)   
7861  1100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4) 
7862  1200 FORMAT(///20X,'Event statistics - final state'/   
7863      &20X,'based on an analysis of ',I6,' events'// 
7864      &5X,'Mean primary multiplicity =',F8.3/    
7865      &5X,'Mean final   multiplicity =',F8.3/    
7866      &5X,'Mean charged multiplicity =',F8.3//   
7867      &5X,'Number of particles produced per event (directly and via ',   
7868      &'decays/branchings)'/ 
7869      &5X,'KF    Particle/jet  MDCY',8X,'Particles',9X,'Antiparticles',  
7870      &5X,'Total'/34X,'prim      seco      prim      seco'/) 
7871  1300 FORMAT(1X,I6,4X,A16,I2,5(1X,F9.4))    
7872  1400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/   
7873      &20X,'based on an analysis of ',I6,' events'// 
7874      &3X,'delta-',A3,' delta-phi     <n>/bin',10X,'<F2>',18X,'<F3>',    
7875      &18X,'<F4>',18X,'<F5>'/35X,4('     value     error  '))    
7876  1500 FORMAT(10X)   
7877  1600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))    
7878  1700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/  
7879      &20X,'based on an analysis of ',I6,' events'// 
7880      &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,  
7881      &'EECA(theta)'/2X,'in degrees ',3('      value    error')/)    
7882  1800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))  
7883  1900 FORMAT(///20X,'Decay channel analysis - final state'/ 
7884      &20X,'based on an analysis of ',I6,' events'// 
7885      &2X,'Probability',10X,'Complete final state'/) 
7886  2000 FORMAT(2X,F9.5,5X,8(A12,1X))  
7887  2100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',  
7888      &'or table overflow)') 
7889     
7890       RETURN    
7891       END   
7892     
7893 C*********************************************************************  
7894     
7895       SUBROUTINE LUEEVT(KFL,ECM)    
7896     
7897 C...Purpose: to handle the generation of an e+e- annihilation jet event.    
7898       IMPLICIT DOUBLE PRECISION(D)  
7899       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
7900       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
7901       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
7902       SAVE 
7903     
7904 C...Check input parameters. 
7905       IF(MSTU(12).GE.1) CALL LULIST(0)  
7906       IF(KFL.LT.0.OR.KFL.GT.8) THEN 
7907         CALL LUERRM(16,'(LUEEVT:) called with unknown flavour code')    
7908         IF(MSTU(21).GE.1) RETURN    
7909       ENDIF 
7910       IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))   
7911       IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)    
7912       IF(ECM.LT.ECMMIN) THEN    
7913         CALL LUERRM(16,'(LUEEVT:) called with too small CM energy') 
7914         IF(MSTU(21).GE.1) RETURN    
7915       ENDIF 
7916     
7917 C...Check consistency of MSTJ options set.  
7918       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN    
7919         CALL LUERRM(6,  
7920      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1') 
7921         MSTJ(110)=1 
7922       ENDIF 
7923       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN    
7924         CALL LUERRM(6,  
7925      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0') 
7926         MSTJ(111)=0 
7927       ENDIF 
7928     
7929 C...Initialize alpha_strong and total cross-section.    
7930       MSTU(111)=MSTJ(108)   
7931       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) 
7932      &MSTU(111)=1   
7933       PARU(112)=PARJ(121)   
7934       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)    
7935       IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.   
7936      &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LUXTOT(KFL,ECM, 
7937      &XTOT) 
7938       IF(MSTJ(116).GE.3) MSTJ(116)=1    
7939     
7940 C...Add initial e+e- to event record (documentation only).  
7941       NTRY=0    
7942   100 NTRY=NTRY+1   
7943       IF(NTRY.GT.100) THEN  
7944         CALL LUERRM(14,'(LUEEVT:) caught in an infinite loop')  
7945         RETURN  
7946       ENDIF 
7947       NC=0  
7948       IF(MSTJ(115).GE.2) THEN   
7949         NC=NC+2 
7950         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)  
7951         K(NC-1,1)=21    
7952         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)  
7953         K(NC,1)=21  
7954       ENDIF 
7955     
7956 C...Radiative photon (in initial state).    
7957       MK=0  
7958       ECMC=ECM  
7959       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LURADK(ECM,MK,PAK, 
7960      &THEK,PHIK,ALPK)   
7961       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))   
7962       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN   
7963         NC=NC+1 
7964         CALL LU1ENT(NC,22,PAK,THEK,PHIK)    
7965         K(NC,3)=MIN(MSTJ(115)/2,1)  
7966       ENDIF 
7967     
7968 C...Virtual exchange boson (gamma or Z0).   
7969       IF(MSTJ(115).GE.3) THEN   
7970         NC=NC+1 
7971         KF=22   
7972         IF(MSTJ(102).EQ.2) KF=23    
7973         MSTU10=MSTU(10) 
7974         MSTU(10)=1  
7975         P(NC,5)=ECMC    
7976         CALL LU1ENT(NC,KF,ECMC,0.,0.)   
7977         K(NC,1)=21  
7978         K(NC,3)=1   
7979         MSTU(10)=MSTU10 
7980       ENDIF 
7981     
7982 C...Choice of flavour and jet configuration.    
7983       CALL LUXKFL(KFL,ECM,ECMC,KFLC)    
7984       IF(KFLC.EQ.0) GOTO 100    
7985       CALL LUXJET(ECMC,NJET,CUT)    
7986       KFLN=21   
7987       IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,   
7988      &X12,X14)  
7989       IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,KFLC,ECMC,X1,X3)   
7990       IF(NJET.EQ.2) MSTJ(120)=1 
7991     
7992 C...Fill jet configuration and origin.  
7993       IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LU2ENT(NC+1,KFLC,-KFLC,ECMC)    
7994       IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LU2ENT(-(NC+1),KFLC,-KFLC,  
7995      &ECMC) 
7996       IF(NJET.EQ.3) CALL LU3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)  
7997       IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LU4ENT(NC+1,KFLC,KFLN,KFLN, 
7998      &-KFLC,ECMC,X1,X2,X4,X12,X14)  
7999       IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LU4ENT(NC+1,KFLC,-KFLN,KFLN,    
8000      &-KFLC,ECMC,X1,X2,X4,X12,X14)  
8001       DO 110 IP=NC+1,N  
8002   110 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)   
8003     
8004 C...Angular orientation according to matrix element.    
8005       IF(MSTJ(106).EQ.1) THEN   
8006         CALL LUXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)  
8007         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)  
8008         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0) 
8009       ENDIF 
8010     
8011 C...Rotation and boost from radiative photon.   
8012       IF(MK.EQ.1) THEN  
8013         DBEK=-PAK/(ECM-PAK) 
8014         NMIN=NC+1-MSTJ(115)/3   
8015         CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)    
8016         CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))   
8017         CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0) 
8018       ENDIF 
8019     
8020 C...Generate parton shower. Rearrange along strings and check.  
8021       IF(MSTJ(101).EQ.5) THEN   
8022         CALL LUSHOW(N-1,N,ECMC) 
8023         MSTJ14=MSTJ(14) 
8024         IF(MSTJ(105).EQ.-1) MSTJ(14)=0  
8025         IF(MSTJ(105).GE.0) MSTU(28)=0   
8026         CALL LUPREP(0)  
8027         MSTJ(14)=MSTJ14 
8028         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100   
8029       ENDIF 
8030     
8031 C...Fragmentation/decay generation. Information for LUTABU. 
8032       IF(MSTJ(105).EQ.1) CALL LUEXEC    
8033       MSTU(161)=KFLC    
8034       MSTU(162)=-KFLC   
8035     
8036       RETURN    
8037       END   
8038     
8039 C*********************************************************************  
8040     
8041       SUBROUTINE LUXTOT(KFL,ECM,XTOT)   
8042     
8043 C...Purpose: to calculate total cross-section, including initial    
8044 C...state radiation effects.    
8045       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8046       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
8047       SAVE 
8048     
8049 C...Status, (optimized) Q^2 scale, alpha_strong.    
8050       PARJ(151)=ECM 
8051       MSTJ(119)=10*MSTJ(102)+KFL    
8052       IF(MSTJ(111).EQ.0) THEN   
8053         Q2R=ECM**2  
8054       ELSEIF(MSTU(111).EQ.0) THEN   
8055         PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/    
8056      &  ((33.-2.*MSTU(112))*PARU(111)))))   
8057         Q2R=PARJ(168)*ECM**2    
8058       ELSE  
8059         PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,   
8060      &  (2.*PARU(112)/ECM)**2)) 
8061         Q2R=PARJ(168)*ECM**2    
8062       ENDIF 
8063       ALSPI=ULALPS(Q2R)/PARU(1) 
8064     
8065 C...QCD corrections factor in R.    
8066       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN 
8067         RQCD=1. 
8068       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN  
8069         RQCD=1.+ALSPI   
8070       ELSEIF(MSTJ(109).EQ.0) THEN   
8071         RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2  
8072         IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.* 
8073      &  LOG(PARJ(168))*ALSPI**2)    
8074       ELSEIF(IABS(MSTJ(101)).EQ.1) THEN 
8075         RQCD=1.+(3./4.)*ALSPI   
8076       ELSE  
8077         RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2 
8078       ENDIF 
8079     
8080 C...Calculate Z0 width if default value not acceptable. 
8081       IF(MSTJ(102).GE.3) THEN   
8082         RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/  
8083      &  3.)**2+(4.*PARU(102)/3.-1.)**2) 
8084         DO 100 KFLC=5,6 
8085         VQ=1.   
8086         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*ULMASS(KFLC)/   
8087      &  ECM)**2))   
8088         IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1. 
8089         IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3. 
8090   100   RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3) 
8091         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))    
8092       ENDIF 
8093     
8094 C...Calculate propagator and related constants for QFD case.    
8095       POLL=1.-PARJ(131)*PARJ(132)   
8096       IF(MSTJ(102).GE.2) THEN   
8097         SFF=1./(16.*PARU(102)*(1.-PARU(102)))   
8098         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)  
8099         SFI=SFW*(1.-(PARJ(123)/ECM)**2) 
8100         VE=4.*PARU(102)-1.  
8101         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))  
8102         SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))   
8103         HF1I=SFI*SF1I   
8104         HF1W=SFW*SF1W   
8105       ENDIF 
8106     
8107 C...Loop over different flavours: charge, velocity. 
8108       RTOT=0.   
8109       RQQ=0.    
8110       RQV=0.    
8111       RVA=0.    
8112       DO 110 KFLC=1,MAX(MSTJ(104),KFL)  
8113       IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110 
8114       MSTJ(93)=1    
8115       PMQ=ULMASS(KFLC)  
8116       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110  
8117       QF=KCHG(KFLC,1)/3.    
8118       VQ=1. 
8119       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2) 
8120     
8121 C...Calculate R and sum of charges for QED or QFD case. 
8122       RQQ=RQQ+3.*QF**2*POLL 
8123       IF(MSTJ(102).LE.1) THEN   
8124         RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL   
8125       ELSE  
8126         VF=SIGN(1.,QF)-4.*QF*PARU(102)  
8127         RQV=RQV-6.*QF*VF*SF1I   
8128         RVA=RVA+3.*(VF**2+1.)*SF1W  
8129         RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+  
8130      &  VF**2*HF1W)+VQ**3*HF1W) 
8131       ENDIF 
8132   110 CONTINUE  
8133       RSUM=RQQ  
8134       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA   
8135     
8136 C...Calculate cross-section, including QCD corrections. 
8137       PARJ(141)=RQQ 
8138       PARJ(142)=RTOT    
8139       PARJ(143)=RTOT*RQCD   
8140       PARJ(144)=PARJ(143)   
8141       PARJ(145)=PARJ(141)*86.8/ECM**2   
8142       PARJ(146)=PARJ(142)*86.8/ECM**2   
8143       PARJ(147)=PARJ(143)*86.8/ECM**2   
8144       PARJ(148)=PARJ(147)   
8145       PARJ(157)=RSUM*RQCD   
8146       PARJ(158)=0.  
8147       PARJ(159)=0.  
8148       XTOT=PARJ(147)    
8149       IF(MSTJ(107).LE.0) RETURN 
8150     
8151 C...Virtual cross-section.  
8152       XKL=PARJ(135) 
8153       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)   
8154       ALE=2.*LOG(ECM/ULMASS(11))-1. 
8155       SIGV=ALE/3.+2.*LOG(ECM**2/(ULMASS(13)*ULMASS(15)))/3.-4./3.+  
8156      &1.526*LOG(ECM**2/0.932)   
8157     
8158 C...Soft and hard radiative cross-section in QED case.  
8159       IF(MSTJ(102).LE.1) THEN   
8160         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV  
8161         SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)  
8162         SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL)) 
8163     
8164 C...Soft and hard radiative cross-section in QFD case.  
8165       ELSE  
8166         SZM=1.-(PARJ(123)/ECM)**2   
8167         SZW=PARJ(123)*PARJ(124)/ECM**2  
8168         PARJ(161)=-RQQ/RSUM 
8169         PARJ(162)=-(RQQ+RQV+RVA)/RSUM   
8170         PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM 
8171         PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM- 
8172      &  SZM**2))/(SZW*RSUM) 
8173         SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+    
8174      &  (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.   
8175         SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+  
8176      &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+   
8177      &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW))) 
8178         SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+ 
8179      &  PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/    
8180      &  ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-  
8181      &  ATAN((XKL-SZM)/SZW)))   
8182       ENDIF 
8183     
8184 C...Total cross-section and fraction of hard photon events. 
8185       PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH) 
8186       PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD 
8187       PARJ(144)=PARJ(157)   
8188       PARJ(148)=PARJ(144)*86.8/ECM**2   
8189       XTOT=PARJ(148)    
8190     
8191       RETURN    
8192       END   
8193     
8194 C*********************************************************************  
8195     
8196       SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK)  
8197     
8198 C...Purpose: to generate initial state photon radiation.    
8199       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8200       SAVE 
8201     
8202 C...Function: cumulative hard photon spectrum in QFD case.  
8203       FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+ 
8204      &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)    
8205     
8206 C...Determine whether radiative photon or not.  
8207       MK=0  
8208       PAK=0.    
8209       IF(PARJ(160).LT.RLU(0)) RETURN    
8210       MK=1  
8211     
8212 C...Photon energy range. Find photon momentum in QED case.  
8213       XKL=PARJ(135) 
8214       XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)   
8215       IF(MSTJ(102).LE.1) THEN   
8216   100   XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLU(0))    
8217         IF(1.+(1.-XK)**2.LT.2.*RLU(0)) GOTO 100 
8218     
8219 C...Ditto in QFD case, by numerical inversion of integrated spectrum.   
8220       ELSE  
8221         SZM=1.-(PARJ(123)/ECM)**2   
8222         SZW=PARJ(123)*PARJ(124)/ECM**2  
8223         FXKL=FXK(XKL)   
8224         FXKU=FXK(XKU)   
8225         FXKD=1E-4*(FXKU-FXKL)   
8226         FXKR=FXKL+RLU(0)*(FXKU-FXKL)    
8227         NXK=0   
8228   110   NXK=NXK+1   
8229         XK=0.5*(XKL+XKU)    
8230         FXKV=FXK(XK)    
8231         IF(FXKV.GT.FXKR) THEN   
8232           XKU=XK    
8233           FXKU=FXKV 
8234         ELSE    
8235           XKL=XK    
8236           FXKL=FXKV 
8237         ENDIF   
8238         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110    
8239         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)    
8240       ENDIF 
8241       PAK=0.5*ECM*XK    
8242     
8243 C...Photon polar and azimuthal angle.   
8244       PME=2.*(ULMASS(11)/ECM)**2    
8245   120 CTHM=PME*(2./PME)**RLU(0) 
8246       IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,   
8247      &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLU(0)) GOTO 120  
8248       CTHE=1.-CTHM  
8249       IF(RLU(0).GT.0.5) CTHE=-CTHE  
8250       STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))   
8251       THEK=ULANGL(CTHE,STHE)    
8252       PHIK=PARU(2)*RLU(0)   
8253     
8254 C...Rotation angle for hadronic system. 
8255       SGN=1.    
8256       IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT. 
8257      &RLU(0)) SGN=-1.   
8258       ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/  
8259      &(2.-XK*(1.-SGN*CTHE)))    
8260     
8261       RETURN    
8262       END   
8263     
8264 C*********************************************************************  
8265     
8266       SUBROUTINE LUXKFL(KFL,ECM,ECMC,KFLC)  
8267     
8268 C...Purpose: to select flavour for produced qqbar pair. 
8269       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8270       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
8271       SAVE 
8272     
8273 C...Calculate maximum weight in QED or QFD case.    
8274       IF(MSTJ(102).LE.1) THEN   
8275         RFMAX=4./9. 
8276       ELSE  
8277         POLL=1.-PARJ(131)*PARJ(132) 
8278         SFF=1./(16.*PARU(102)*(1.-PARU(102)))   
8279         SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)    
8280         SFI=SFW*(1.-(PARJ(123)/ECMC)**2)    
8281         VE=4.*PARU(102)-1.  
8282         HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))  
8283         HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))   
8284         RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+   
8285      &  ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.* 
8286      &  (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)  
8287       ENDIF 
8288     
8289 C...Choose flavour. Gives charge and velocity.  
8290       NTRY=0    
8291   100 NTRY=NTRY+1   
8292       IF(NTRY.GT.100) THEN  
8293         CALL LUERRM(14,'(LUXKFL:) caught in an infinite loop')  
8294         KFLC=0  
8295         RETURN  
8296       ENDIF 
8297       KFLC=KFL  
8298       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLU(0)) 
8299       MSTJ(93)=1    
8300       PMQ=ULMASS(KFLC)  
8301       IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100  
8302       QF=KCHG(KFLC,1)/3.    
8303       VQ=1. 
8304       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))    
8305     
8306 C...Calculate weight in QED or QFD case.    
8307       IF(MSTJ(102).LE.1) THEN   
8308         RF=QF**2    
8309         RFV=0.5*VQ*(3.-VQ**2)*QF**2 
8310       ELSE  
8311         VF=SIGN(1.,QF)-4.*QF*PARU(102)  
8312         RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W 
8313         RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+    
8314      &  VQ**3*HF1W  
8315       ENDIF 
8316     
8317 C...Weighting or new event (radiative photon). Cross-section update.    
8318       IF(KFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100  
8319       PARJ(158)=PARJ(158)+1.    
8320       IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLU(0)*RF) KFLC=0   
8321       IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100 
8322       IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.  
8323       PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)   
8324       PARJ(148)=PARJ(144)*86.8/ECM**2   
8325     
8326       RETURN    
8327       END   
8328     
8329 C*********************************************************************  
8330     
8331       SUBROUTINE LUXJET(ECM,NJET,CUT)   
8332     
8333 C...Purpose: to select number of jets in matrix element approach.   
8334       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8335       DIMENSION ZHUT(5) 
8336       SAVE
8337 
8338 C...Relative three-jet rate in Zhu second order parametrization.    
8339       DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/ 
8340     
8341 C...Trivial result for two-jets only, including parton shower.  
8342       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN 
8343         CUT=0.  
8344     
8345 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.    
8346       ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN 
8347         CF=4./3.    
8348         IF(MSTJ(109).EQ.2) CF=1.    
8349         IF(MSTJ(111).EQ.0) THEN 
8350           Q2=ECM**2 
8351           Q2R=ECM**2    
8352         ELSEIF(MSTU(111).EQ.0) THEN 
8353           PARJ(169)=MIN(1.,PARJ(129))   
8354           Q2=PARJ(169)*ECM**2   
8355           PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/  
8356      &    ((33.-2.*MSTU(112))*PARU(111))))) 
8357           Q2R=PARJ(168)*ECM**2  
8358         ELSE    
8359           PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))    
8360           Q2=PARJ(169)*ECM**2   
8361           PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM, 
8362      &    (2.*PARU(112)/ECM)**2))   
8363           Q2R=PARJ(168)*ECM**2  
8364         ENDIF   
8365     
8366 C...alpha_strong for R and R itself.    
8367         ALSPI=(3./4.)*CF*ULALPS(Q2R)/PARU(1)    
8368         IF(IABS(MSTJ(101)).EQ.1) THEN   
8369           RQCD=1.+ALSPI 
8370         ELSEIF(MSTJ(109).EQ.0) THEN 
8371           RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2    
8372           IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*   
8373      &    LOG(PARJ(168))*ALSPI**2)  
8374         ELSE    
8375           RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2   
8376         ENDIF   
8377     
8378 C...alpha_strong for jet rate. Initial value for y cut. 
8379         ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1) 
8380         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2) 
8381         IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0)) 
8382      &  CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)  
8383         IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))  
8384     
8385 C...Parametrization of first order three-jet cross-section. 
8386   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN  
8387           PARJ(152)=0.  
8388         ELSE    
8389           PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))* 
8390      &    LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+ 
8391      &    5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+    
8392      &    1.342*(1.-3.*CUT)**4)/RQCD    
8393           IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))    
8394      &    PARJ(152)=0.  
8395         ENDIF   
8396     
8397 C...Parametrization of second order three-jet cross-section.    
8398         IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR. 
8399      &  CUT.GE.0.25) THEN   
8400           PARJ(153)=0.  
8401         ELSEIF(MSTJ(110).LE.1) THEN 
8402           CT=LOG(1./CUT-2.) 
8403           PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-   
8404      &    0.2661*CT**3+0.01159*CT**4)/RQCD  
8405     
8406 C...Interpolation in second/first order ratio for Zhu parametrization.  
8407         ELSEIF(MSTJ(110).EQ.2) THEN 
8408           IZA=0 
8409           DO 110 IY=1,5 
8410   110     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY 
8411           IF(IZA.NE.0) THEN 
8412             ZHURAT=ZHUT(IZA)    
8413           ELSE  
8414             IZ=100.*CUT 
8415             ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ)) 
8416           ENDIF 
8417           PARJ(153)=ALSPI*PARJ(152)*ZHURAT  
8418         ENDIF   
8419     
8420 C...Shift in second order three-jet cross-section with optimized Q^2.   
8421         IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.  
8422      &  AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*    
8423      &  LOG(PARJ(169))*ALSPI*PARJ(152)  
8424     
8425 C...Parametrization of second order four-jet cross-section. 
8426         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN   
8427           PARJ(154)=0.  
8428         ELSE    
8429           CT=LOG(1./CUT-5.) 
8430           IF(CUT.LE.0.018) THEN 
8431             XQQGG=6.349-4.330*CT+0.8304*CT**2   
8432             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+    
8433      &      0.4059*CT**2)   
8434             XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)  
8435             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ   
8436           ELSE  
8437             XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3 
8438             IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-    
8439      &      0.1326*CT**2+0.04365*CT**3) 
8440             XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*   
8441      &      CT**3)  
8442             IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ   
8443           ENDIF 
8444           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD   
8445           PARJ(155)=XQQQQ/(XQQGG+XQQQQ) 
8446         ENDIF   
8447     
8448 C...If negative three-jet rate, change y' optimization parameter.   
8449         IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.    
8450      &  PARJ(169).LT.0.99) THEN 
8451           PARJ(169)=MIN(1.,1.2*PARJ(169))   
8452           Q2=PARJ(169)*ECM**2   
8453           ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)   
8454           GOTO 100  
8455         ENDIF   
8456     
8457 C...If too high cross-section, use harder cuts, or fail.    
8458         IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN 
8459           IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.   
8460      &    PARJ(169).LT.0.99) THEN   
8461             PARJ(169)=MIN(1.,1.2*PARJ(169)) 
8462             Q2=PARJ(169)*ECM**2 
8463             ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1) 
8464             GOTO 100    
8465           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN 
8466             CALL LUERRM(26, 
8467      &      '(LUXJET:) no allowed y cut value for Zhu parametrization') 
8468           ENDIF 
8469           CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)  
8470           IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))    
8471           GOTO 100  
8472         ENDIF   
8473     
8474 C...Scalar gluon (first order only).    
8475       ELSE  
8476         ALSPI=ULALPS(ECM**2)/PARU(1)    
8477         CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))  
8478         PARJ(152)=0.    
8479         IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*  
8480      &  LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))    
8481         PARJ(153)=0.    
8482         PARJ(154)=0.    
8483       ENDIF 
8484     
8485 C...Select number of jets.  
8486       PARJ(150)=CUT 
8487       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN 
8488         NJET=2  
8489       ELSEIF(MSTJ(101).LE.0) THEN   
8490         NJET=MIN(4,2-MSTJ(101)) 
8491       ELSE  
8492         RNJ=RLU(0)  
8493         NJET=2  
8494         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3 
8495         IF(PARJ(154).GT.RNJ) NJET=4 
8496       ENDIF 
8497     
8498       RETURN    
8499       END   
8500     
8501 C*********************************************************************  
8502     
8503       SUBROUTINE LUX3JT(NJET,CUT,KFL,ECM,X1,X2) 
8504     
8505 C...Purpose: to select the kinematical variables of three-jet events.   
8506       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8507       DIMENSION ZHUP(5,12)  
8508       SAVE
8509 
8510 C...Coefficients of Zhu second order parametrization.   
8511       DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/  
8512      &    18.29,    89.56,    4.541,   -52.09,   -109.8,    24.90,  
8513      &    11.63,    3.683,    17.50, 0.002440,   -1.362,  -0.3537,  
8514      &    11.42,    6.299,   -22.55,   -8.915,    59.25,   -5.855,  
8515      &   -32.85,   -1.054,   -16.90, 0.006489,  -0.8156,  0.01095,  
8516      &    7.847,   -3.964,   -35.83,    1.178,    29.39,   0.2806,  
8517      &    47.82,   -12.36,   -56.72,  0.04054,  -0.4365,   0.6062,  
8518      &    5.441,   -56.89,   -50.27,    15.13,    114.3,   -18.19,  
8519      &    97.05,   -1.890,   -139.9,  0.08153,  -0.4984,   0.9439,  
8520      &   -17.65,    51.44,   -58.32,    70.95,   -255.7,   -78.99,  
8521      &    476.9,    29.65,   -239.3,   0.4745,   -1.174,    6.081/  
8522     
8523 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).  
8524       DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.    
8525     
8526 C...Event type. Mass effect factors and other common constants. 
8527       MSTJ(120)=2   
8528       MSTJ(121)=0   
8529       PMQ=ULMASS(KFL)   
8530       QME=(2.*PMQ/ECM)**2   
8531       IF(MSTJ(109).NE.1) THEN   
8532         CUTL=LOG(CUT)   
8533         CUTD=LOG(1./CUT-2.) 
8534         IF(MSTJ(109).EQ.0) THEN 
8535           CF=4./3.  
8536           CN=3. 
8537           TR=2. 
8538           WTMX=MIN(20.,37.-6.*CUTD) 
8539           IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)  
8540         ELSE    
8541           CF=1. 
8542           CN=0. 
8543           TR=12.    
8544           WTMX=0.   
8545         ENDIF   
8546     
8547 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.    
8548         ALS2PI=PARU(118)/PARU(2)    
8549         WTOPT=0.    
8550         IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*  
8551      &  ALS2PI  
8552         WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)  
8553     
8554 C...Choose three-jet events in allowed region.  
8555   100   NJET=3  
8556   110   Y13L=CUTL+CUTD*RLU(0)   
8557         Y23L=CUTL+CUTD*RLU(0)   
8558         Y13=EXP(Y13L)   
8559         Y23=EXP(Y23L)   
8560         Y12=1.-Y13-Y23  
8561         IF(Y12.LE.CUT) GOTO 110 
8562         IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLU(0)) GOTO 110  
8563     
8564 C...Second order corrections.   
8565         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN  
8566           Y12L=LOG(Y12) 
8567           Y13M=LOG(1.-Y13)  
8568           Y23M=LOG(1.-Y23)  
8569           Y12M=LOG(1.-Y12)  
8570           IF(Y13.LE.0.5) Y13I=DILOG(Y13)    
8571           IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)  
8572           IF(Y23.LE.0.5) Y23I=DILOG(Y23)    
8573           IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)  
8574           IF(Y12.LE.0.5) Y12I=DILOG(Y12)    
8575           IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)  
8576           WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)  
8577           WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+   
8578      &    2.*(2.*CUTL-Y12L)*CUT/Y12)+   
8579      &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+ 
8580      &    67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*   
8581      &    CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+  
8582      &    TR*(2.*CUTL/3.-10./9.)+   
8583      &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+  
8584      &    Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+  
8585      &    Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/ 
8586      &    WT1+  
8587      &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+   
8588      &    (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*  
8589      &    Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)* 
8590      &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/   
8591      &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-    
8592      &    2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-   
8593      &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I) 
8594           IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1 
8595           IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110  
8596           PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)    
8597     
8598         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN  
8599 C...Second order corrections; Zhu parametrization of ERT.   
8600           ZX=(Y23-Y13)**2   
8601           ZY=1.-Y12 
8602           IZA=0 
8603           DO 120 IY=1,5 
8604   120     IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY 
8605           IF(IZA.NE.0) THEN 
8606             IZ=IZA  
8607             WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+  
8608      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ 
8609      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+    
8610      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY  
8611           ELSE  
8612             IZ=100.*CUT 
8613             WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+  
8614      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ 
8615      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+    
8616      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY  
8617             IZ=IZ+1 
8618             WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+  
8619      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ 
8620      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+    
8621      &      ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY  
8622             WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)  
8623           ENDIF 
8624           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1  
8625           IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110   
8626           PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)  
8627         ENDIF   
8628     
8629 C...Impose mass cuts (gives two jets). For fixed jet number new try.    
8630         X1=1.-Y23   
8631         X2=1.-Y13   
8632         X3=1.-Y12   
8633         IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2  
8634         IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+   
8635      &  0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+  
8636      &  (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLU(0)) NJET=2    
8637         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100  
8638     
8639 C...Scalar gluon model (first order only, no mass effects). 
8640       ELSE  
8641   130   NJET=3  
8642   140   Y12=SQRT(4.*CUT**2+RLU(0)*((1.-CUT)**2-4.*CUT**2))  
8643         IF(LOG((Y12-CUT)/CUT).LE.RLU(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140  
8644         YD=SIGN(2.*CUT*((Y12-CUT)/CUT)**RLU(0)-Y12,RLU(0)-0.5)  
8645         X1=1.-0.5*(Y12+YD)  
8646         X2=1.-0.5*(Y12-YD)  
8647         IF(4.*(1.-X1)*(1.-X2)*Y12/(1.-Y12)**2.LE.QME) NJET=2    
8648         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130  
8649       ENDIF 
8650     
8651       RETURN    
8652       END   
8653     
8654 C*********************************************************************  
8655     
8656       SUBROUTINE LUX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14) 
8657     
8658 C...Purpose: to select the kinematical variables of four-jet events.    
8659       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8660       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)  
8661       SAVE
8662 
8663 C...Common constants. Colour factors for QCD and Abelian gluon theory.  
8664       PMQ=ULMASS(KFL)   
8665       QME=(2.*PMQ/ECM)**2   
8666       CT=LOG(1./CUT-5.) 
8667       IF(MSTJ(109).EQ.0) THEN   
8668         CF=4./3.    
8669         CN=3.   
8670         TR=2.   
8671       ELSE  
8672         CF=1.   
8673         CN=0.   
8674         TR=12.  
8675       ENDIF 
8676     
8677 C...Choice of process (qqbargg or qqbarqqbar).  
8678   100 NJET=4    
8679       IT=1  
8680       IF(PARJ(155).GT.RLU(0)) IT=2  
8681       IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2   
8682       IF(IT.EQ.1) WTMX=0.7/CUT**2   
8683       IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2    
8684       IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2  
8685       ID=1  
8686     
8687 C...Sample the five kinematical variables (for qqgg preweighted in y34).    
8688   110 Y134=3.*CUT+(1.-6.*CUT)*RLU(0)    
8689       Y234=3.*CUT+(1.-6.*CUT)*RLU(0)    
8690       IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLU(0))   
8691       IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLU(0)    
8692       IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110  
8693       VT=RLU(0) 
8694       CP=COS(PARU(1)*RLU(0))    
8695       Y14=(Y134-Y34)*VT 
8696       Y13=Y134-Y14-Y34  
8697       VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34)) 
8698       Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*    
8699      &CP-(1.-2.*VT)*(1.-2.*VB)) 
8700       Y23=Y234-Y34-Y24  
8701       Y12=1.-Y134-Y23-Y24   
8702       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110  
8703       Y123=Y12+Y13+Y23  
8704       Y124=Y12+Y14+Y24  
8705     
8706 C...Calculate matrix elements for qqgg or qqqq process. 
8707       IC=0  
8708       WTTOT=0.  
8709   120 IC=IC+1   
8710       IF(IT.EQ.1) THEN  
8711         WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+ 
8712      &  3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-    
8713      &  Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12* 
8714      &  Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+   
8715      &  2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*  
8716      &  Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*  
8717      &  Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)    
8718         WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12* 
8719      &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*   
8720      &  Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+ 
8721      &  Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)  
8722         WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*   
8723      &  Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+    
8724      &  Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-  
8725      &  Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/  
8726      &  (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24* 
8727      &  Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*    
8728      &  Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*    
8729      &  Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+  
8730      &  2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-   
8731      &  2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)   
8732         WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+  
8733      &  4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34- 
8734      &  Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+    
8735      &  4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+  
8736      &  2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*  
8737      &  Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)- 
8738      &  (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*  
8739      &  Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-    
8740      &  4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/    
8741      &  (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34- 
8742      &  2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-    
8743      &  2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-  
8744      &  Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)   
8745         WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/ 
8746      &  8.  
8747       ELSE  
8748         WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12* 
8749      &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*    
8750      &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*   
8751      &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*  
8752      &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+ 
8753      &  Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+  
8754      &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*  
8755      &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24- 
8756      &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)   
8757         WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*  
8758      &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23* 
8759      &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*  
8760      &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+   
8761      &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+  
8762      &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*    
8763      &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*   
8764      &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)    
8765         WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16. 
8766       ENDIF 
8767     
8768 C...Permutations of momenta in matrix element. Weighting.   
8769   130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN 
8770         YSAV=Y13    
8771         Y13=Y14 
8772         Y14=YSAV    
8773         YSAV=Y23    
8774         Y23=Y24 
8775         Y24=YSAV    
8776         YSAV=Y123   
8777         Y123=Y124   
8778         Y124=YSAV   
8779       ENDIF 
8780       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN 
8781         YSAV=Y13    
8782         Y13=Y23 
8783         Y23=YSAV    
8784         YSAV=Y14    
8785         Y14=Y24 
8786         Y24=YSAV    
8787         YSAV=Y134   
8788         Y134=Y234   
8789         Y234=YSAV   
8790       ENDIF 
8791       IF(IC.LE.3) GOTO 120  
8792       IF(ID.EQ.1.AND.WTTOT.LT.RLU(0)*WTMX) GOTO 110 
8793       IC=5  
8794     
8795 C...qqgg events: string configuration and event type.   
8796       IF(IT.EQ.1) THEN  
8797         IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN 
8798           PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+   
8799      &    WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT) 
8800           IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLU(0)*(WTA(1)+WTA(2)+ 
8801      &    WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2 
8802           IF(ID.EQ.2) GOTO 130  
8803         ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN 
8804           PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)    
8805           IF(WTA(2)+WTA(4).GT.RLU(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2    
8806           IF(ID.EQ.2) GOTO 130  
8807         ENDIF   
8808         MSTJ(120)=3 
8809         IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT. 
8810      &  RLU(0)*WTTOT) MSTJ(120)=4   
8811         KFLN=21 
8812     
8813 C...Mass cuts. Kinematical variables out.   
8814         IF(Y12.LE.CUT+QME) NJET=2   
8815         IF(NJET.EQ.2) GOTO 150  
8816         Q12=0.5*(1.-SQRT(1.-QME/Y12))   
8817         X1=1.-(1.-Q12)*Y234-Q12*Y134    
8818         X4=1.-(1.-Q12)*Y134-Q12*Y234    
8819         X2=1.-Y124  
8820         X12=(1.-Q12)*Y13+Q12*Y23    
8821         X14=Y12-0.5*QME 
8822         IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2    
8823     
8824 C...qqbarqqbar events: string configuration, choose new flavour.    
8825       ELSE  
8826         IF(ID.EQ.1) THEN    
8827           WTR=RLU(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))  
8828           IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2  
8829           IF(WTR.LT.WTD(3)+WTD(4)) ID=3 
8830           IF(WTR.LT.WTD(4)) ID=4    
8831           IF(ID.GE.2) GOTO 130  
8832         ENDIF   
8833         MSTJ(120)=5 
8834         PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)   
8835   140   KFLN=1+INT(5.*RLU(0))   
8836         IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLU(0)) GOTO 140    
8837         IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLU(0)) GOTO 140 
8838         IF(KFLN.GT.MSTJ(104)) NJET=2    
8839         PMQN=ULMASS(KFLN)   
8840         QMEN=(2.*PMQN/ECM)**2   
8841     
8842 C...Mass cuts. Kinematical variables out.   
8843         IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2    
8844         IF(NJET.EQ.2) GOTO 150  
8845         Q24=0.5*(1.-SQRT(1.-QME/Y24))   
8846         Q13=0.5*(1.-SQRT(1.-QMEN/Y13))  
8847         X1=1.-(1.-Q24)*Y123-Q24*Y134    
8848         X4=1.-(1.-Q24)*Y134-Q24*Y123    
8849         X2=1.-(1.-Q13)*Y234-Q13*Y124    
8850         X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)  
8851         X14=Y24-0.5*QME 
8852         X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)  
8853         IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.   
8854      &  (PARJ(127)+PMQ+PMQN)**2) NJET=2 
8855         IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2    
8856       ENDIF 
8857   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100    
8858     
8859       RETURN    
8860       END   
8861     
8862 C*********************************************************************  
8863     
8864       SUBROUTINE LUXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)    
8865     
8866 C...Purpose: to give the angular orientation of events. 
8867       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
8868       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8869       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
8870       SAVE 
8871     
8872 C...Charge. Factors depending on polarization for QED case. 
8873       QF=KCHG(KFL,1)/3. 
8874       POLL=1.-PARJ(131)*PARJ(132)   
8875       POLD=PARJ(132)-PARJ(131)  
8876       IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN 
8877         HF1=POLL    
8878         HF2=0.  
8879         HF3=PARJ(133)**2    
8880         HF4=0.  
8881     
8882 C...Factors depending on flavour, energy and polarization for QFD case. 
8883       ELSE  
8884         SFF=1./(16.*PARU(102)*(1.-PARU(102)))   
8885         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)  
8886         SFI=SFW*(1.-(PARJ(123)/ECM)**2) 
8887         AE=-1.  
8888         VE=4.*PARU(102)-1.  
8889         AF=SIGN(1.,QF)  
8890         VF=AF-4.*QF*PARU(102)   
8891         HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+  
8892      &  (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD) 
8893         HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*    
8894      &  (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)  
8895         HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*  
8896      &  SFW*SFF**2*(VE**2-AE**2))   
8897         HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*    
8898      &  SFF*AE  
8899       ENDIF 
8900     
8901 C...Mass factor. Differential cross-sections for two-jet events.    
8902       SQ2=SQRT(2.)  
8903       QME=0.    
8904       IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.    
8905      &MSTJ(109).NE.1) QME=(2.*ULMASS(KFL)/ECM)**2   
8906       IF(NJET.EQ.2) THEN    
8907         SIGU=4.*SQRT(1.-QME)    
8908         SIGL=2.*QME*SQRT(1.-QME)    
8909         SIGT=0. 
8910         SIGI=0. 
8911         SIGA=0. 
8912         SIGP=4. 
8913     
8914 C...Kinematical variables. Reduce four-jet event to three-jet one.  
8915       ELSE  
8916         IF(NJET.EQ.3) THEN  
8917           X1=2.*P(NC+1,4)/ECM   
8918           X2=2.*P(NC+3,4)/ECM   
8919         ELSE    
8920           ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+   
8921      &    (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)    
8922           X1=2.*P(NC+1,4)/ECMR  
8923           X2=2.*P(NC+4,4)/ECMR  
8924         ENDIF   
8925     
8926 C...Differential cross-sections for three-jet (or reduced four-jet).    
8927         XQ=(1.-X1)/(1.-X2)  
8928         CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))   
8929         ST12=SQRT(1.-CT12**2)   
8930         IF(MSTJ(109).NE.1) THEN 
8931           SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-  
8932      &    QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ  
8933           SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+ 
8934      &    0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ 
8935           SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2   
8936           SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+    
8937      &    0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2 
8938           SIGA=X2**2*ST12/SQ2   
8939           SIGP=2.*(X1**2-X2**2*CT12)    
8940     
8941 C...Differential cross-sect for scalar gluons (no mass or QFD effects). 
8942         ELSE    
8943           SIGU=2.*(2.-X1-X2)**2-(X2*ST12)**2    
8944           SIGL=(X2*ST12)**2 
8945           SIGT=0.5*SIGL 
8946           SIGI=-(2.-X1-X2)*X2*ST12/SQ2  
8947           SIGA=0.   
8948           SIGP=0.   
8949         ENDIF   
8950       ENDIF 
8951     
8952 C...Upper bounds for differential cross-section.    
8953       HF1A=ABS(HF1) 
8954       HF2A=ABS(HF2) 
8955       HF3A=ABS(HF3) 
8956       HF4A=ABS(HF4) 
8957       SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)* 
8958      &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2* 
8959      &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+   
8960      &2.*HF2A*ABS(SIGP) 
8961     
8962 C...Generate angular orientation according to differential cross-sect.  
8963   100 CHI=PARU(2)*RLU(0)    
8964       CTHE=2.*RLU(0)-1. 
8965       PHI=PARU(2)*RLU(0)    
8966       CCHI=COS(CHI) 
8967       SCHI=SIN(CHI) 
8968       C2CHI=COS(2.*CHI) 
8969       S2CHI=SIN(2.*CHI) 
8970       THE=ACOS(CTHE)    
8971       STHE=SIN(THE) 
8972       C2PHI=COS(2.*(PHI-PARJ(134))) 
8973       S2PHI=SIN(2.*(PHI-PARJ(134))) 
8974       SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+    
8975      &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+  
8976      &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*    
8977      &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*   
8978      &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-  
8979      &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+   
8980      &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP    
8981       IF(SIG.LT.SIGMAX*RLU(0)) GOTO 100 
8982     
8983       RETURN    
8984       END   
8985     
8986 C*********************************************************************  
8987     
8988       SUBROUTINE LUONIA(KFL,ECM)    
8989     
8990 C...Purpose: to generate Upsilon and toponium decays into three 
8991 C...gluons or two gluons and a photon.  
8992       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
8993       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8994       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
8995       SAVE
8996 
8997 C...Printout. Check input parameters.   
8998       IF(MSTU(12).GE.1) CALL LULIST(0)  
8999       IF(KFL.LT.0.OR.KFL.GT.8) THEN 
9000         CALL LUERRM(16,'(LUONIA:) called with unknown flavour code')    
9001         IF(MSTU(21).GE.1) RETURN    
9002       ENDIF 
9003       IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN  
9004         CALL LUERRM(16,'(LUONIA:) called with too small CM energy') 
9005         IF(MSTU(21).GE.1) RETURN    
9006       ENDIF 
9007     
9008 C...Initial e+e- and onium state (optional).    
9009       NC=0  
9010       IF(MSTJ(115).GE.2) THEN   
9011         NC=NC+2 
9012         CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)  
9013         K(NC-1,1)=21    
9014         CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)  
9015         K(NC,1)=21  
9016       ENDIF 
9017       KFLC=IABS(KFL)    
9018       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN 
9019         NC=NC+1 
9020         KF=110*KFLC+3   
9021         MSTU10=MSTU(10) 
9022         MSTU(10)=1  
9023         P(NC,5)=ECM 
9024         CALL LU1ENT(NC,KF,ECM,0.,0.)    
9025         K(NC,1)=21  
9026         K(NC,3)=1   
9027         MSTU(10)=MSTU10 
9028       ENDIF 
9029     
9030 C...Choose x1 and x2 according to matrix element.   
9031       NTRY=0    
9032   100 X1=RLU(0) 
9033       X2=RLU(0) 
9034       X3=2.-X1-X2   
9035       IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+ 
9036      &((1.-X3)/(X1*X2))**2.LE.2.*RLU(0)) GOTO 100   
9037       NTRY=NTRY+1   
9038       NJET=3    
9039       IF(MSTJ(101).LE.4) CALL LU3ENT(NC+1,21,21,21,ECM,X1,X3)   
9040       IF(MSTJ(101).GE.5) CALL LU3ENT(-(NC+1),21,21,21,ECM,X1,X3)    
9041     
9042 C...Photon-gluon-gluon events. Small system modifications. Jet origin.  
9043       MSTU(111)=MSTJ(108)   
9044       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) 
9045      &MSTU(111)=1   
9046       PARU(112)=PARJ(121)   
9047       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)    
9048       QF=0. 
9049       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.  
9050       RGAM=7.2*QF**2*PARU(101)/ULALPS(ECM**2)   
9051       MK=0  
9052       ECMC=ECM  
9053       IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN 
9054         IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))   
9055      &  NJET=2  
9056         IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LU2ENT(NC+1,21,21,ECM)    
9057         IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LU2ENT(-(NC+1),21,21,ECM) 
9058       ELSE  
9059         MK=1    
9060         ECMC=SQRT(1.-X1)*ECM    
9061         IF(ECMC.LT.2.*PARJ(127)) GOTO 100   
9062         K(NC+1,1)=1 
9063         K(NC+1,2)=22    
9064         K(NC+1,4)=0 
9065         K(NC+1,5)=0 
9066         IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3) 
9067         IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3) 
9068         IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2) 
9069         IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2) 
9070         NJET=2  
9071         IF(ECMC.LT.4.*PARJ(127)) THEN   
9072           MSTU10=MSTU(10)   
9073           MSTU(10)=1    
9074           P(NC+2,5)=ECMC    
9075           CALL LU1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)   
9076           MSTU(10)=MSTU10   
9077           NJET=0    
9078         ENDIF   
9079       ENDIF 
9080       DO 110 IP=NC+1,N  
9081   110 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)   
9082     
9083 C...Differential cross-sections. Upper limit for cross-section. 
9084       IF(MSTJ(106).EQ.1) THEN   
9085         SQ2=SQRT(2.)    
9086         HF1=1.-PARJ(131)*PARJ(132)  
9087         HF3=PARJ(133)**2    
9088         CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3) 
9089         ST13=SQRT(1.-CT13**2)   
9090         SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2  
9091         SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL   
9092         SIGT=0.5*SIGL   
9093         SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2 
9094         SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+   
9095      &  2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI) 
9096     
9097 C...Angular orientation of event.   
9098   120   CHI=PARU(2)*RLU(0)  
9099         CTHE=2.*RLU(0)-1.   
9100         PHI=PARU(2)*RLU(0)  
9101         CCHI=COS(CHI)   
9102         SCHI=SIN(CHI)   
9103         C2CHI=COS(2.*CHI)   
9104         S2CHI=SIN(2.*CHI)   
9105         THE=ACOS(CTHE)  
9106         STHE=SIN(THE)   
9107         C2PHI=COS(2.*(PHI-PARJ(134)))   
9108         S2PHI=SIN(2.*(PHI-PARJ(134)))   
9109         SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-  
9110      &  STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*    
9111      &  C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*    
9112      &  CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI 
9113         IF(SIG.LT.SIGMAX*RLU(0)) GOTO 120   
9114         CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)  
9115         CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0) 
9116       ENDIF 
9117     
9118 C...Generate parton shower. Rearrange along strings and check.  
9119       IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN 
9120         CALL LUSHOW(NC+MK+1,-NJET,ECMC) 
9121         MSTJ14=MSTJ(14) 
9122         IF(MSTJ(105).EQ.-1) MSTJ(14)=0  
9123         IF(MSTJ(105).GE.0) MSTU(28)=0   
9124         CALL LUPREP(0)  
9125         MSTJ(14)=MSTJ14 
9126         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100   
9127       ENDIF 
9128     
9129 C...Generate fragmentation. Information for LUTABU: 
9130       IF(MSTJ(105).EQ.1) CALL LUEXEC    
9131       MSTU(161)=110*KFLC+3  
9132       MSTU(162)=0   
9133     
9134       RETURN    
9135       END   
9136     
9137 C*********************************************************************  
9138     
9139       SUBROUTINE LUHEPC(MCONV)  
9140     
9141 C...Purpose: to convert JETSET event record contents to or from 
9142 C...the standard event record commonblock.  
9143       PARAMETER (NMXHEP=9000)   
9144       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),   
9145      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)   
9146       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9147       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
9148       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
9149       SAVE 
9150     
9151 C...Conversion from JETSET to standard, the easy part.  
9152       IF(MCONV.EQ.1) THEN   
9153         NEVHEP=0    
9154         IF(N.GT.NMXHEP) CALL LUERRM(8,  
9155      &  '(LUHEPC:) no more space in /HEPEVT/')  
9156         NHEP=MIN(N,NMXHEP)  
9157         DO 140 I=1,NHEP 
9158         ISTHEP(I)=0 
9159         IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1    
9160         IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2   
9161         IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3   
9162         IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1) 
9163         IDHEP(I)=K(I,2) 
9164         JMOHEP(1,I)=K(I,3)  
9165         JMOHEP(2,I)=0   
9166         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN  
9167           JDAHEP(1,I)=K(I,4)    
9168           JDAHEP(2,I)=K(I,5)    
9169         ELSE    
9170           JDAHEP(1,I)=0 
9171           JDAHEP(2,I)=0 
9172         ENDIF   
9173         DO 100 J=1,5    
9174   100   PHEP(J,I)=P(I,J)    
9175         DO 110 J=1,4    
9176   110   VHEP(J,I)=V(I,J)    
9177     
9178 C...Fill in missing mother information. 
9179         IF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN  
9180           I1=K(I,3)-1   
9181   120     I1=I1+1   
9182           IF(I1.GE.I) CALL LUERRM(8,    
9183      &    '(LUHEPC:) translation of inconsistent event history')    
9184           IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120   
9185           KC=LUCOMP(K(I1,2))    
9186           IF(I1.LT.I.AND.KC.EQ.0) GOTO 120  
9187           IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120  
9188           JMOHEP(2,I)=I1    
9189         ELSEIF(K(I,2).EQ.94) THEN   
9190           NJET=2    
9191           IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3  
9192           IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4  
9193           JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))  
9194           IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=   
9195      &    MOD(K(I+1,4)/MSTU(5),MSTU(5)) 
9196         ENDIF   
9197     
9198 C...Fill in missing daughter information.   
9199         IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN 
9200           DO 130 I1=JDAHEP(1,I),JDAHEP(2,I) 
9201           I2=MOD(K(I1,4)/MSTU(5),MSTU(5))   
9202   130     JDAHEP(1,I2)=I    
9203         ENDIF   
9204         IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140  
9205         I1=JMOHEP(1,I)  
9206         IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140  
9207         IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140    
9208         IF(JDAHEP(1,I1).EQ.0) THEN  
9209           JDAHEP(1,I1)=I    
9210         ELSE    
9211           JDAHEP(2,I1)=I    
9212         ENDIF   
9213   140   CONTINUE    
9214         DO 150 I=1,NHEP 
9215         IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150  
9216         IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)    
9217   150   CONTINUE    
9218     
9219 C...Conversion from standard to JETSET, the easy part.  
9220       ELSE  
9221         IF(NHEP.GT.MSTU(4)) CALL LUERRM(8,  
9222      &  '(LUHEPC:) no more space in /LUJETS/')  
9223         N=MIN(NHEP,MSTU(4)) 
9224         NKQ=0   
9225         KQSUM=0 
9226         DO 180 I=1,N    
9227         K(I,1)=0    
9228         IF(ISTHEP(I).EQ.1) K(I,1)=1 
9229         IF(ISTHEP(I).EQ.2) K(I,1)=11    
9230         IF(ISTHEP(I).EQ.3) K(I,1)=21    
9231         K(I,2)=IDHEP(I) 
9232         K(I,3)=JMOHEP(1,I)  
9233         K(I,4)=JDAHEP(1,I)  
9234         K(I,5)=JDAHEP(2,I)  
9235         DO 160 J=1,5    
9236   160   P(I,J)=PHEP(J,I)    
9237         DO 170 J=1,4    
9238   170   V(I,J)=VHEP(J,I)    
9239         V(I,5)=0.   
9240         IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN  
9241           I1=JDAHEP(1,I)    
9242           IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))* 
9243      &    PHEP(5,I)/PHEP(4,I)   
9244         ENDIF   
9245     
9246 C...Fill in missing information on colour connection in jet systems.    
9247         IF(ISTHEP(I).EQ.1) THEN 
9248           KC=LUCOMP(K(I,2)) 
9249           KQ=0  
9250           IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
9251           IF(KQ.NE.0) NKQ=NKQ+1 
9252           IF(KQ.NE.2) KQSUM=KQSUM+KQ    
9253           IF(KQ.NE.0.AND.KQSUM.NE.0) THEN   
9254             K(I,1)=2    
9255           ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN   
9256             IF(K(I+1,2).EQ.21) K(I,1)=2 
9257           ENDIF 
9258         ENDIF   
9259   180   CONTINUE    
9260         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LUERRM(8,   
9261      &  '(LUHEPC:) input parton configuration not colour singlet')  
9262       ENDIF 
9263     
9264       END   
9265     
9266 C*********************************************************************  
9267     
9268       SUBROUTINE LUTEST(MTEST)  
9269     
9270 C...Purpose: to provide a simple program (disguised as subroutine) to   
9271 C...run at installation as a check that the program works as intended.  
9272       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9273       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
9274       DIMENSION PSUM(5),PINI(6),PFIN(6) 
9275       SAVE
9276 
9277 C...Loop over events to be generated.   
9278       IF(MTEST.GE.1) CALL LUTABU(20)    
9279       NERR=0    
9280       DO 170 IEV=1,600  
9281     
9282 C...Reset parameter values. Switch on some nonstandard features.    
9283       MSTJ(1)=1 
9284       MSTJ(3)=0 
9285       MSTJ(11)=1    
9286       MSTJ(42)=2    
9287       MSTJ(43)=4    
9288       MSTJ(44)=2    
9289       PARJ(17)=0.1  
9290       PARJ(22)=1.5  
9291       PARJ(43)=1.   
9292       PARJ(54)=-0.05    
9293       MSTJ(101)=5   
9294       MSTJ(104)=5   
9295       MSTJ(105)=0   
9296       MSTJ(107)=1   
9297       IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3    
9298     
9299 C...Ten events each for some single jets configurations.    
9300       IF(IEV.LE.50) THEN    
9301         ITY=(IEV+9)/10  
9302         MSTJ(3)=-1  
9303         IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2 
9304         IF(ITY.EQ.1) CALL LU1ENT(1,1,15.,0.,0.) 
9305         IF(ITY.EQ.2) CALL LU1ENT(1,3101,15.,0.,0.)  
9306         IF(ITY.EQ.3) CALL LU1ENT(1,-2203,15.,0.,0.) 
9307         IF(ITY.EQ.4) CALL LU1ENT(1,-4,30.,0.,0.)    
9308         IF(ITY.EQ.5) CALL LU1ENT(1,21,15.,0.,0.)    
9309     
9310 C...Ten events each for some simple jet systems; string fragmentation.  
9311       ELSEIF(IEV.LE.130) THEN   
9312         ITY=(IEV-41)/10 
9313         IF(ITY.EQ.1) CALL LU2ENT(1,1,-1,40.)    
9314         IF(ITY.EQ.2) CALL LU2ENT(1,4,-4,30.)    
9315         IF(ITY.EQ.3) CALL LU2ENT(1,2,2103,100.) 
9316         IF(ITY.EQ.4) CALL LU2ENT(1,21,21,40.)   
9317         IF(ITY.EQ.5) CALL LU3ENT(1,2101,21,-3203,30.,0.6,0.8)   
9318         IF(ITY.EQ.6) CALL LU3ENT(1,5,21,-5,40.,0.9,0.8) 
9319         IF(ITY.EQ.7) CALL LU3ENT(1,21,21,21,60.,0.7,0.5)    
9320         IF(ITY.EQ.8) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)    
9321     
9322 C...Seventy events with independent fragmentation and momentum cons.    
9323       ELSEIF(IEV.LE.200) THEN   
9324         ITY=1+(IEV-131)/16  
9325         MSTJ(2)=1+MOD(IEV-131,4)    
9326         MSTJ(3)=1+MOD((IEV-131)/4,4)    
9327         IF(ITY.EQ.1) CALL LU2ENT(1,4,-5,40.)    
9328         IF(ITY.EQ.2) CALL LU3ENT(1,3,21,-3,40.,0.9,0.4) 
9329         IF(ITY.EQ.3) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)    
9330         IF(ITY.GE.4) CALL LU4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2) 
9331     
9332 C...A hundred events with random jets (check invariant mass).   
9333       ELSEIF(IEV.LE.300) THEN   
9334   100   DO 110 J=1,5    
9335   110   PSUM(J)=0.  
9336         NJET=2.+6.*RLU(0)   
9337         DO 120 I=1,NJET 
9338         KFL=21  
9339         IF(I.EQ.1) KFL=INT(1.+4.*RLU(0))    
9340         IF(I.EQ.NJET) KFL=-INT(1.+4.*RLU(0))    
9341         EJET=5.+20.*RLU(0)  
9342         THETA=ACOS(2.*RLU(0)-1.)    
9343         PHI=6.2832*RLU(0)   
9344         IF(I.LT.NJET) CALL LU1ENT(-I,KFL,EJET,THETA,PHI)    
9345         IF(I.EQ.NJET) CALL LU1ENT(I,KFL,EJET,THETA,PHI) 
9346         IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+ULMASS(KFL) 
9347         DO 120 J=1,4    
9348   120   PSUM(J)=PSUM(J)+P(I,J)  
9349         IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.  
9350      &  (PSUM(5)+PARJ(32))**2) GOTO 100 
9351     
9352 C...Fifty e+e- continuum events with matrix elements.   
9353       ELSEIF(IEV.LE.350) THEN   
9354         MSTJ(101)=2 
9355         CALL LUEEVT(0,40.)  
9356     
9357 C...Fifty e+e- continuum event with varying shower options. 
9358       ELSEIF(IEV.LE.400) THEN   
9359         MSTJ(42)=1+MOD(IEV,2)   
9360         MSTJ(43)=1+MOD(IEV/2,4) 
9361         MSTJ(44)=MOD(IEV/8,3)   
9362         CALL LUEEVT(0,90.)  
9363     
9364 C...Fifty e+e- continuum events with coherent shower, including top.    
9365       ELSEIF(IEV.LE.450) THEN   
9366         MSTJ(104)=6 
9367         CALL LUEEVT(0,500.) 
9368     
9369 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.    
9370       ELSEIF(IEV.LE.500) THEN   
9371         CALL LUONIA(5,9.46) 
9372     
9373 C...One decay each for some heavy mesons.   
9374       ELSEIF(IEV.LE.560) THEN   
9375         ITY=IEV-501 
9376         KFLS=2*(ITY/20)+1   
9377         KFLB=8-MOD(ITY/5,4) 
9378         KFLC=KFLB-MOD(ITY,5)    
9379         CALL LU1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)   
9380     
9381 C...One decay each for some heavy baryons.  
9382       ELSEIF(IEV.LE.600) THEN   
9383         ITY=IEV-561 
9384         KFLS=2*(ITY/20)+2   
9385         KFLA=8-MOD(ITY/5,4) 
9386         KFLB=KFLA-MOD(ITY,5)    
9387         KFLC=MAX(1,KFLB-1)  
9388         CALL LU1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.) 
9389       ENDIF 
9390     
9391 C...Generate event. Find total momentum, energy and charge. 
9392       DO 130 J=1,4  
9393   130 PINI(J)=PLU(0,J)  
9394       PINI(6)=PLU(0,6)  
9395       CALL LUEXEC   
9396       DO 140 J=1,4  
9397   140 PFIN(J)=PLU(0,J)  
9398       PFIN(6)=PLU(0,6)  
9399     
9400 C...Check conservation of energy, momentum and charge;  
9401 C...usually exact, but only approximate for single jets.    
9402       MERR=0    
9403       IF(IEV.LE.50) THEN    
9404         IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1 
9405         EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)  
9406         IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1   
9407         IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1 
9408       ELSE  
9409         DO 150 J=1,4    
9410   150   IF(ABS(PFIN(J)-PINI(J)).GT.0001*PINI(4)) MERR=MERR+1    
9411         IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1 
9412       ENDIF 
9413       IF(MERR.NE.0) WRITE(MSTU(11),1000) (PINI(J),J=1,4),PINI(6),   
9414      &(PFIN(J),J=1,4),PFIN(6)   
9415     
9416 C...Check that all KF codes are known ones, and that partons/particles  
9417 C...satisfy energy-momentum-mass relation. Store particle statistics.   
9418       DO 160 I=1,N  
9419       IF(K(I,1).GT.20) GOTO 160 
9420       IF(LUCOMP(K(I,2)).EQ.0) THEN  
9421         WRITE(MSTU(11),1100) I  
9422         MERR=MERR+1 
9423       ENDIF 
9424       PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2  
9425       IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN  
9426         WRITE(MSTU(11),1200) I  
9427         MERR=MERR+1 
9428       ENDIF 
9429   160 CONTINUE  
9430       IF(MTEST.GE.1) CALL LUTABU(21)    
9431     
9432 C...List all erroneous events and some normal ones. 
9433       IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN  
9434         CALL LULIST(2)  
9435       ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN   
9436         CALL LULIST(1)  
9437       ENDIF 
9438     
9439 C...Stop execution if too many errors. Endresult of run.    
9440       IF(MERR.NE.0) NERR=NERR+1 
9441       IF(NERR.GE.10) THEN   
9442         WRITE(MSTU(11),1300) IEV    
9443         STOP    
9444       ENDIF 
9445   170 CONTINUE  
9446       IF(MTEST.GE.1) CALL LUTABU(22)    
9447       WRITE(MSTU(11),1400) NERR 
9448     
9449 C...Reset commonblock variables changed during run. 
9450       MSTJ(2)=3 
9451       PARJ(17)=0.   
9452       PARJ(22)=1.   
9453       PARJ(43)=0.5  
9454       PARJ(54)=0.   
9455       MSTJ(105)=1   
9456       MSTJ(107)=0   
9457     
9458 C...Format statements for output.   
9459  1000 FORMAT(/' Momentum, energy and/or charge were not conserved ',    
9460      &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X, 
9461      &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X, 
9462      &4(1X,F12.5),1X,F8.2)  
9463  1100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')   
9464  1200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',  
9465      &'kinematics') 
9466  1300 FORMAT(/5X,'Ten errors experienced by event ',I3/ 
9467      &5X,'Something is seriously wrong! Execution stopped now!')    
9468  1400 FORMAT(/5X,'Number of erroneous or suspect events in run:',I3/    
9469      &5X,'(0 fine, 1 acceptable if a single jet, ', 
9470      &'>=2 something is wrong)')    
9471     
9472       RETURN    
9473       END   
9474     
9475 C*********************************************************************  
9476     
9477       BLOCK DATA LUDATA 
9478     
9479 C...Purpose: to give default values to parameters and particle and  
9480 C...decay data. 
9481       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
9482       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
9483       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
9484       COMMON/LUDAT4/CHAF(500)   
9485       CHARACTER CHAF*8  
9486       COMMON/LUDATR/MRLU(6),RRLU(100)   
9487       SAVE 
9488     
9489 C...LUDAT1, containing status codes and most parameters.    
9490       DATA MSTU/    
9491      &    0,    0,    0, 9000,10000,  500, 2000,    0,    0,    2,  
9492      1    6,    1,    1,    0,    1,    1,    0,    0,    0,    0,  
9493      2    2,   10,    0,    0,    1,   10,    0,    0,    0,    0,  
9494      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
9495      4    2,    2,    1,    4,    2,    1,    1,    0,    0,    0,  
9496      5   25,   24,    0,    1,    0,    0,    0,    0,    0,    0,  
9497      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
9498      7  40*0,   
9499      1    1,    5,    3,    5,    0,    0,    0,    0,    0,    0,  
9500      2  60*0,   
9501      8    7,    2, 1989,   11,   25,    0,    0,    0,    0,    0,  
9502      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
9503       DATA PARU/    
9504      & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568,   4*0.,  
9505      1 0.001, 0.09, 0.01,  0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9506      2   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9507      3   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9508      4  2.0,  1.0, 0.25,  2.5, 0.05,   0.,   0., 0.0001, 0.,   0.,  
9509      5  2.5,  1.5,  7.0,  1.0,  0.5,  2.0,  3.2,   0.,   0.,   0.,  
9510      6  40*0.,  
9511      & 0.0072974, 0.230, 0., 0., 0.,   0.,   0.,   0.,   0.,   0.,  
9512      1 0.20, 0.25,  1.0,  4.0,   0.,   0.,   0.,   0.,   0.,   0.,  
9513      2  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9514      3  70*0./  
9515       DATA MSTJ/    
9516      &    1,    3,    0,    0,    0,    0,    0,    0,    0,    0,  
9517      1    1,    2,    0,    1,    0,    0,    0,    0,    0,    0,  
9518      2    2,    2,    1,    2,    1,    0,    0,    0,    0,    0,  
9519      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
9520      4    1,    2,    4,    2,    5,    0,    1,    0,    0,    0,  
9521      5    0,    3,    0,    0,    0,    0,    0,    0,    0,    0,  
9522      6  40*0,   
9523      &    5,    2,    7,    5,    1,    1,    0,    2,    0,    1,  
9524      1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,  
9525      2  80*0/   
9526       DATA PARJ/    
9527      & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50,   0.,   0.,   0.,  
9528      1 0.50, 0.60, 0.75,   0.,   0.,   0.,   0.,  1.0,  1.0,   0.,  
9529      2 0.35,  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9530      3 0.10,  1.0,  0.8,  1.5,  0.8,  2.0,  0.2,  2.5,  0.6,  2.5,  
9531      4  0.5,  0.9,  0.5,  0.9,  0.5,   0.,   0.,   0.,   0.,   0.,  
9532      5 0.77, 0.77, 0.77,   0.,   0.,   0.,   0.,   0.,  1.0,   0.,  
9533      6  4.5,  0.7,  0., 0.003,  0.5,  0.5,   0.,   0.,   0.,   0.,  
9534      7  10., 1000., 100., 1000., 0.,   0.,   0.,   0.,   0.,   0.,  
9535      8  0.4,  1.0,  1.0,   0.,  10.,  10.,   0.,   0.,   0.,   0.,  
9536      9 0.02,  1.0,  0.2,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9537      &   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9538      1   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9539      2  1.5,  0.5, 91.2, 2.40, 0.02,  2.0,  1.0, 0.25,0.002,   0.,  
9540      3   0.,   0.,   0.,   0., 0.01, 0.99,   0.,   0.,  0.2,   0.,  
9541      4  60*0./  
9542     
9543 C...LUDAT2, with particle data and flavour treatment parameters.    
9544       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,   
9545      &-3,0,-3,6*0,3,9*0,3,2*0,3,46*0,2,-1,2,-1,2,3,11*0,3,0,2*3,    
9546      &0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0, 
9547      &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,  
9548      &3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,  
9549      &4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,-3,0,3,-3,0,-3,114*0/   
9550       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,68*0,-1,410*0/    
9551       DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,2*0,1, 
9552      &41*0,1,0,7*1,10*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,    
9553      &11*0,9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,   
9554      &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/ 
9555       DATA (PMAS(I,1),I=   1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,   
9556      &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15., 
9557      &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,  
9558      &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,   
9559      &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921, 
9560      &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,   
9561      &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,  
9562      &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,  
9563      &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,  
9564      &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,   
9565      &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,   
9566      &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274, 
9567      &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,    
9568      &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,  
9569      &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,   
9570      &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,  
9571      &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5, 
9572      &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./    
9573       DATA (PMAS(I,2),I=   1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,  
9574      &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06, 
9575      &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,   
9576      &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,    
9577      &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,  
9578      &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./ 
9579       DATA (PMAS(I,3),I=   1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4, 
9580      &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2, 
9581      &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,   
9582      &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,  
9583      &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./   
9584       DATA (PMAS(I,4),I=   1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,  
9585      &15*0.,7803.,.00003,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,   
9586      &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,  
9587      &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./  
9588       DATA PARF/    
9589      &  0.5, 0.25,  0.5, 0.25,   1.,  0.5,   0.,   0.,   0.,   0.,  
9590      1  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
9591      2  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
9592      3  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
9593      4  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
9594      5  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
9595      6 0.75,  0.5,   0., 0.1667, 0.0833, 0.1667, 0., 0., 0.,   0.,  
9596      7   0.,   0.,   1., 0.3333, 0.6667, 0.3333, 0., 0., 0.,   0.,  
9597      8   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9598      9   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9599      & 0.325, 0.325, 0.5, 1.6,  5.0,   0.,   0.,   0.,   0.,   0.,  
9600      1   0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60,  0.,   0.,  
9601      2  0.2,  0.1,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
9602      3  1870*0./    
9603       DATA ((VCKM(I,J),J=1,4),I=1,4)/   
9604      1  0.95150,  0.04847,  0.00003,  0.00000,  
9605      2  0.04847,  0.94936,  0.00217,  0.00000,  
9606      3  0.00003,  0.00217,  0.99780,  0.00000,  
9607      4  0.00000,  0.00000,  0.00000,  1.00000/  
9608     
9609 C...LUDAT3, with particle decay parameters and data.    
9610       DATA (MDCY(I,1),I=   1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,  
9611      &1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,    
9612      &9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,2*1,   
9613      &6*0,1,0,2*1,9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/ 
9614       DATA (MDCY(I,2),I=   1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,  
9615      &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,    
9616      &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,    
9617      &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,    
9618      &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,    
9619      &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,    
9620      &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,    
9621      &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,  
9622      &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,    
9623      &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,   
9624      &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,  
9625      &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023, 
9626      &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,  
9627      &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,  
9628      &1065,114*0/   
9629       DATA (MDCY(I,3),I=   1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,   
9630      &17,20,17,6*0,16,4*0,8,2*0,9,42*0,1,4,9,3*2,20,11*0,1,2,6,121,168, 
9631      &32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,2*0,1,2*5,  
9632      &2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,2*4,3*2,2*1,  
9633      &2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,2*8,5,0,7,8,    
9634      &4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,2,1,3,1,2,0,  
9635      &6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/    
9636       DATA (MDME(I,1),I=   1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,  
9637      &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,2*-1,6*1,2*-1,6*1,3*-1,3*1,-1,3*1,  
9638      &-1,3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,2*-1,3*1,-1,3*1, 
9639      &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/  
9640       DATA (MDME(I,2),I=   1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,   
9641      &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,    
9642      &8*0,4*32,4*0,6*32,3*0,12,2*42,2*11,9*42,6*45,20*46,7*0,34*42, 
9643      &86*0,2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,  
9644      &8*0,2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0, 
9645      &12,3*0,4*32,2*4,6*0,5*32,2*4,2*45,87,88,30*0,12,32,0,32,87,88,    
9646      &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,   
9647      &32,87,88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,  
9648      &974*0/    
9649       DATA (BRAT(I)  ,I=   1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003, 
9650      &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,  
9651      &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,    
9652      &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01, 
9653      &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,  
9654      &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,    
9655      &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,    
9656      &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,    
9657      &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032, 
9658      &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,   
9659      &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001, 
9660      &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037, 
9661      &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,  
9662      &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004, 
9663      &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004, 
9664      &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021, 
9665      &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,    
9666      &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,   
9667      &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007, 
9668      &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/   
9669       DATA (BRAT(I)  ,I= 526, 893)/.019,2*.003,.002,.005,.004,.008, 
9670      &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001, 
9671      &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04, 
9672      &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012, 
9673      &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,  
9674      &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,  
9675      &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,   
9676      &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,    
9677      &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,  
9678      &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,   
9679      &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033, 
9680      &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,   
9681      &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333, 
9682      &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35, 
9683      &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,   
9684      &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084, 
9685      &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,  
9686      &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,  
9687      &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,  
9688      &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/ 
9689       DATA (BRAT(I)  ,I= 894,2000)/.003,.573,.287,.063,.028,2*.021, 
9690      &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,   
9691      &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003, 
9692      &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006, 
9693      &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,    
9694      &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001, 
9695      &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,   
9696      &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,    
9697      &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676, 
9698      &.234,.085,.005,3*1.,4*.5,7*1.,935*0./ 
9699       DATA (KFDP(I,1),I=   1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,  
9700      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,    
9701      &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,    
9702      &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,   
9703      &23,-24,25,23,24,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,   
9704      &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5, 
9705      &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1, 
9706      &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,    
9707      &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2, 
9708      &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,   
9709      &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,  
9710      &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,   
9711      &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,  
9712      &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,    
9713      &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311, 
9714      &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311, 
9715      &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,    
9716      &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,  
9717      &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321, 
9718      &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/ 
9719       DATA (KFDP(I,1),I= 500, 873)/-323,2*-321,-311,2*333,211,213,  
9720      &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,  
9721      &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313, 
9722      &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15, 
9723      &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,  
9724      &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111, 
9725      &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,    
9726      &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13, 
9727      &82,11,13,15,1,2,3,4,21,22,11,12,13,14,15,16,1,2,3,4,5,21,22,2*89, 
9728      &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,  
9729      &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,   
9730      &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413, 
9731      &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,  
9732      &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,    
9733      &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,    
9734      &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213, 
9735      &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,   
9736      &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,    
9737      &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,  
9738      &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/  
9739       DATA (KFDP(I,1),I= 874,2000)/2*511,521,513,523,513,523,511,2*521, 
9740      &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130, 
9741      &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,   
9742      &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214, 
9743      &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212, 
9744      &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,    
9745      &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,    
9746      &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122, 
9747      &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122, 
9748      &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,    
9749      &935*0/    
9750       DATA (KFDP(I,2),I=   1, 496)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4, 
9751      &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,    
9752      &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211, 
9753      &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,   
9754      &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,  
9755      &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2, 
9756      &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,    
9757      &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,  
9758      &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,    
9759      &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18, 
9760      &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,   
9761      &-3,11,13,15,1,4,3,4,1,3,5,3,6,4,7,5,2,4,6,8,2,4,6,8,2,4,6,8,2,4,  
9762      &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,  
9763      &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,    
9764      &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223, 
9765      &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113, 
9766      &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1, 
9767      &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,  
9768      &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,  
9769      &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/  
9770       DATA (KFDP(I,2),I= 497, 863)/323,321,2*311,313,2*311,111,211, 
9771      &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,   
9772      &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,  
9773      &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,   
9774      &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,    
9775      &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,   
9776      &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,   
9777      &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82, 
9778      &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4, 
9779      &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,    
9780      &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,   
9781      &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,  
9782      &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,    
9783      &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321, 
9784      &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211, 
9785      &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111, 
9786      &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22, 
9787      &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211, 
9788      &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211, 
9789      &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/    
9790       DATA (KFDP(I,2),I= 864,2000)/2*111,211,-211,111,-211,111,-211,    
9791      &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,    
9792      &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22, 
9793      &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111, 
9794      &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,   
9795      &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,  
9796      &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,    
9797      &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,  
9798      &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211, 
9799      &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,  
9800      &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,  
9801      &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/ 
9802       DATA (KFDP(I,3),I=   1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,  
9803      &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,  
9804      &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,  
9805      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111, 
9806      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111, 
9807      &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211, 
9808      &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,  
9809      &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211, 
9810      &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,  
9811      &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,   
9812      &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,  
9813      &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,    
9814      &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,  
9815      &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,    
9816      &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,  
9817      &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,  
9818      &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,  
9819      &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111, 
9820      &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,    
9821      &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/   
9822       DATA (KFDP(I,3),I= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,   
9823      &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0, 
9824      &2112,43*0,3322,949*0/ 
9825       DATA (KFDP(I,4),I=   1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,  
9826      &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111, 
9827      &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,   
9828      &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,   
9829      &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,   
9830      &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,   
9831      &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211, 
9832      &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,    
9833      &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,    
9834      &1006*0/   
9835       DATA (KFDP(I,5),I=   1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,   
9836      &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111, 
9837      &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/   
9838     
9839 C...LUDAT4, with character strings. 
9840       DATA (CHAF(I)  ,I=   1, 331)/'d','u','s','c','b','t','l','h', 
9841      &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',  
9842      &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',  
9843      &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron', 
9844      &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',    
9845      &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis', 
9846      &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B', 
9847      &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l', 
9848      &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho', 
9849      &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',  
9850      &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',  
9851      &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0', 
9852      &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',   
9853      &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1', 
9854      &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',   
9855      &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2', 
9856      &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',   
9857      &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L', 
9858      &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',    
9859      &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/  
9860       DATA (CHAF(I)  ,I= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',    
9861      &3*'Sigma_c',2*'Xi''_c','Omega_c', 
9862      &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',   
9863      &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c', 
9864      &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/  
9865     
9866 C...LUDATR, with initial values for the random number generator.    
9867       DATA MRLU/19780503,0,0,97,33,0/   
9868     
9869       END   
9870       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)  
9871     
9872 C...Initializes the generation procedure; finds maxima of the   
9873 C...differential cross-sections to be used for weighting.   
9874       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
9875       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
9876       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
9877       COMMON/LUDAT4/CHAF(500)   
9878       CHARACTER CHAF*8  
9879       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
9880       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
9881       COMMON/PYINT1/MINT(400),VINT(400) 
9882       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
9883       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
9884       CHARACTER*(*) FRAME,BEAM,TARGET   
9885       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHMO(12)*3,CHLH(2)*6 
9886       SAVE
9887       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
9888      &'Oct','Nov','Dec'/, CHLH/'lepton','hadron'/   
9889     
9890       CHMO(1)=CHMO(1)
9891 C...Write headers.  
9892 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),  
9893 C     &MSTP(185),CHMO(MSTP(184)),MSTP(183)   
9894       CALL LULIST(0)
9895 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)  
9896     
9897 C...Identify beam and target particles and initialize kinematics.   
9898       CHFRAM=FRAME//' ' 
9899       CHBEAM=BEAM//' '  
9900       CHTARG=TARGET//' '    
9901       CALL PYINKI(CHFRAM,CHBEAM,CHTARG,WIN) 
9902     
9903 C...Select partonic subprocesses to be included in the simulation.  
9904       IF(MSEL.NE.0) THEN    
9905         DO 100 I=1,200  
9906   100   MSUB(I)=0   
9907       ENDIF 
9908       IF(MINT(43).EQ.1.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN   
9909 C...Lepton+lepton -> gamma/Z0 or W. 
9910         IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1    
9911         IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1    
9912       ELSEIF(MSEL.EQ.1) THEN    
9913 C...High-pT QCD processes:  
9914         MSUB(11)=1  
9915         MSUB(12)=1  
9916         MSUB(13)=1  
9917         MSUB(28)=1  
9918         MSUB(53)=1  
9919         MSUB(68)=1  
9920         IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1    
9921         IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1    
9922       ELSEIF(MSEL.EQ.2) THEN    
9923 C...All QCD processes:  
9924         MSUB(11)=1  
9925         MSUB(12)=1  
9926         MSUB(13)=1  
9927         MSUB(28)=1  
9928         MSUB(53)=1  
9929         MSUB(68)=1  
9930         MSUB(91)=1  
9931         MSUB(92)=1  
9932         MSUB(93)=1  
9933         MSUB(95)=1  
9934       ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN  
9935 C...Heavy quark production. 
9936         MSUB(81)=1  
9937         MSUB(82)=1  
9938         DO 110 J=1,MIN(8,MDCY(21,3))    
9939   110   MDME(MDCY(21,2)+J-1,1)=0    
9940         MDME(MDCY(21,2)+MSEL-1,1)=1 
9941       ELSEIF(MSEL.EQ.10) THEN   
9942 C...Prompt photon production:   
9943         MSUB(14)=1  
9944         MSUB(18)=1  
9945         MSUB(29)=1  
9946       ELSEIF(MSEL.EQ.11) THEN   
9947 C...Z0/gamma* production:   
9948         MSUB(1)=1   
9949       ELSEIF(MSEL.EQ.12) THEN   
9950 C...W+/- production:    
9951         MSUB(2)=1   
9952       ELSEIF(MSEL.EQ.13) THEN   
9953 C...Z0 + jet:   
9954         MSUB(15)=1  
9955         MSUB(30)=1  
9956       ELSEIF(MSEL.EQ.14) THEN   
9957 C...W+/- + jet: 
9958         MSUB(16)=1  
9959         MSUB(31)=1  
9960       ELSEIF(MSEL.EQ.15) THEN   
9961 C...Z0 & W+/- pair production:  
9962         MSUB(19)=1  
9963         MSUB(20)=1  
9964         MSUB(22)=1  
9965         MSUB(23)=1  
9966         MSUB(25)=1  
9967       ELSEIF(MSEL.EQ.16) THEN   
9968 C...H0 production:  
9969         MSUB(3)=1   
9970         MSUB(5)=1   
9971         MSUB(8)=1   
9972         MSUB(102)=1 
9973       ELSEIF(MSEL.EQ.17) THEN   
9974 C...H0 & Z0 or W+/- pair production:    
9975         MSUB(24)=1  
9976         MSUB(26)=1  
9977       ELSEIF(MSEL.EQ.21) THEN   
9978 C...Z'0 production: 
9979         MSUB(141)=1 
9980       ELSEIF(MSEL.EQ.22) THEN   
9981 C...H+/- production:    
9982         MSUB(142)=1 
9983       ELSEIF(MSEL.EQ.23) THEN   
9984 C...R production:   
9985         MSUB(143)=1 
9986       ENDIF 
9987     
9988 C...Count number of subprocesses on.    
9989       MINT(44)=0    
9990       DO 120 ISUB=1,200 
9991       IF(MINT(43).LT.4.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.   
9992      &MSUB(ISUB).EQ.1) THEN 
9993         WRITE(MSTU(11),1200) ISUB,CHLH(MINT(41)),CHLH(MINT(42)) 
9994         STOP    
9995       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN 
9996         WRITE(MSTU(11),1300) ISUB   
9997         STOP    
9998       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN 
9999         WRITE(MSTU(11),1400) ISUB   
10000         STOP    
10001       ELSEIF(MSUB(ISUB).EQ.1) THEN  
10002         MINT(44)=MINT(44)+1 
10003       ENDIF 
10004   120 CONTINUE  
10005       IF(MINT(44).EQ.0) THEN    
10006         WRITE(MSTU(11),1500)    
10007         STOP    
10008       ENDIF 
10009       MINT(45)=MINT(44)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) 
10010     
10011 C...Maximum 4 generations; set maximum number of allowed flavours.  
10012       MSTP(1)=MIN(4,MSTP(1))    
10013       MSTU(114)=MIN(MSTU(114),2*MSTP(1))    
10014       MSTP(54)=MIN(MSTP(54),2*MSTP(1))  
10015     
10016 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. 
10017       DO 140 I=-20,20   
10018       VINT(180+I)=0.    
10019       IA=IABS(I)    
10020       IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN  
10021         DO 130 J=1,MSTP(1)  
10022         IB=2*J-1+MOD(IA,2)  
10023         IPM=(5-ISIGN(1,I))/2    
10024         IDC=J+MDCY(IA,2)+2  
10025   130   IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)= 
10026      &  VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2) 
10027       ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN  
10028         VINT(180+I)=1.  
10029       ENDIF 
10030   140 CONTINUE  
10031     
10032 C...Choose Lambda value to use in alpha-strong. 
10033       MSTU(111)=MSTP(2) 
10034       IF(MSTP(3).GE.1) THEN 
10035         ALAM=PARP(1)    
10036         IF(MSTP(51).EQ.1) ALAM=0.2  
10037         IF(MSTP(51).EQ.2) ALAM=0.29 
10038         IF(MSTP(51).EQ.3) ALAM=0.2  
10039         IF(MSTP(51).EQ.4) ALAM=0.4  
10040         IF(MSTP(51).EQ.11) ALAM=0.16    
10041         IF(MSTP(51).EQ.12) ALAM=0.26    
10042         IF(MSTP(51).EQ.13) ALAM=0.36    
10043         PARP(1)=ALAM    
10044         PARP(61)=ALAM   
10045         PARU(112)=ALAM  
10046         PARJ(81)=ALAM   
10047       ENDIF 
10048     
10049 C...Initialize widths and partial widths for resonances.    
10050       CALL PYINRE   
10051     
10052 C...Reset variables for cross-section calculation.  
10053       DO 150 I=0,200    
10054       DO 150 J=1,3  
10055       NGEN(I,J)=0   
10056   150 XSEC(I,J)=0.  
10057       VINT(108)=0.  
10058     
10059 C...Find parametrized total cross-sections. 
10060       IF(MINT(43).EQ.4) CALL PYXTOT 
10061     
10062 C...Maxima of differential cross-sections.  
10063       IF(MSTP(121).LE.0) CALL PYMAXI    
10064     
10065 C...Initialize possibility of overlayed events. 
10066       IF(MSTP(131).NE.0) CALL PYOVLY(1) 
10067     
10068 C...Initialize multiple interactions with variable impact parameter.    
10069       IF(MINT(43).EQ.4.AND.(MINT(45).NE.0.OR.MSTP(131).NE.0).AND.   
10070      &MSTP(82).GE.2) CALL PYMULT(1) 
10071 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)  
10072     
10073 C...Formats for initialization information. 
10074 C      FORMAT(///20X,'The Lund Monte Carlo - PYTHIA version ',I1,'.',I1/ 
10075 C     &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)  
10076 C      FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',    
10077 C     &'routines',1X,17('*'))    
10078  1200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,  
10079      &'-',A6,' interactions.'/1X,'Execution stopped!')  
10080  1300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/   
10081      &1X,'Execution stopped!')  
10082  1400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/  
10083      &1X,'Execution stopped!')  
10084  1500 FORMAT(1X,'Error: no subprocess switched on.'/    
10085      &1X,'Execution stopped.')  
10086 C...      FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,  
10087 C     &22('*'))  
10088     
10089       RETURN    
10090       END   
10091     
10092 C*********************************************************************  
10093     
10094       SUBROUTINE PYTHIA 
10095     
10096 C...Administers the generation of a high-pt event via calls to a number 
10097 C...of subroutines; also computes cross-sections.   
10098       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10099       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10100       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
10101       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
10102       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10103       COMMON/PYINT1/MINT(400),VINT(400) 
10104       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
10105       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
10106       SAVE 
10107     
10108 C...Loop over desired number of overlayed events (normally 1).  
10109       MINT(7)=0 
10110       MINT(8)=0 
10111       NOVL=1    
10112       IF(MSTP(131).NE.0) CALL PYOVLY(2) 
10113       IF(MSTP(131).NE.0) NOVL=MINT(81)  
10114       MINT(83)=0    
10115       MINT(84)=MSTP(126)    
10116       MSTU(70)=0    
10117       DO 190 IOVL=1,NOVL    
10118       IF(MINT(84)+100.GE.MSTU(4)) THEN  
10119         CALL LUERRM(11, 
10120      &  '(PYTHIA:) no more space in LUJETS for overlayed events')   
10121         IF(MSTU(21).GE.1) GOTO 200  
10122       ENDIF 
10123       MINT(82)=IOVL 
10124     
10125 C...Generate variables of hard scattering.  
10126   100 CONTINUE  
10127       IF(IOVL.EQ.1) NGEN(0,2)=NGEN(0,2)+1   
10128       MINT(31)=0    
10129       MINT(51)=0    
10130       CALL PYRAND   
10131       ISUB=MINT(1)  
10132       IF(IOVL.EQ.1) THEN    
10133         NGEN(ISUB,2)=NGEN(ISUB,2)+1 
10134     
10135 C...Store information on hard interaction.  
10136         DO 110 J=1,200  
10137         MSTI(J)=0   
10138   110   PARI(J)=0.  
10139         MSTI(1)=MINT(1) 
10140         MSTI(2)=MINT(2) 
10141         MSTI(11)=MINT(11)   
10142         MSTI(12)=MINT(12)   
10143         MSTI(15)=MINT(15)   
10144         MSTI(16)=MINT(16)   
10145         MSTI(17)=MINT(17)   
10146         MSTI(18)=MINT(18)   
10147         PARI(11)=VINT(1)    
10148         PARI(12)=VINT(2)    
10149         IF(ISUB.NE.95) THEN 
10150           DO 120 J=13,22    
10151   120     PARI(J)=VINT(30+J)    
10152           PARI(33)=VINT(41) 
10153           PARI(34)=VINT(42) 
10154           PARI(35)=PARI(33)-PARI(34)    
10155           PARI(36)=VINT(21) 
10156           PARI(37)=VINT(22) 
10157           PARI(38)=VINT(26) 
10158           PARI(41)=VINT(23) 
10159         ENDIF   
10160       ENDIF 
10161     
10162       IF(MSTP(111).EQ.-1) GOTO 160  
10163       IF(ISUB.LE.90.OR.ISUB.GE.95) THEN 
10164 C...Hard scattering (including low-pT): 
10165 C...reconstruct kinematics and colour flow of hard scattering.  
10166         CALL PYSCAT 
10167         IF(MINT(51).EQ.1) GOTO 100  
10168     
10169 C...Showering of initial state partons (optional).  
10170         IPU1=MINT(84)+1 
10171         IPU2=MINT(84)+2 
10172         IF(MSTP(61).GE.1.AND.MINT(43).NE.1.AND.ISUB.NE.95)  
10173      &  CALL PYSSPA(IPU1,IPU2)  
10174         NSAV1=N 
10175     
10176 C...Multiple interactions.  
10177         IF(MSTP(81).GE.1.AND.MINT(43).EQ.4.AND.ISUB.NE.95)  
10178      &  CALL PYMULT(6)  
10179         MINT(1)=ISUB    
10180         NSAV2=N 
10181     
10182 C...Hadron remnants and primordial kT.  
10183         CALL PYREMN(IPU1,IPU2)  
10184         IF(MINT(51).EQ.1) GOTO 100  
10185         NSAV3=N 
10186     
10187 C...Showering of final state partons (optional).    
10188         IPU3=MINT(84)+3 
10189         IPU4=MINT(84)+4 
10190         IF(MSTP(71).GE.1.AND.ISUB.NE.95.AND.K(IPU3,1).GT.0.AND. 
10191      &  K(IPU3,1).LE.10.AND.K(IPU4,1).GT.0.AND.K(IPU4,1).LE.10) THEN    
10192           QMAX=SQRT(PARP(71)*VINT(52))  
10193           IF(ISUB.EQ.5) QMAX=SQRT(PMAS(23,1)**2)    
10194           IF(ISUB.EQ.8) QMAX=SQRT(PMAS(24,1)**2)    
10195           CALL LUSHOW(IPU3,IPU4,QMAX)   
10196         ENDIF   
10197     
10198 C...Sum up transverse and longitudinal momenta. 
10199         IF(IOVL.EQ.1) THEN  
10200           PARI(65)=2.*PARI(17)  
10201           DO 130 I=MSTP(126)+1,N    
10202           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130  
10203           PT=SQRT(P(I,1)**2+P(I,2)**2)  
10204           PARI(69)=PARI(69)+PT  
10205           IF(I.LE.NSAV1.OR.I.GT.NSAV3) PARI(66)=PARI(66)+PT 
10206           IF(I.GT.NSAV1.AND.I.LE.NSAV2) PARI(68)=PARI(68)+PT    
10207   130     CONTINUE  
10208           PARI(67)=PARI(68) 
10209           PARI(71)=VINT(151)    
10210           PARI(72)=VINT(152)    
10211           PARI(73)=VINT(151)    
10212           PARI(74)=VINT(152)    
10213         ENDIF   
10214     
10215 C...Decay of final state resonances.    
10216         IF(MSTP(41).GE.1.AND.ISUB.NE.95) CALL PYRESD    
10217     
10218       ELSE  
10219 C...Diffractive and elastic scattering. 
10220         CALL PYDIFF 
10221         IF(IOVL.EQ.1) THEN  
10222           PARI(65)=2.*PARI(17)  
10223           PARI(66)=PARI(65) 
10224           PARI(69)=PARI(65) 
10225         ENDIF   
10226       ENDIF 
10227     
10228 C...Recalculate energies from momenta and masses (if desired).  
10229       IF(MSTP(113).GE.1) THEN   
10230         DO 140 I=MINT(83)+1,N   
10231   140   IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ 
10232      &  P(I,2)**2+P(I,3)**2+P(I,5)**2)  
10233       ENDIF 
10234     
10235 C...Rearrange partons along strings, check invariant mass cuts. 
10236       MSTU(28)=0    
10237       CALL LUPREP(MINT(84)+1)   
10238       IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 
10239       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN 
10240         DO 150 I=MINT(84)+1,N   
10241         IF(K(I,2).NE.94) GOTO 150   
10242         K(I+1,3)=MOD(K(I+1,4)/MSTU(5),MSTU(5))  
10243         K(I+2,3)=MOD(K(I+2,4)/MSTU(5),MSTU(5))  
10244   150   CONTINUE    
10245         CALL LUEDIT(12) 
10246         CALL LUEDIT(14) 
10247         IF(MSTP(125).EQ.0) CALL LUEDIT(15)  
10248         IF(MSTP(125).EQ.0) MINT(4)=0    
10249       ENDIF 
10250     
10251 C...Introduce separators between sections in LULIST event listing.  
10252       IF(IOVL.EQ.1.AND.MSTP(125).LE.0) THEN 
10253         MSTU(70)=1  
10254         MSTU(71)=N  
10255       ELSEIF(IOVL.EQ.1) THEN    
10256         MSTU(70)=3  
10257         MSTU(71)=2  
10258         MSTU(72)=MINT(4)    
10259         MSTU(73)=N  
10260       ENDIF 
10261     
10262 C...Perform hadronization (if desired). 
10263       IF(MSTP(111).GE.1) CALL LUEXEC    
10264       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL LUEDIT(14)  
10265     
10266 C...Calculate Monte Carlo estimates of cross-sections.  
10267   160 IF(IOVL.EQ.1) THEN    
10268         IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1 
10269         NGEN(0,3)=NGEN(0,3)+1   
10270         XSEC(0,3)=0.    
10271         DO 170 I=1,200  
10272         IF(I.EQ.96) THEN    
10273           XSEC(I,3)=0.  
10274         ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR. 
10275      &  I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN    
10276           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1.,FLOAT(NGEN(96,1))*  
10277      &    FLOAT(NGEN(96,2)))    
10278         ELSEIF(NGEN(I,1).EQ.0) THEN 
10279           XSEC(I,3)=0.  
10280         ELSEIF(NGEN(I,2).EQ.0) THEN 
10281           XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(FLOAT(NGEN(I,1))*  
10282      &    FLOAT(NGEN(0,2))) 
10283         ELSE    
10284           XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(FLOAT(NGEN(I,1))*  
10285      &    FLOAT(NGEN(I,2))) 
10286         ENDIF   
10287   170   XSEC(0,3)=XSEC(0,3)+XSEC(I,3)   
10288         IF(MSUB(95).EQ.1) THEN  
10289           NGENS=NGEN(91,3)+NGEN(92,3)+NGEN(93,3)+NGEN(94,3)+NGEN(95,3)  
10290           XSECS=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+XSEC(95,3)  
10291           XMAXS=XSEC(95,1)  
10292           IF(MSUB(91).EQ.1) XMAXS=XMAXS+XSEC(91,1)  
10293           IF(MSUB(92).EQ.1) XMAXS=XMAXS+XSEC(92,1)  
10294           IF(MSUB(93).EQ.1) XMAXS=XMAXS+XSEC(93,1)  
10295           IF(MSUB(94).EQ.1) XMAXS=XMAXS+XSEC(94,1)  
10296           FAC=1.    
10297           IF(NGENS.LT.NGEN(0,3)) FAC=(XMAXS-XSECS)/(XSEC(0,3)-XSECS)    
10298           XSEC(11,3)=FAC*XSEC(11,3) 
10299           XSEC(12,3)=FAC*XSEC(12,3) 
10300           XSEC(13,3)=FAC*XSEC(13,3) 
10301           XSEC(28,3)=FAC*XSEC(28,3) 
10302           XSEC(53,3)=FAC*XSEC(53,3) 
10303           XSEC(68,3)=FAC*XSEC(68,3) 
10304           XSEC(0,3)=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+    
10305      &    XSEC(95,1)    
10306         ENDIF   
10307     
10308 C...Store final information.    
10309         MINT(5)=MINT(5)+1   
10310         MSTI(3)=MINT(3) 
10311         MSTI(4)=MINT(4) 
10312         MSTI(5)=MINT(5) 
10313         MSTI(6)=MINT(6) 
10314         MSTI(7)=MINT(7) 
10315         MSTI(8)=MINT(8) 
10316         MSTI(13)=MINT(13)   
10317         MSTI(14)=MINT(14)   
10318         MSTI(21)=MINT(21)   
10319         MSTI(22)=MINT(22)   
10320         MSTI(23)=MINT(23)   
10321         MSTI(24)=MINT(24)   
10322         MSTI(25)=MINT(25)   
10323         MSTI(26)=MINT(26)   
10324         MSTI(31)=MINT(31)   
10325         PARI(1)=XSEC(0,3)   
10326         PARI(2)=XSEC(0,3)/MINT(5)   
10327         PARI(31)=VINT(141)  
10328         PARI(32)=VINT(142)  
10329         IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN    
10330           PARI(42)=2.*VINT(47)/VINT(1)  
10331           DO 180 IS=7,8 
10332           PARI(36+IS)=P(MINT(IS),3)/VINT(1) 
10333           PARI(38+IS)=P(MINT(IS),4)/VINT(1) 
10334           I=MINT(IS)    
10335           PR=MAX(1E-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)   
10336           PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/    
10337      &    SQRT(PR),1E20)),P(I,3))   
10338           PR=MAX(1E-20,P(I,1)**2+P(I,2)**2) 
10339           PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/    
10340      &    SQRT(PR),1E20)),P(I,3))   
10341           PARI(44+IS)=P(I,3)/SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)    
10342           PARI(46+IS)=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))  
10343           PARI(48+IS)=ULANGL(P(I,1),P(I,2)) 
10344   180     CONTINUE  
10345         ENDIF   
10346         PARI(61)=VINT(148)  
10347         IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN 
10348           MSTU(161)=MINT(21)    
10349           MSTU(162)=0   
10350         ELSE    
10351           MSTU(161)=MINT(21)    
10352           MSTU(162)=MINT(22)    
10353         ENDIF   
10354       ENDIF 
10355     
10356 C...Prepare to go to next overlayed event.  
10357       MSTI(41)=IOVL 
10358       IF(IOVL.GE.2.AND.IOVL.LE.10) MSTI(40+IOVL)=ISUB   
10359       IF(MSTU(70).LT.10) THEN   
10360         MSTU(70)=MSTU(70)+1 
10361         MSTU(70+MSTU(70))=N 
10362       ENDIF 
10363       MINT(83)=N    
10364       MINT(84)=N+MSTP(126)  
10365   190 CONTINUE  
10366     
10367 C...Information on overlayed events.    
10368       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN    
10369         PARI(91)=VINT(132)  
10370         PARI(92)=VINT(133)  
10371         PARI(93)=VINT(134)  
10372         IF(MSTP(133).EQ.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)    
10373       ENDIF 
10374     
10375 C...Transform to the desired coordinate frame.  
10376   200 CALL PYFRAM(MSTP(124))    
10377     
10378       RETURN    
10379       END   
10380     
10381 C***********************************************************************    
10382     
10383       SUBROUTINE PYSTAT(MSTAT)  
10384     
10385 C...Prints out information about cross-sections, decay widths, branching    
10386 C...ratios, kinematical limits, status codes and parameter values.  
10387       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10388       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
10389       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
10390       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
10391       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10392       COMMON/PYINT1/MINT(400),VINT(400) 
10393       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
10394       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
10395       COMMON/PYINT6/PROC(0:200) 
10396       CHARACTER PROC*28 
10397       CHARACTER CHAU*16,CHPA(-40:40)*12,CHIN(2)*12, 
10398      &STATE(-1:5)*4,CHKIN(21)*18    
10399       SAVE
10400       DATA STATE/'----','off ','on  ','on/+','on/-','on/1','on/2'/, 
10401      &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',  
10402      &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',   
10403      &'     y*_small     ','    eta*_large    ','    eta*_small    ',   
10404      &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',   
10405      &'       x_2        ','       x_F        ',' cos(theta_hard)  ',   
10406      &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',  
10407      &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',   
10408      &'       tau''       '/    
10409     
10410 C...Cross-sections. 
10411       IF(MSTAT.LE.1) THEN   
10412         WRITE(MSTU(11),1000)    
10413         WRITE(MSTU(11),1100)    
10414         WRITE(MSTU(11),1200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)    
10415         DO 100 I=1,200  
10416         IF(MSUB(I).NE.1) GOTO 100   
10417         WRITE(MSTU(11),1200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)    
10418   100   CONTINUE    
10419         WRITE(MSTU(11),1300) 1.-FLOAT(NGEN(0,3))/   
10420      &  MAX(1.,FLOAT(NGEN(0,2)))    
10421     
10422 C...Decay widths and branching ratios.  
10423       ELSEIF(MSTAT.EQ.2) THEN   
10424         DO 110 KF=-40,40    
10425         CALL LUNAME(KF,CHAU)    
10426   110   CHPA(KF)=CHAU(1:12) 
10427         WRITE(MSTU(11),1400)    
10428         WRITE(MSTU(11),1500)    
10429 C...Off-shell branchings.   
10430         DO 130 I=1,17   
10431         KC=I    
10432         IF(I.GE.9) KC=I+2   
10433         IF(I.EQ.17) KC=21   
10434         WRITE(MSTU(11),1600) CHPA(KC),0.,0.,STATE(MDCY(KC,1)),0.    
10435         DO 120 J=1,MDCY(KC,3)   
10436         IDC=J+MDCY(KC,2)-1  
10437   120   IF(MDME(IDC,2).EQ.102) WRITE(MSTU(11),1700) CHPA(KFDP(IDC,1)),  
10438      &  CHPA(KFDP(IDC,2)),0.,0.,STATE(MDME(IDC,1)),0.   
10439   130   CONTINUE    
10440 C...On-shell decays.    
10441         DO 150 I=1,6    
10442         KC=I+22 
10443         IF(I.EQ.4) KC=32    
10444         IF(I.EQ.5) KC=37    
10445         IF(I.EQ.6) KC=40    
10446         IF(WIDE(KC,0).GT.0.) THEN   
10447           WRITE(MSTU(11),1600) CHPA(KC),WIDP(KC,0),1.,  
10448      &    STATE(MDCY(KC,1)),1.  
10449           DO 140 J=1,MDCY(KC,3) 
10450           IDC=J+MDCY(KC,2)-1    
10451   140     WRITE(MSTU(11),1700) CHPA(KFDP(IDC,1)),CHPA(KFDP(IDC,2)), 
10452      &    WIDP(KC,J),WIDP(KC,J)/WIDP(KC,0),STATE(MDME(IDC,1)),  
10453      &    WIDE(KC,J)/WIDE(KC,0) 
10454         ELSE    
10455           WRITE(MSTU(11),1600) CHPA(KC),WIDP(KC,0),1.,  
10456      &    STATE(MDCY(KC,1)),0.  
10457         ENDIF   
10458   150   CONTINUE    
10459         WRITE(MSTU(11),1800)    
10460     
10461 C...Allowed incoming partons/particles at hard interaction. 
10462       ELSEIF(MSTAT.EQ.3) THEN   
10463         WRITE(MSTU(11),1900)    
10464         CALL LUNAME(MINT(11),CHAU)  
10465         CHIN(1)=CHAU(1:12)  
10466         CALL LUNAME(MINT(12),CHAU)  
10467         CHIN(2)=CHAU(1:12)  
10468         WRITE(MSTU(11),2000) CHIN(1),CHIN(2)    
10469         DO 160 KF=-40,40    
10470         CALL LUNAME(KF,CHAU)    
10471   160   CHPA(KF)=CHAU(1:12) 
10472         IF(MINT(43).EQ.1) THEN  
10473           WRITE(MSTU(11),2100) CHPA(MINT(11)),STATE(KFIN(1,MINT(11))),  
10474      &    CHPA(MINT(12)),STATE(KFIN(2,MINT(12)))    
10475         ELSEIF(MINT(43).EQ.2) THEN  
10476           WRITE(MSTU(11),2100) CHPA(MINT(11)),STATE(KFIN(1,MINT(11))),  
10477      &    CHPA(-MSTP(54)),STATE(KFIN(2,-MSTP(54)))  
10478           DO 170 I=-MSTP(54)+1,-1   
10479   170     WRITE(MSTU(11),2200) CHPA(I),STATE(KFIN(2,I)) 
10480           DO 180 I=1,MSTP(54)   
10481   180     WRITE(MSTU(11),2200) CHPA(I),STATE(KFIN(2,I)) 
10482           WRITE(MSTU(11),2200) CHPA(21),STATE(KFIN(2,21))   
10483         ELSEIF(MINT(43).EQ.3) THEN  
10484           WRITE(MSTU(11),2100) CHPA(-MSTP(54)),STATE(KFIN(1,-MSTP(54))),    
10485      &    CHPA(MINT(12)),STATE(KFIN(2,MINT(12)))    
10486           DO 190 I=-MSTP(54)+1,-1   
10487   190     WRITE(MSTU(11),2300) CHPA(I),STATE(KFIN(1,I)) 
10488           DO 200 I=1,MSTP(54)   
10489   200     WRITE(MSTU(11),2300) CHPA(I),STATE(KFIN(1,I)) 
10490           WRITE(MSTU(11),2300) CHPA(21),STATE(KFIN(1,21))   
10491         ELSEIF(MINT(43).EQ.4) THEN  
10492           DO 210 I=-MSTP(54),-1 
10493   210     WRITE(MSTU(11),2100) CHPA(I),STATE(KFIN(1,I)),CHPA(I),    
10494      &    STATE(KFIN(2,I))  
10495           DO 220 I=1,MSTP(54)   
10496   220     WRITE(MSTU(11),2100) CHPA(I),STATE(KFIN(1,I)),CHPA(I),    
10497      &    STATE(KFIN(2,I))  
10498           WRITE(MSTU(11),2100) CHPA(21),STATE(KFIN(1,21)),CHPA(21), 
10499      &    STATE(KFIN(2,21)) 
10500         ENDIF   
10501         WRITE(MSTU(11),2400)    
10502     
10503 C...User-defined and derived limits on kinematical variables.   
10504       ELSEIF(MSTAT.EQ.4) THEN   
10505         WRITE(MSTU(11),2500)    
10506         WRITE(MSTU(11),2600)    
10507         SHRMAX=CKIN(2)  
10508         IF(SHRMAX.LT.0.) SHRMAX=VINT(1) 
10509         WRITE(MSTU(11),2700) CKIN(1),CHKIN(1),SHRMAX    
10510         PTHMIN=MAX(CKIN(3),CKIN(5)) 
10511         PTHMAX=CKIN(4)  
10512         IF(PTHMAX.LT.0.) PTHMAX=0.5*SHRMAX  
10513         WRITE(MSTU(11),2800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX 
10514         WRITE(MSTU(11),2900) CHKIN(3),CKIN(6)   
10515         DO 230 I=4,14   
10516   230   WRITE(MSTU(11),2700) CKIN(2*I-1),CHKIN(I),CKIN(2*I) 
10517         SPRMAX=CKIN(32) 
10518         IF(SPRMAX.LT.0.) SPRMAX=VINT(1) 
10519         WRITE(MSTU(11),2700) CKIN(31),CHKIN(13),SPRMAX  
10520         WRITE(MSTU(11),3000)    
10521         WRITE(MSTU(11),3100)    
10522         WRITE(MSTU(11),2600)    
10523         DO 240 I=16,21  
10524   240   WRITE(MSTU(11),2700) VINT(I-5),CHKIN(I),VINT(I+15)  
10525         WRITE(MSTU(11),3000)    
10526     
10527 C...Status codes and parameter values.  
10528       ELSEIF(MSTAT.EQ.5) THEN   
10529         WRITE(MSTU(11),3200)    
10530         WRITE(MSTU(11),3300)    
10531         DO 250 I=1,100  
10532   250   WRITE(MSTU(11),3400) I,MSTP(I),PARP(I),100+I,MSTP(100+I),   
10533      &  PARP(100+I) 
10534       ENDIF 
10535     
10536 C...Formats for printouts.  
10537  1000 FORMAT('1',9('*'),1X,'PYSTAT:  Statistics on Number of ', 
10538      &'Events and Cross-sections',1X,9('*'))    
10539  1100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X, 
10540      &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,  
10541      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),    
10542      &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,    
10543      &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X, 
10544      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X, 
10545      &'I',12X,'I')  
10546  1200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P, 
10547      &E10.3,1X,'I') 
10548  1300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//    
10549      &1X,'********* Fraction of events that fail fragmentation ',   
10550      &'cuts =',1X,F8.5,' *********'/)   
10551  1400 FORMAT('1',17('*'),1X,'PYSTAT:  Decay Widths and Branching ', 
10552      &'Ratios',1X,17('*'))  
10553  1500 FORMAT(/1X,78('=')/1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ 
10554      &1X,'I',1X,'Branching/Decay Channel',5X,'I',1X,'Width (GeV)',1X,   
10555      &'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,'Eff. B.R.',1X,'I'/1X,   
10556      &'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,78('='))    
10557  1600 FORMAT(1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,   
10558      &A12,1X,'->',13X,'I',2X,1P,E10.3,0P,1X,'I',1X,1P,E10.3,0P,1X,'I',  
10559      &1X,A4,1X,'I',1X,1P,E10.3,0P,1X,'I')   
10560  1700 FORMAT(1X,'I',1X,A12,1X,'+',1X,A12,1X,'I',2X,1P,E10.3,0P,1X,'I',  
10561      &1X,1P,E10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,E10.3,0P,1X,'I') 
10562  1800 FORMAT(1X,'I',29X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,78('='))  
10563  1900 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/', 
10564      &'Particles at Hard Interaction',1X,7('*'))    
10565  2000 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,  
10566      &'Beam particle:',1X,A,10X,'I',1X,'Target particle:',1X,A,7X,  
10567      &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',9X,'State',16X,    
10568      &'I',1X,'Content',9X,'State',15X,'I'/1X,'I',38X,'I',37X,'I'/1X,    
10569      &78('=')/1X,'I',38X,'I',37X,'I')   
10570  2100 FORMAT(1X,'I',1X,A,5X,A,16X,'I',1X,A,5X,A,15X,'I')    
10571  2200 FORMAT(1X,'I',38X,'I',1X,A,5X,A,15X,'I')  
10572  2300 FORMAT(1X,'I',1X,A,5X,A,16X,'I',37X,'I')  
10573  2400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('=')) 
10574  2500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',  
10575      &'Kinematical Variables',1X,12('*'))   
10576  2600 FORMAT(/1X,78('=')/1X,'I',76X,'I')    
10577  2700 FORMAT(1X,'I',16X,1P,E10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,E10.3,0P,  
10578      &16X,'I')  
10579  2800 FORMAT(1X,'I',3X,1P,E10.3,0P,1X,'(',1P,E10.3,0P,')',1X,'<',1X,A,  
10580      &1X,'<',1X,1P,E10.3,0P,16X,'I')    
10581  2900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,E10.3,0P,16X,'I')    
10582  3000 FORMAT(1X,'I',76X,'I'/1X,78('=')) 
10583  3100 FORMAT(////1X,5('*'),1X,'PYSTAT: Derived Limits on Kinematical ', 
10584      &'Variables Used in Generation',1X,5('*')) 
10585  3200 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ', 
10586      &'Parameter Values',1X,12('*'))    
10587  3300 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X, 
10588      &'PARP(I)'/)   
10589  3400 FORMAT(1X,I3,5X,I6,6X,1P,E10.3,0P,18X,I3,5X,I6,6X,1P,E10.3)   
10590     
10591       RETURN    
10592       END   
10593     
10594 C*********************************************************************  
10595     
10596       SUBROUTINE PYINKI(CHFRAM,CHBEAM,CHTARG,WIN)   
10597     
10598 C...Identifies the two incoming particles and sets up kinematics,   
10599 C...including rotations and boosts to/from CM frame.    
10600       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10601       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10602       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
10603       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10604       COMMON/PYINT1/MINT(400),VINT(400) 
10605       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,  
10606      &CHIDNT(3)*8,CHTEMP*8,CHCDE(18)*8,CHINIT*76    
10607       DIMENSION LEN(3),KCDE(18) 
10608       SAVE
10609       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',  
10610      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
10611       DATA CHCDE/'e-      ','e+      ','nue     ','nue~    ',   
10612      &'mu-     ','mu+     ','numu    ','numu~   ','tau-    ',   
10613      &'tau+    ','nutau   ','nutau~  ','pi+     ','pi-     ',   
10614      &'n       ','n~      ','p       ','p~      '/  
10615       DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,  
10616      &211,-211,2112,-2112,2212,-2212/   
10617     
10618 C...Convert character variables to lowercase and find their length. 
10619       CHCOM(1)=CHFRAM   
10620       CHCOM(2)=CHBEAM   
10621       CHCOM(3)=CHTARG   
10622       DO 120 I=1,3  
10623       LEN(I)=8  
10624       DO 100 LL=8,1,-1  
10625       IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1   
10626       DO 100 LA=1,26    
10627   100 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=   
10628      &CHALP(1)(LA:LA)   
10629       CHIDNT(I)=CHCOM(I)    
10630       DO 110 LL=1,6 
10631       IF(CHIDNT(I)(LL:LL+2).EQ.'bar') THEN  
10632         CHTEMP=CHIDNT(I)    
10633         CHIDNT(I)=CHTEMP(1:LL-1)//'~'//CHTEMP(LL+3:8)//'  ' 
10634       ENDIF 
10635   110 CONTINUE  
10636       DO 120 LL=1,8 
10637       IF(CHIDNT(I)(LL:LL).EQ.'_') THEN  
10638         CHTEMP=CHIDNT(I)    
10639         CHIDNT(I)=CHTEMP(1:LL-1)//CHTEMP(LL+1:8)//' '   
10640       ENDIF 
10641   120 CONTINUE  
10642     
10643 C...Set initial state. Error for unknown codes. Reset variables.    
10644       N=2   
10645       DO 140 I=1,2  
10646       K(I,2)=0  
10647       DO 130 J=1,18 
10648   130 IF(CHIDNT(I+1).EQ.CHCDE(J)) K(I,2)=KCDE(J)    
10649       P(I,5)=ULMASS(K(I,2)) 
10650       MINT(40+I)=1  
10651       IF(IABS(K(I,2)).GT.100) MINT(40+I)=2  
10652       DO 140 J=1,5  
10653   140 V(I,J)=0. 
10654       IF(K(1,2).EQ.0) WRITE(MSTU(11),1000) CHBEAM(1:LEN(2)) 
10655       IF(K(2,2).EQ.0) WRITE(MSTU(11),1100) CHTARG(1:LEN(3)) 
10656       IF(K(1,2).EQ.0.OR.K(2,2).EQ.0) STOP   
10657       DO 150 J=6,10 
10658   150 VINT(J)=0.    
10659       CHINIT=' '    
10660     
10661 C...Set up kinematics for events defined in CM frame.   
10662       IF(CHCOM(1)(1:2).EQ.'cm') THEN    
10663         IF(CHCOM(2)(1:1).NE.'e') THEN   
10664           LOFFS=(34-(LEN(2)+LEN(3)))/2  
10665           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//  
10666      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' ' 
10667         ELSE    
10668           LOFFS=(33-(LEN(2)+LEN(3)))/2  
10669           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '// 
10670      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' ' 
10671         ENDIF   
10672 C        WRITE(MSTU(11),1200) CHINIT 
10673 C        WRITE(MSTU(11),1300) WIN    
10674         S=WIN**2    
10675         P(1,1)=0.   
10676         P(1,2)=0.   
10677         P(2,1)=0.   
10678         P(2,2)=0.   
10679         P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2.*P(1,5)*P(2,5))**2)/ 
10680      &  (4.*S)) 
10681         P(2,3)=-P(1,3)  
10682         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)    
10683         P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)    
10684     
10685 C...Set up kinematics for fixed target events.  
10686       ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN   
10687         LOFFS=(29-(LEN(2)+LEN(3)))/2    
10688         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//  
10689      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//    
10690      &  ' fixed target'//' '    
10691 C        WRITE(MSTU(11),1200) CHINIT 
10692 C        WRITE(MSTU(11),1400) WIN    
10693         P(1,1)=0.   
10694         P(1,2)=0.   
10695         P(2,1)=0.   
10696         P(2,2)=0.   
10697         P(1,3)=WIN  
10698         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)    
10699         P(2,3)=0.   
10700         P(2,4)=P(2,5)   
10701         S=P(1,5)**2+P(2,5)**2+2.*P(2,4)*P(1,4)  
10702         VINT(10)=P(1,3)/(P(1,4)+P(2,4)) 
10703         CALL LUROBO(0.,0.,0.,0.,-VINT(10))  
10704 C        WRITE(MSTU(11),1500) SQRT(S)    
10705     
10706 C...Set up kinematics for events in user-defined frame. 
10707       ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN   
10708         LOFFS=(13-(LEN(1)+LEN(2)))/2    
10709         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//  
10710      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//    
10711      &  'user-specified configuration'//' ' 
10712 C        WRITE(MSTU(11),1200) CHINIT 
10713 C        WRITE(MSTU(11),1600)    
10714 C        WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)  
10715 C        WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)  
10716         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)    
10717         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)    
10718         DO 160 J=1,3    
10719   160   VINT(7+J)=(DBLE(P(1,J))+DBLE(P(2,J)))/DBLE(P(1,4)+P(2,4))   
10720         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))  
10721         VINT(7)=ULANGL(P(1,1),P(1,2))   
10722         CALL LUROBO(0.,-VINT(7),0.,0.,0.)   
10723         VINT(6)=ULANGL(P(1,3),P(1,1))   
10724         CALL LUROBO(-VINT(6),0.,0.,0.,0.)   
10725         S=P(1,5)**2+P(2,5)**2+2.*(P(1,4)*P(2,4)-P(1,3)*P(2,3))  
10726 C        WRITE(MSTU(11),1500) SQRT(S)    
10727     
10728 C...Unknown frame. Error for too low CM energy. 
10729       ELSE  
10730         WRITE(MSTU(11),1800) CHFRAM(1:LEN(1))   
10731         STOP    
10732       ENDIF 
10733       IF(S.LT.PARP(2)**2) THEN  
10734         WRITE(MSTU(11),1900) SQRT(S)    
10735         STOP    
10736       ENDIF 
10737     
10738 C...Save information on incoming particles. 
10739       MINT(11)=K(1,2)   
10740       MINT(12)=K(2,2)   
10741       MINT(43)=2*MINT(41)+MINT(42)-2    
10742       VINT(1)=SQRT(S)   
10743       VINT(2)=S 
10744       VINT(3)=P(1,5)    
10745       VINT(4)=P(2,5)    
10746       VINT(5)=P(1,3)    
10747     
10748 C...Store constants to be used in generation.   
10749       IF(MSTP(82).LE.1) VINT(149)=4.*PARP(81)**2/S  
10750       IF(MSTP(82).GE.2) VINT(149)=4.*PARP(82)**2/S  
10751     
10752 C...Formats for initialization and error information.   
10753  1000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''.'/ 
10754      &1X,'Execution stopped!')  
10755  1100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''.'/   
10756      &1X,'Execution stopped!')  
10757 C 1200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') 
10758 C 1300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',   
10759 C     &19X,'I'/1X,'I',76X,'I'/1X,78('='))    
10760 C 1400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')  
10761 C 1500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,  
10762 C     &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))    
10763 C 1600 FORMAT(1X,'I',76X,'I'/1X,'I',24X,'px (GeV/c)',3X,'py (GeV/c)',3X, 
10764 C     &'pz (GeV/c)',16X,'I') 
10765 C 1700 FORMAT(1X,'I',15X,A8,3(2X,F10.3,1X),15X,'I')  
10766  1800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''.'/  
10767      &1X,'Execution stopped!')  
10768  1900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ', 
10769      &'generation.'/1X,'Execution stopped!')    
10770     
10771       RETURN    
10772       END   
10773     
10774 C*********************************************************************  
10775     
10776       SUBROUTINE PYINRE 
10777     
10778 C...Calculates full and effective widths of guage bosons, stores masses 
10779 C...and widths, rescales coefficients to be used for resonance  
10780 C...production generation.  
10781       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10782       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
10783       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
10784       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
10785       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10786       COMMON/PYINT1/MINT(400),VINT(400) 
10787       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
10788       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
10789       COMMON/PYINT6/PROC(0:200) 
10790       CHARACTER PROC*28 
10791       DIMENSION WDTP(0:40),WDTE(0:40,0:5)   
10792       SAVE
10793     
10794 C...Calculate full and effective widths of gauge bosons.    
10795       AEM=PARU(101) 
10796       XW=PARU(102)  
10797       DO 100 I=21,40    
10798       DO 100 J=0,40 
10799       WIDP(I,J)=0.  
10800   100 WIDE(I,J)=0.  
10801     
10802 C...W+/-:   
10803       WMAS=PMAS(24,1)   
10804       WFAC=AEM/(24.*XW)*WMAS    
10805       CALL PYWIDT(24,WMAS,WDTP,WDTE)    
10806       WIDS(24,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+  
10807      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+  
10808      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
10809       WIDS(24,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
10810       WIDS(24,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)    
10811       DO 110 I=0,40 
10812       WIDP(24,I)=WFAC*WDTP(I)   
10813   110 WIDE(24,I)=WFAC*WDTE(I,0) 
10814     
10815 C...H+/-:   
10816       HCMAS=PMAS(37,1)  
10817       HCFAC=AEM/(8.*XW)*(HCMAS/WMAS)**2*HCMAS   
10818       CALL PYWIDT(37,HCMAS,WDTP,WDTE)   
10819       WIDS(37,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+  
10820      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+  
10821      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
10822       WIDS(37,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
10823       WIDS(37,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)    
10824       DO 120 I=0,40 
10825       WIDP(37,I)=HCFAC*WDTP(I)  
10826   120 WIDE(37,I)=HCFAC*WDTE(I,0)    
10827     
10828 C...Z0: 
10829       ZMAS=PMAS(23,1)   
10830       ZFAC=AEM/(48.*XW*(1.-XW))*ZMAS    
10831       CALL PYWIDT(23,ZMAS,WDTP,WDTE)    
10832       WIDS(23,1)=((WDTE(0,1)+WDTE(0,2))**2+ 
10833      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+   
10834      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
10835       WIDS(23,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
10836       WIDS(23,3)=0. 
10837       DO 130 I=0,40 
10838       WIDP(23,I)=ZFAC*WDTP(I)   
10839   130 WIDE(23,I)=ZFAC*WDTE(I,0) 
10840     
10841 C...H0: 
10842       HMAS=PMAS(25,1)   
10843       HFAC=AEM/(8.*XW)*(HMAS/WMAS)**2*HMAS  
10844       CALL PYWIDT(25,HMAS,WDTP,WDTE)    
10845       WIDS(25,1)=((WDTE(0,1)+WDTE(0,2))**2+ 
10846      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+   
10847      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
10848       WIDS(25,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
10849       WIDS(25,3)=0. 
10850       DO 140 I=0,40 
10851       WIDP(25,I)=HFAC*WDTP(I)   
10852   140 WIDE(25,I)=HFAC*WDTE(I,0) 
10853     
10854 C...Z'0:    
10855       ZPMAS=PMAS(32,1)  
10856       ZPFAC=AEM/(48.*XW*(1.-XW))*ZPMAS  
10857       CALL PYWIDT(32,ZPMAS,WDTP,WDTE)   
10858       WIDS(32,1)=((WDTE(0,1)+WDTE(0,2)+WDTE(0,3))**2+   
10859      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+   
10860      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
10861       WIDS(32,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
10862       WIDS(32,3)=0. 
10863       DO 150 I=0,40 
10864       WIDP(32,I)=ZPFAC*WDTP(I)  
10865   150 WIDE(32,I)=ZPFAC*WDTE(I,0)    
10866     
10867 C...R:  
10868       RMAS=PMAS(40,1)   
10869       RFAC=0.08*RMAS/((MSTP(1)-1)*(1.+6.*(1.+ULALPS(RMAS**2)/PARU(1)))) 
10870       CALL PYWIDT(40,RMAS,WDTP,WDTE)    
10871       WIDS(40,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+  
10872      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+  
10873      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
10874       WIDS(40,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
10875       WIDS(40,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)    
10876       DO 160 I=0,40 
10877       WIDP(40,I)=WFAC*WDTP(I)   
10878   160 WIDE(40,I)=WFAC*WDTE(I,0) 
10879     
10880 C...Q:  
10881       KFLQM=1   
10882       DO 170 I=1,MIN(8,MDCY(21,3))  
10883       IDC=I+MDCY(21,2)-1    
10884       IF(MDME(IDC,1).LE.0) GOTO 170 
10885       KFLQM=I   
10886   170 CONTINUE  
10887       MINT(46)=KFLQM    
10888       KFPR(81,1)=KFLQM  
10889       KFPR(81,2)=KFLQM  
10890       KFPR(82,1)=KFLQM  
10891       KFPR(82,2)=KFLQM  
10892     
10893 C...Set resonance widths and branching ratios in JETSET.    
10894       DO 180 I=1,6  
10895       IF(I.LE.3) KC=I+22    
10896       IF(I.EQ.4) KC=32  
10897       IF(I.EQ.5) KC=37  
10898       IF(I.EQ.6) KC=40  
10899       PMAS(KC,2)=WIDP(KC,0) 
10900       PMAS(KC,3)=MIN(0.9*PMAS(KC,1),10.*PMAS(KC,2)) 
10901       DO 180 J=1,MDCY(KC,3) 
10902       IDC=J+MDCY(KC,2)-1    
10903       BRAT(IDC)=WIDE(KC,J)/WIDE(KC,0)   
10904   180 CONTINUE  
10905     
10906 C...Special cases in treatment of gamma*/Z0: redefine process name. 
10907       IF(MSTP(43).EQ.1) THEN    
10908         PROC(1)='f + fb -> gamma*'  
10909       ELSEIF(MSTP(43).EQ.2) THEN    
10910         PROC(1)='f + fb -> Z0'  
10911       ELSEIF(MSTP(43).EQ.3) THEN    
10912         PROC(1)='f + fb -> gamma*/Z0'   
10913       ENDIF 
10914     
10915 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. 
10916       IF(MSTP(44).EQ.1) THEN    
10917         PROC(141)='f + fb -> gamma*'    
10918       ELSEIF(MSTP(44).EQ.2) THEN    
10919         PROC(141)='f + fb -> Z0'    
10920       ELSEIF(MSTP(44).EQ.3) THEN    
10921         PROC(141)='f + fb -> Z''0'  
10922       ELSEIF(MSTP(44).EQ.4) THEN    
10923         PROC(141)='f + fb -> gamma*/Z0' 
10924       ELSEIF(MSTP(44).EQ.5) THEN    
10925         PROC(141)='f + fb -> gamma*/Z''0'   
10926       ELSEIF(MSTP(44).EQ.6) THEN    
10927         PROC(141)='f + fb -> Z0/Z''0'   
10928       ELSEIF(MSTP(44).EQ.7) THEN    
10929         PROC(141)='f + fb -> gamma*/Z0/Z''0'    
10930       ENDIF 
10931     
10932       RETURN    
10933       END   
10934     
10935 C*********************************************************************  
10936     
10937       SUBROUTINE PYXTOT 
10938     
10939 C...Parametrizes total, double diffractive, single diffractive and  
10940 C...elastic cross-sections for different energies and beams.    
10941       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10942       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10943       COMMON/PYINT1/MINT(400),VINT(400) 
10944       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
10945       DIMENSION BCS(5,8),BCB(2,5),BCC(3)    
10946       SAVE
10947    
10948 C...The following data lines are coefficients needed in the 
10949 C...Block, Cahn parametrization of total cross-section and nuclear  
10950 C...slope parameter; see below. 
10951       DATA ((BCS(I,J),J=1,8),I=1,5)/    
10952      1 41.74, 0.66, 0.0000, 337.,  0.0, 0.0, -39.3, 0.48,   
10953      2 41.66, 0.60, 0.0000, 306.,  0.0, 0.0, -34.6, 0.51,   
10954      3 41.36, 0.63, 0.0000, 299.,  7.3, 0.5, -40.4, 0.47,   
10955      4 41.68, 0.63, 0.0083, 330.,  0.0, 0.0, -39.0, 0.48,   
10956      5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/   
10957       DATA ((BCB(I,J),J=1,5),I=1,2)/    
10958      1 10.79, -0.049, 0.040, 21.5, 1.23,    
10959      2  9.92, -0.027, 0.013, 18.9, 1.07/    
10960       DATA BCC/2.0164346,-0.5590311,0.0376279/  
10961     
10962 C...Total cross-section and nuclear slope parameter for pp and p-pbar   
10963       NFIT=MIN(5,MAX(1,MSTP(31)))   
10964       SIGP=BCS(NFIT,1)+BCS(NFIT,2)*(-0.25*PARU(1)**2*   
10965      &(1.-0.25*BCS(NFIT,3)*PARU(1)**2)+(1.+0.5*BCS(NFIT,3)*PARU(1)**2)* 
10966      &(LOG(VINT(2)/BCS(NFIT,4)))**2+BCS(NFIT,3)*    
10967      &(LOG(VINT(2)/BCS(NFIT,4)))**4)/   
10968      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*  
10969      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)*(LOG(VINT(2)/BCS(NFIT,4)))**2+   
10970      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)+BCS(NFIT,5)*    
10971      &VINT(2)**(BCS(NFIT,6)-1.)*SIN(0.5*PARU(1)*BCS(NFIT,6))    
10972       SIGM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*  
10973      &COS(0.5*PARU(1)*BCS(NFIT,8))  
10974       REFP=BCS(NFIT,2)*PARU(1)*LOG(VINT(2)/BCS(NFIT,4))/    
10975      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*  
10976      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)+(LOG(VINT(2)/BCS(NFIT,4)))**2+   
10977      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)-BCS(NFIT,5)*    
10978      &VINT(2)**(BCS(NFIT,6)-1.)*COS(0.5*PARU(1)*BCS(NFIT,6))    
10979       REFM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*  
10980      &SIN(0.5*PARU(1)*BCS(NFIT,8))  
10981       SIGMA=SIGP-ISIGN(1,MINT(11)*MINT(12))*SIGM    
10982       RHO=(REFP-ISIGN(1,MINT(11)*MINT(12))*REFM)/SIGMA  
10983     
10984 C...Nuclear slope parameter B, curvature C: 
10985       NFIT=1    
10986       IF(MSTP(31).GE.4) NFIT=2  
10987       BP=BCB(NFIT,1)+BCB(NFIT,2)*LOG(VINT(2))+  
10988      &BCB(NFIT,3)*(LOG(VINT(2)))**2 
10989       BM=BCB(NFIT,4)+BCB(NFIT,5)*LOG(VINT(2))   
10990       B=BP-ISIGN(1,MINT(11)*MINT(12))*SIGM/SIGP*(BM-BP) 
10991       VINT(121)=B   
10992       C=-0.5*BCC(2)/BCC(3)*(1.-SQRT(MAX(0.,1.+4.*BCC(3)/BCC(2)**2*  
10993      &(1.E-03*VINT(1)-BCC(1)))))    
10994       VINT(122)=C   
10995     
10996 C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).   
10997       SIGEL=SIGMA**2*(1.+RHO**2)/(16.*PARU(1)*PARU(5)*B)    
10998     
10999 C...Single diffractive scattering cross-section from Goulianos: 
11000       SIGSD=2.*0.68*(1.+36./VINT(2))*LOG(0.6+0.1*VINT(2))   
11001     
11002 C...Double diffractive scattering cross-section (essentially fixed by   
11003 C...sigma-sd and sigma-el). 
11004       SIGDD=SIGSD**2/(3.*SIGEL) 
11005     
11006 C...Total non-elastic, non-diffractive cross-section.   
11007       SIGND=SIGMA-SIGDD-SIGSD-SIGEL 
11008     
11009 C...Rescale for pions.  
11010       IF(IABS(MINT(11)).EQ.211.AND.IABS(MINT(12)).EQ.211) THEN  
11011         SIGMA=4./9.*SIGMA   
11012         SIGDD=4./9.*SIGDD   
11013         SIGSD=4./9.*SIGSD   
11014         SIGEL=4./9.*SIGEL   
11015         SIGND=4./9.*SIGND   
11016       ELSEIF(IABS(MINT(11)).EQ.211.OR.IABS(MINT(12)).EQ.211) THEN   
11017         SIGMA=2./3.*SIGMA   
11018         SIGDD=2./3.*SIGDD   
11019         SIGSD=2./3.*SIGSD   
11020         SIGEL=2./3.*SIGEL   
11021         SIGND=2./3.*SIGND   
11022       ENDIF 
11023     
11024 C...Save cross-sections in common block PYPARA. 
11025       VINT(101)=SIGMA   
11026       VINT(102)=SIGEL   
11027       VINT(103)=SIGSD   
11028       VINT(104)=SIGDD   
11029       VINT(106)=SIGND   
11030       XSEC(95,1)=SIGND  
11031     
11032       RETURN    
11033       END   
11034     
11035 C*********************************************************************  
11036     
11037       SUBROUTINE PYMAXI 
11038     
11039 C...Finds optimal set of coefficients for kinematical variable selection    
11040 C...and the maximum of the part of the differential cross-section used  
11041 C...in the event weighting. 
11042       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
11043       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
11044       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
11045       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
11046       COMMON/PYINT1/MINT(400),VINT(400) 
11047       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
11048       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
11049       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
11050       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
11051       COMMON/PYINT6/PROC(0:200) 
11052       CHARACTER PROC*28 
11053       CHARACTER CVAR(4)*4   
11054       DIMENSION NPTS(4),MVARPT(200,4),VINTPT(200,30),SIGSPT(200),   
11055      &NAREL(6),WTREL(6),WTMAT(6,6),COEFU(6),IACCMX(4),SIGSMX(4),    
11056      &SIGSSM(3) 
11057       SAVE
11058       DATA CVAR/'tau ','tau''','y*  ','cth '/   
11059     
11060 C...Select subprocess to study: skip cases not applicable.  
11061       VINT(143)=1.  
11062       VINT(144)=1.  
11063       XSEC(0,1)=0.  
11064       DO 350 ISUB=1,200 
11065       IF(ISUB.GE.91.AND.ISUB.LE.95) THEN    
11066         XSEC(ISUB,1)=VINT(ISUB+11)  
11067         IF(MSUB(ISUB).NE.1) GOTO 350    
11068         GOTO 340    
11069       ELSEIF(ISUB.EQ.96) THEN   
11070         IF(MINT(43).NE.4) GOTO 350  
11071         IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0) GOTO 350 
11072       ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.   
11073      &ISUB.EQ.53.OR.ISUB.EQ.68) THEN    
11074         IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 350   
11075       ELSE  
11076         IF(MSUB(ISUB).NE.1) GOTO 350    
11077       ENDIF 
11078       MINT(1)=ISUB  
11079       ISTSB=ISET(ISUB)  
11080       IF(ISUB.EQ.96) ISTSB=2    
11081       IF(MSTP(122).GE.2) WRITE(MSTU(11),1000) ISUB  
11082     
11083 C...Find resonances (explicit or implicit in cross-section).    
11084       MINT(72)=0    
11085       KFR1=0    
11086       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3) THEN 
11087         KFR1=KFPR(ISUB,1)   
11088       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN    
11089         KFR1=25 
11090       ENDIF 
11091       IF(KFR1.NE.0) THEN    
11092         TAUR1=PMAS(KFR1,1)**2/VINT(2)   
11093         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2) 
11094         MINT(72)=1  
11095         MINT(73)=KFR1   
11096         VINT(73)=TAUR1  
11097         VINT(74)=GAMR1  
11098       ENDIF 
11099       IF(ISUB.EQ.141) THEN  
11100         KFR2=23 
11101         TAUR2=PMAS(KFR2,1)**2/VINT(2)   
11102         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2) 
11103         MINT(72)=2  
11104         MINT(74)=KFR2   
11105         VINT(75)=TAUR2  
11106         VINT(76)=GAMR2  
11107       ENDIF 
11108     
11109 C...Find product masses and minimum pT of process.  
11110       SQM3=0.   
11111       SQM4=0.   
11112       MINT(71)=0    
11113       VINT(71)=CKIN(3)  
11114       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
11115         IF(KFPR(ISUB,1).NE.0) SQM3=PMAS(KFPR(ISUB,1),1)**2  
11116         IF(KFPR(ISUB,2).NE.0) SQM4=PMAS(KFPR(ISUB,2),1)**2  
11117         IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1 
11118         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) 
11119         IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)  
11120         IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08*PARP(82) 
11121       ENDIF 
11122       VINT(63)=SQM3 
11123       VINT(64)=SQM4 
11124     
11125 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).  
11126       NPTS(1)=2+2*MINT(72)  
11127       IF(MINT(43).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) NPTS(1)=1    
11128       NPTS(2)=1 
11129       IF(MINT(43).GE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) NPTS(2)=2    
11130       NPTS(3)=1 
11131       IF(MINT(43).EQ.4) NPTS(3)=3   
11132       NPTS(4)=1 
11133       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5    
11134       NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)  
11135     
11136 C...Reset coefficients of cross-section weighting.  
11137       DO 100 J=1,20 
11138   100 COEF(ISUB,J)=0.   
11139       COEF(ISUB,1)=1.   
11140       COEF(ISUB,7)=0.5  
11141       COEF(ISUB,8)=0.5  
11142       COEF(ISUB,10)=1.  
11143       COEF(ISUB,15)=1.  
11144       MCTH=0    
11145       MTAUP=0   
11146       CTH=0.    
11147       TAUP=0.   
11148       SIGSAM=0. 
11149     
11150 C...Find limits and select tau, y*, cos(theta-hat) and tau' values, 
11151 C...in grid of phase space points.  
11152       CALL PYKLIM(1)    
11153       NACC=0    
11154       DO 120 ITRY=1,NTRY    
11155       IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN 
11156         MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))   
11157         CALL PYKMAP(1,MTAU,0.5) 
11158         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4) 
11159       ENDIF 
11160       IF((ISTSB.EQ.3.OR.ISTSB.EQ.4).AND.MOD(ITRY-1,NPTS(3)*NPTS(4)).    
11161      &EQ.0) THEN    
11162         MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2)) 
11163         CALL PYKMAP(4,MTAUP,0.5)    
11164       ENDIF 
11165       IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) CALL PYKLIM(2)   
11166       IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN 
11167         MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))    
11168         CALL PYKMAP(2,MYST,0.5) 
11169         CALL PYKLIM(3)  
11170       ENDIF 
11171       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
11172         MCTH=1+MOD(ITRY-1,NPTS(4))  
11173         CALL PYKMAP(3,MCTH,0.5) 
11174       ENDIF 
11175       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2) 
11176     
11177 C...Calculate and store cross-section.  
11178       MINT(51)=0    
11179       CALL PYKLIM(0)    
11180       IF(MINT(51).EQ.1) GOTO 120    
11181       NACC=NACC+1   
11182       MVARPT(NACC,1)=MTAU   
11183       MVARPT(NACC,2)=MTAUP  
11184       MVARPT(NACC,3)=MYST   
11185       MVARPT(NACC,4)=MCTH   
11186       DO 110 J=1,30 
11187   110 VINTPT(NACC,J)=VINT(10+J) 
11188       CALL PYSIGH(NCHN,SIGS)    
11189       SIGSPT(NACC)=SIGS 
11190       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS    
11191       IF(MSTP(122).GE.2) WRITE(MSTU(11),1100) MTAU,MTAUP,MYST,MCTH, 
11192      &VINT(21),VINT(22),VINT(23),VINT(26),SIGS  
11193   120 CONTINUE  
11194       IF(SIGSAM.EQ.0.) THEN 
11195         WRITE(MSTU(11),1200) ISUB   
11196         STOP    
11197       ENDIF 
11198     
11199 C...Calculate integrals in tau and y* over maximal phase space limits.  
11200       TAUMIN=VINT(11)   
11201       TAUMAX=VINT(31)   
11202       ATAU1=LOG(TAUMAX/TAUMIN)  
11203       ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN) 
11204       IF(NPTS(1).GE.3) THEN 
11205         ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1    
11206         ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/  
11207      &  GAMR1   
11208       ENDIF 
11209       IF(NPTS(1).GE.5) THEN 
11210         ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2    
11211         ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/  
11212      &  GAMR2   
11213       ENDIF 
11214       YSTMIN=0.5*LOG(TAUMIN)    
11215       YSTMAX=-YSTMIN    
11216       AYST0=YSTMAX-YSTMIN   
11217       AYST1=0.5*(YSTMAX-YSTMIN)**2  
11218       AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))    
11219     
11220 C...Reset. Sum up cross-sections in points calculated.  
11221       DO 230 IVAR=1,4   
11222       IF(NPTS(IVAR).EQ.1) GOTO 230  
11223       IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 230 
11224       NBIN=NPTS(IVAR)   
11225       DO 130 J1=1,NBIN  
11226       NAREL(J1)=0   
11227       WTREL(J1)=0.  
11228       COEFU(J1)=0.  
11229       DO 130 J2=1,NBIN  
11230   130 WTMAT(J1,J2)=0.   
11231       DO 140 IACC=1,NACC    
11232       IBIN=MVARPT(IACC,IVAR)    
11233       NAREL(IBIN)=NAREL(IBIN)+1 
11234       WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)  
11235     
11236 C...Sum up tau cross-section pieces in points used. 
11237       IF(IVAR.EQ.1) THEN    
11238         TAU=VINTPT(IACC,11) 
11239         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.  
11240         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU   
11241         IF(NBIN.GE.3) THEN  
11242           WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1) 
11243           WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/    
11244      &    ((TAU-TAUR1)**2+GAMR1**2) 
11245         ENDIF   
11246         IF(NBIN.GE.5) THEN  
11247           WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2) 
11248           WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/    
11249      &    ((TAU-TAUR2)**2+GAMR2**2) 
11250         ENDIF   
11251     
11252 C...Sum up tau' cross-section pieces in points used.    
11253       ELSEIF(IVAR.EQ.2) THEN    
11254         TAU=VINTPT(IACC,11) 
11255         TAUP=VINTPT(IACC,16)    
11256         TAUPMN=VINTPT(IACC,6)   
11257         TAUPMX=VINTPT(IACC,26)  
11258         ATAUP1=LOG(TAUPMX/TAUPMN)   
11259         ATAUP2=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU) 
11260         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.  
11261         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*(1.-TAU/TAUP)**3/   
11262      &  TAUP    
11263     
11264 C...Sum up y* and cos(theta-hat) cross-section pieces in points used.   
11265       ELSEIF(IVAR.EQ.3) THEN    
11266         YST=VINTPT(IACC,12) 
11267         WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)  
11268         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST1)*(YSTMAX-YST)  
11269         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST) 
11270       ELSE  
11271         RM34=2.*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2  
11272         RSQM=1.+RM34    
11273         CTHMAX=SQRT(1.-4.*VINT(71)**2/(TAUMAX*VINT(2))) 
11274         CTHMIN=-CTHMAX  
11275         IF(CTHMAX.GT.0.9999) RM34=MAX(RM34,2.*VINT(71)**2/  
11276      &  (TAUMAX*VINT(2)))   
11277         ACTH1=CTHMAX-CTHMIN 
11278         ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))  
11279         ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))  
11280         ACTH4=1./MAX(RM34,RSQM-CTHMAX)-1./MAX(RM34,RSQM-CTHMIN) 
11281         ACTH5=1./MAX(RM34,RSQM+CTHMIN)-1./MAX(RM34,RSQM+CTHMAX) 
11282         CTH=VINTPT(IACC,13) 
11283         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.  
11284         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/MAX(RM34,RSQM-CTH)    
11285         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/MAX(RM34,RSQM+CTH)    
11286         WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/MAX(RM34,RSQM-CTH)**2 
11287         WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/MAX(RM34,RSQM+CTH)**2 
11288       ENDIF 
11289   140 CONTINUE  
11290     
11291 C...Check that equation system solvable; else trivial way out.  
11292       IF(MSTP(122).GE.2) WRITE(MSTU(11),1300) CVAR(IVAR)    
11293       MSOLV=1   
11294       DO 150 IBIN=1,NBIN    
11295       IF(MSTP(122).GE.2) WRITE(MSTU(11),1400) (WTMAT(IBIN,IRED),    
11296      &IRED=1,NBIN),WTREL(IBIN)  
11297   150 IF(NAREL(IBIN).EQ.0) MSOLV=0  
11298       IF(MSOLV.EQ.0) THEN   
11299         DO 160 IBIN=1,NBIN  
11300   160   COEFU(IBIN)=1.  
11301     
11302 C...Solve to find relative importance of cross-section pieces.  
11303       ELSE  
11304         DO 170 IRED=1,NBIN-1    
11305         DO 170 IBIN=IRED+1,NBIN 
11306         RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)   
11307         WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED) 
11308         DO 170 ICOE=IRED,NBIN   
11309   170   WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)  
11310         DO 190 IRED=NBIN,1,-1   
11311         DO 180 ICOE=IRED+1,NBIN 
11312   180   WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)    
11313   190   COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)    
11314       ENDIF 
11315     
11316 C...Normalize coefficients, with piece shared democratically.   
11317       COEFSU=0. 
11318       DO 200 IBIN=1,NBIN    
11319       COEFU(IBIN)=MAX(0.,COEFU(IBIN))   
11320   200 COEFSU=COEFSU+COEFU(IBIN) 
11321       IF(IVAR.EQ.1) IOFF=0  
11322       IF(IVAR.EQ.2) IOFF=14 
11323       IF(IVAR.EQ.3) IOFF=6  
11324       IF(IVAR.EQ.4) IOFF=9  
11325       IF(COEFSU.GT.0.) THEN 
11326         DO 210 IBIN=1,NBIN  
11327   210   COEF(ISUB,IOFF+IBIN)=PARP(121)/NBIN+(1.-PARP(121))*COEFU(IBIN)/ 
11328      &  COEFSU  
11329       ELSE  
11330         DO 220 IBIN=1,NBIN  
11331   220   COEF(ISUB,IOFF+IBIN)=1./NBIN    
11332       ENDIF 
11333       IF(MSTP(122).GE.2) WRITE(MSTU(11),1500) CVAR(IVAR),   
11334      &(COEF(ISUB,IOFF+IBIN),IBIN=1,NBIN)    
11335   230 CONTINUE  
11336     
11337 C...Find two most promising maxima among points previously determined.  
11338       DO 240 J=1,4  
11339       IACCMX(J)=0   
11340   240 SIGSMX(J)=0.  
11341       NMAX=0    
11342       DO 290 IACC=1,NACC    
11343       DO 250 J=1,30 
11344   250 VINT(10+J)=VINTPT(IACC,J) 
11345       CALL PYSIGH(NCHN,SIGS)    
11346       IEQ=0 
11347       DO 260 IMV=1,NMAX 
11348   260 IF(ABS(SIGS-SIGSMX(IMV)).LT.1E-4*(SIGS+SIGSMX(IMV))) IEQ=IMV  
11349       IF(IEQ.EQ.0) THEN 
11350         DO 270 IMV=NMAX,1,-1    
11351         IIN=IMV+1   
11352         IF(SIGS.LE.SIGSMX(IMV)) GOTO 280    
11353         IACCMX(IMV+1)=IACCMX(IMV)   
11354   270   SIGSMX(IMV+1)=SIGSMX(IMV)   
11355         IIN=1   
11356   280   IACCMX(IIN)=IACC    
11357         SIGSMX(IIN)=SIGS    
11358         IF(NMAX.LE.1) NMAX=NMAX+1   
11359       ENDIF 
11360   290 CONTINUE  
11361     
11362 C...Read out starting position for search.  
11363       IF(MSTP(122).GE.2) WRITE(MSTU(11),1600)   
11364       SIGSAM=SIGSMX(1)  
11365       DO 330 IMAX=1,NMAX    
11366       IACC=IACCMX(IMAX) 
11367       MTAU=MVARPT(IACC,1)   
11368       MTAUP=MVARPT(IACC,2)  
11369       MYST=MVARPT(IACC,3)   
11370       MCTH=MVARPT(IACC,4)   
11371       VTAU=0.5  
11372       VYST=0.5  
11373       VCTH=0.5  
11374       VTAUP=0.5 
11375     
11376 C...Starting point and step size in parameter space.    
11377       DO 320 IRPT=1,2   
11378       DO 310 IVAR=1,4   
11379       IF(NPTS(IVAR).EQ.1) GOTO 310  
11380       IF(IVAR.EQ.1) VVAR=VTAU   
11381       IF(IVAR.EQ.2) VVAR=VTAUP  
11382       IF(IVAR.EQ.3) VVAR=VYST   
11383       IF(IVAR.EQ.4) VVAR=VCTH   
11384       IF(IVAR.EQ.1) MVAR=MTAU   
11385       IF(IVAR.EQ.2) MVAR=MTAUP  
11386       IF(IVAR.EQ.3) MVAR=MYST   
11387       IF(IVAR.EQ.4) MVAR=MCTH   
11388       IF(IRPT.EQ.1) VDEL=0.1    
11389       IF(IRPT.EQ.2) VDEL=MAX(0.01,MIN(0.05,VVAR-0.02,0.98-VVAR))    
11390       IF(IRPT.EQ.1) VMAR=0.02   
11391       IF(IRPT.EQ.2) VMAR=0.002  
11392       IMOV0=1   
11393       IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0   
11394       DO 300 IMOV=IMOV0,8   
11395     
11396 C...Define new point in parameter space.    
11397       IF(IMOV.EQ.0) THEN    
11398         INEW=2  
11399         VNEW=VVAR   
11400       ELSEIF(IMOV.EQ.1) THEN    
11401         INEW=3  
11402         VNEW=VVAR+VDEL  
11403       ELSEIF(IMOV.EQ.2) THEN    
11404         INEW=1  
11405         VNEW=VVAR-VDEL  
11406       ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND. 
11407      &VVAR+2.*VDEL.LT.1.-VMAR) THEN 
11408         VVAR=VVAR+VDEL  
11409         SIGSSM(1)=SIGSSM(2) 
11410         SIGSSM(2)=SIGSSM(3) 
11411         INEW=3  
11412         VNEW=VVAR+VDEL  
11413       ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND. 
11414      &VVAR-2.*VDEL.GT.VMAR) THEN    
11415         VVAR=VVAR-VDEL  
11416         SIGSSM(3)=SIGSSM(2) 
11417         SIGSSM(2)=SIGSSM(1) 
11418         INEW=1  
11419         VNEW=VVAR-VDEL  
11420       ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN   
11421         VDEL=0.5*VDEL   
11422         VVAR=VVAR+VDEL  
11423         SIGSSM(1)=SIGSSM(2) 
11424         INEW=2  
11425         VNEW=VVAR   
11426       ELSE  
11427         VDEL=0.5*VDEL   
11428         VVAR=VVAR-VDEL  
11429         SIGSSM(3)=SIGSSM(2) 
11430         INEW=2  
11431         VNEW=VVAR   
11432       ENDIF 
11433     
11434 C...Convert to relevant variables and find derived new limits.  
11435       IF(IVAR.EQ.1) THEN    
11436         VTAU=VNEW   
11437         CALL PYKMAP(1,MTAU,VTAU)    
11438         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4) 
11439       ENDIF 
11440       IF(IVAR.LE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) THEN 
11441         IF(IVAR.EQ.2) VTAUP=VNEW    
11442         CALL PYKMAP(4,MTAUP,VTAUP)  
11443       ENDIF 
11444       IF(IVAR.LE.2) CALL PYKLIM(2)  
11445       IF(IVAR.LE.3) THEN    
11446         IF(IVAR.EQ.3) VYST=VNEW 
11447         CALL PYKMAP(2,MYST,VYST)    
11448         CALL PYKLIM(3)  
11449       ENDIF 
11450       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
11451         IF(IVAR.EQ.4) VCTH=VNEW 
11452         CALL PYKMAP(3,MCTH,VCTH)    
11453       ENDIF 
11454       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2) 
11455     
11456 C...Evaluate cross-section. Save new maximum. Final maximum.    
11457       CALL PYSIGH(NCHN,SIGS)    
11458       SIGSSM(INEW)=SIGS 
11459       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS    
11460       IF(MSTP(122).GE.2) WRITE(MSTU(11),1700) IMAX,IVAR,MVAR,IMOV,  
11461      &VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS 
11462   300 CONTINUE  
11463   310 CONTINUE  
11464   320 CONTINUE  
11465       IF(IMAX.EQ.1) SIGS11=SIGSAM   
11466   330 CONTINUE  
11467       XSEC(ISUB,1)=1.05*SIGSAM  
11468   340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)   
11469   350 CONTINUE  
11470     
11471 C...Print summary table.    
11472       IF(MSTP(122).GE.1) THEN   
11473         WRITE(MSTU(11),1800)    
11474         WRITE(MSTU(11),1900)    
11475         DO 360 ISUB=1,200   
11476         IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 360 
11477         IF(ISUB.EQ.96.AND.MINT(43).NE.4) GOTO 360   
11478         IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 360 
11479         IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.    
11480      &  ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 360   
11481         WRITE(MSTU(11),2000) ISUB,PROC(ISUB),XSEC(ISUB,1)   
11482   360   CONTINUE    
11483         WRITE(MSTU(11),2100)    
11484       ENDIF 
11485     
11486 C...Format statements for maximization results. 
11487  1000 FORMAT(/1X,'Coefficient optimization and maximum search for ',    
11488      &'subprocess no',I4/1X,'Coefficient modes     tau',10X,'y*',9X,    
11489      &'cth',9X,'tau''',7X,'sigma')  
11490  1100 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,E12.4)   
11491  1200 FORMAT(1X,'Error: requested subprocess ',I3,' has vanishing ',    
11492      &'cross-section.'/1X,'Execution stopped!')
11493  1300 FORMAT(1X,'Coefficients of equation system to be solved for ',A4) 
11494  1400 FORMAT(1X,1P,7E11.3)  
11495  1500 FORMAT(1X,'Result for ',A4,':',6F9.4) 
11496  1600 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',  
11497      &'MOD MOV   VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma') 
11498  1700 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,E12.4)   
11499  1800 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',  
11500      &'cross-section maximum search',1X,8('*')) 
11501  1900 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I  ISUB  ',  
11502      &'Subprocess name',15X,'I  Maximum value  I'/11X,'I',38X,'I',  
11503      &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')  
11504  2000 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,E12.4,3X,'I')    
11505  2100 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))   
11506     
11507       RETURN    
11508       END   
11509     
11510 C*********************************************************************  
11511     
11512       SUBROUTINE PYOVLY(MOVLY)  
11513     
11514 C...Initializes multiplicity distribution and selects mutliplicity  
11515 C...of overlayed events, i.e. several events occuring at the same   
11516 C...beam crossing.  
11517       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
11518       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
11519       COMMON/PYINT1/MINT(400),VINT(400) 
11520       DIMENSION WTI(0:100)  
11521       SAVE 
11522     
11523 C...Sum of allowed cross-sections for overlayed events. 
11524       IF(MOVLY.EQ.1) THEN   
11525         VINT(131)=VINT(106) 
11526         IF(MSTP(132).GE.2) VINT(131)=VINT(131)+VINT(104)    
11527         IF(MSTP(132).GE.3) VINT(131)=VINT(131)+VINT(103)    
11528         IF(MSTP(132).GE.4) VINT(131)=VINT(131)+VINT(102)    
11529     
11530 C...Initialize multiplicity distribution for unbiased events.   
11531         IF(MSTP(133).EQ.1) THEN 
11532           XNAVE=VINT(131)*PARP(131) 
11533           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE   
11534           WTI(0)=EXP(-MIN(50.,XNAVE))   
11535           WTS=0.    
11536           WTN=0.    
11537           DO 100 I=1,100    
11538           WTI(I)=WTI(I-1)*XNAVE/I   
11539           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 110    
11540           WTS=WTS+WTI(I)    
11541           WTN=WTN+WTI(I)*I  
11542   100     IMAX=I    
11543   110     VINT(132)=XNAVE   
11544           VINT(133)=WTN/WTS 
11545           VINT(134)=WTS 
11546     
11547 C...Initialize mutiplicity distribution for biased events.  
11548         ELSEIF(MSTP(133).EQ.2) THEN 
11549           XNAVE=VINT(131)*PARP(131) 
11550           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE   
11551           WTI(1)=EXP(-MIN(50.,XNAVE))*XNAVE 
11552           WTS=WTI(1)    
11553           WTN=WTI(1)    
11554           DO 120 I=2,100    
11555           WTI(I)=WTI(I-1)*XNAVE/(I-1)   
11556           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 130    
11557           WTS=WTS+WTI(I)    
11558           WTN=WTN+WTI(I)*I  
11559   120     IMAX=I    
11560   130     VINT(132)=XNAVE   
11561           VINT(133)=WTN/WTS 
11562           VINT(134)=WTS 
11563         ENDIF   
11564     
11565 C...Pick multiplicity of overlayed events.  
11566       ELSE  
11567         IF(MSTP(133).EQ.0) THEN 
11568           MINT(81)=MAX(1,MSTP(134)) 
11569         ELSE    
11570           WTR=WTS*RLU(0)    
11571           DO 140 I=1,IMAX   
11572           MINT(81)=I    
11573           WTR=WTR-WTI(I)    
11574           IF(WTR.LE.0.) GOTO 150    
11575   140     CONTINUE  
11576   150     CONTINUE  
11577         ENDIF   
11578       ENDIF 
11579     
11580 C...Format statement for error message. 
11581  1000 FORMAT(1X,'Warning: requested average number of events per bunch',    
11582      &'crossing too large, ',1P,E12.4)  
11583     
11584       RETURN    
11585       END   
11586     
11587 C*********************************************************************  
11588     
11589       SUBROUTINE PYRAND 
11590     
11591 C...Generates quantities characterizing the high-pT scattering at the   
11592 C...parton level according to the matrix elements. Chooses incoming,    
11593 C...reacting partons, their momentum fractions and one of the possible  
11594 C...subprocesses.   
11595       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
11596       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
11597       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
11598       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
11599       COMMON/PYINT1/MINT(400),VINT(400) 
11600       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
11601       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
11602       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
11603       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
11604       SAVE
11605     
11606 C...Initial values, specifically for (first) semihard interaction.  
11607       MINT(17)=0    
11608       MINT(18)=0    
11609       VINT(143)=1.  
11610       VINT(144)=1.  
11611       IF(MSUB(95).EQ.1.OR.MINT(82).GE.2) CALL PYMULT(2) 
11612       ISUB=0    
11613   100 MINT(51)=0    
11614     
11615 C...Choice of process type - first event of overlay.    
11616       IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN 
11617         RSUB=XSEC(0,1)*RLU(0)   
11618         DO 110 I=1,200  
11619         IF(MSUB(I).NE.1) GOTO 110   
11620         ISUB=I  
11621         RSUB=RSUB-XSEC(I,1) 
11622         IF(RSUB.LE.0.) GOTO 120 
11623   110   CONTINUE    
11624   120   IF(ISUB.EQ.95) ISUB=96  
11625     
11626 C...Choice of inclusive process type - overlayed events.    
11627       ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN  
11628         RSUB=VINT(131)*RLU(0)   
11629         ISUB=96 
11630         IF(RSUB.GT.VINT(106)) ISUB=93   
11631         IF(RSUB.GT.VINT(106)+VINT(104)) ISUB=92 
11632         IF(RSUB.GT.VINT(106)+VINT(104)+VINT(103)) ISUB=91   
11633       ENDIF 
11634       IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1   
11635       IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1 
11636       MINT(1)=ISUB  
11637     
11638 C...Find resonances (explicit or implicit in cross-section).    
11639       MINT(72)=0    
11640       KFR1=0    
11641       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN   
11642         KFR1=KFPR(ISUB,1)   
11643       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN    
11644         KFR1=25 
11645       ENDIF 
11646       IF(KFR1.NE.0) THEN    
11647         TAUR1=PMAS(KFR1,1)**2/VINT(2)   
11648         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2) 
11649         MINT(72)=1  
11650         MINT(73)=KFR1   
11651         VINT(73)=TAUR1  
11652         VINT(74)=GAMR1  
11653       ENDIF 
11654       IF(ISUB.EQ.141) THEN  
11655         KFR2=23 
11656         TAUR2=PMAS(KFR2,1)**2/VINT(2)   
11657         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2) 
11658         MINT(72)=2  
11659         MINT(74)=KFR2   
11660         VINT(75)=TAUR2  
11661         VINT(76)=GAMR2  
11662       ENDIF 
11663     
11664 C...Find product masses and minimum pT of process,  
11665 C...optionally with broadening according to a truncated Breit-Wigner.   
11666       VINT(63)=0.   
11667       VINT(64)=0.   
11668       MINT(71)=0    
11669       VINT(71)=CKIN(3)  
11670       IF(MINT(82).GE.2) VINT(71)=0. 
11671       IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN   
11672         DO 130 I=1,2    
11673         IF(KFPR(ISUB,I).EQ.0) THEN  
11674         ELSEIF(MSTP(42).LE.0) THEN  
11675           VINT(62+I)=PMAS(KFPR(ISUB,I),1)**2    
11676         ELSE    
11677           VINT(62+I)=ULMASS(KFPR(ISUB,I))**2    
11678         ENDIF   
11679   130   CONTINUE    
11680         IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1 
11681         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) 
11682       ENDIF 
11683     
11684       IF(ISET(ISUB).EQ.0) THEN  
11685 C...Double or single diffractive, or elastic scattering:    
11686 C...choose m^2 according to 1/m^2 (diffractive), constant (elastic) 
11687         IS=INT(1.5+RLU(0))  
11688         VINT(63)=VINT(3)**2 
11689         VINT(64)=VINT(4)**2 
11690         IF(ISUB.EQ.92.OR.ISUB.EQ.93) VINT(62+IS)=PARP(111)**2   
11691         IF(ISUB.EQ.93) VINT(65-IS)=PARP(111)**2 
11692         SH=VINT(2)  
11693         SQM1=VINT(3)**2 
11694         SQM2=VINT(4)**2 
11695         SQM3=VINT(63)   
11696         SQM4=VINT(64)   
11697         SQLA12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2   
11698         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4   
11699         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH    
11700         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH 
11701         THL=0.5*(THTER1-THTER2) 
11702         THU=0.5*(THTER1+THTER2) 
11703         THM=MIN(MAX(THL,PARP(101)),THU) 
11704         JTMAX=0 
11705         IF(ISUB.EQ.92.OR.ISUB.EQ.93) JTMAX=ISUB-91  
11706         DO 140 JT=1,JTMAX   
11707         MINT(13+3*JT-IS*(2*JT-3))=1 
11708         SQMMIN=VINT(59+3*JT-IS*(2*JT-3))    
11709         SQMI=VINT(8-3*JT+IS*(2*JT-3))**2    
11710         SQMJ=VINT(3*JT-1-IS*(2*JT-3))**2    
11711         SQMF=VINT(68-3*JT+IS*(2*JT-3))  
11712         SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-    
11713      &  SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)   
11714         QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+  
11715      &  SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))   
11716         SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))  
11717         IF(ABS(QUAR/SQUA**2).LT.1.E-06) SQMMAX=0.5*QUAR/SQUA    
11718         SQMMAX=MIN(SQMMAX,(VINT(1)-SQRT(SQMF))**2)  
11719         VINT(59+3*JT-IS*(2*JT-3))=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)    
11720   140   CONTINUE    
11721 C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).   
11722         SQM3=VINT(63)   
11723         SQM4=VINT(64)   
11724         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4   
11725         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH    
11726         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH 
11727         THL=0.5*(THTER1-THTER2) 
11728         THU=0.5*(THTER1+THTER2) 
11729         B=VINT(121) 
11730         C=VINT(122) 
11731         IF(ISUB.EQ.92.OR.ISUB.EQ.93) THEN   
11732           B=0.5*B   
11733           C=0.5*C   
11734         ENDIF   
11735         THM=MIN(MAX(THL,PARP(101)),THU) 
11736         EXPTH=0.    
11737         THARG=B*(THM-THU)   
11738         IF(THARG.GT.-20.) EXPTH=EXP(THARG)  
11739   150   TH=THU+LOG(EXPTH+(1.-EXPTH)*RLU(0))/B   
11740         TH=MAX(THM,MIN(THU,TH)) 
11741         RATLOG=MIN((B+C*(TH+THM))*(TH-THM),(B+C*(TH+THU))*(TH-THU)) 
11742         IF(RATLOG.LT.LOG(RLU(0))) GOTO 150  
11743         VINT(21)=1. 
11744         VINT(22)=0. 
11745         VINT(23)=MIN(1.,MAX(-1.,(2.*TH-THTER1)/THTER2)) 
11746     
11747 C...Note: in the following, by In is meant the integral over the    
11748 C...quantity multiplying coefficient cn.    
11749 C...Choose tau according to h1(tau)/tau, where  
11750 C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +    
11751 C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +  
11752 C...I0/I4*c4*1/(tau+tau_R') +   
11753 C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and    
11754 C...c0 + c1 + c2 + c3 + c4 + c5 = 1 
11755       ELSEIF(ISET(ISUB).GE.1.AND.ISET(ISUB).LE.4) THEN  
11756         CALL PYKLIM(1)  
11757         IF(MINT(51).NE.0) GOTO 100  
11758         RTAU=RLU(0) 
11759         MTAU=1  
11760         IF(RTAU.GT.COEF(ISUB,1)) MTAU=2 
11761         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3    
11762         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4   
11763         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)) 
11764      &  MTAU=5  
11765         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ 
11766      &  COEF(ISUB,5)) MTAU=6    
11767         CALL PYKMAP(1,MTAU,RLU(0))  
11768     
11769 C...2 -> 3, 4 processes:    
11770 C...Choose tau' according to h4(tau,tau')/tau', where   
11771 C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and 
11772 C...c0 + c1 = 1.    
11773         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN 
11774           CALL PYKLIM(4)    
11775           IF(MINT(51).NE.0) GOTO 100    
11776           RTAUP=RLU(0)  
11777           MTAUP=1   
11778           IF(RTAUP.GT.COEF(ISUB,15)) MTAUP=2    
11779           CALL PYKMAP(4,MTAUP,RLU(0))   
11780         ENDIF   
11781     
11782 C...Choose y* according to h2(y*), where    
11783 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +    
11784 C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.    
11785         CALL PYKLIM(2)  
11786         IF(MINT(51).NE.0) GOTO 100  
11787         RYST=RLU(0) 
11788         MYST=1  
11789         IF(RYST.GT.COEF(ISUB,7)) MYST=2 
11790         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3    
11791         CALL PYKMAP(2,MYST,RLU(0))  
11792     
11793 C...2 -> 2 processes:   
11794 C...Choose cos(theta-hat) (cth) according to h3(cth), where 
11795 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +    
11796 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,    
11797 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), 
11798 C...and c0 + c1 + c2 + c3 + c4 = 1. 
11799         CALL PYKLIM(3)  
11800         IF(MINT(51).NE.0) GOTO 100  
11801         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN 
11802           RCTH=RLU(0)   
11803           MCTH=1    
11804           IF(RCTH.GT.COEF(ISUB,10)) MCTH=2  
11805           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)) MCTH=3    
11806           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)) MCTH=4  
11807           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)+ 
11808      &    COEF(ISUB,13)) MCTH=5 
11809           CALL PYKMAP(3,MCTH,RLU(0))    
11810         ENDIF   
11811     
11812 C...Low-pT or multiple interactions (first semihard interaction).   
11813       ELSEIF(ISET(ISUB).EQ.5) THEN  
11814         CALL PYMULT(3)  
11815         ISUB=MINT(1)    
11816       ENDIF 
11817     
11818 C...Choose azimuthal angle. 
11819       VINT(24)=PARU(2)*RLU(0)   
11820     
11821 C...Check against user cuts on kinematics at parton level.  
11822       MINT(51)=0    
11823       IF(ISUB.LE.90.OR.ISUB.GT.100) CALL PYKLIM(0)  
11824       IF(MINT(51).NE.0) GOTO 100    
11825       IF(MINT(82).EQ.1.AND.MSTP(141).GE.1) THEN 
11826         MCUT=0  
11827         IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)   
11828      &  CALL PYKCUT(MCUT)   
11829         IF(MCUT.NE.0) GOTO 100  
11830       ENDIF 
11831     
11832 C...Calculate differential cross-section for different subprocesses.    
11833       CALL PYSIGH(NCHN,SIGS)    
11834     
11835 C...Calculations for Monte Carlo estimate of all cross-sections.    
11836       IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN   
11837         XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS  
11838       ELSEIF(MINT(82).EQ.1) THEN    
11839         XSEC(ISUB,2)=XSEC(ISUB,2)+XSEC(ISUB,1)  
11840       ENDIF 
11841     
11842 C...Multiple interactions: store results of cross-section calculation.  
11843       IF(MINT(43).EQ.4.AND.MSTP(82).GE.3) THEN  
11844         VINT(153)=SIGS  
11845         CALL PYMULT(4)  
11846       ENDIF 
11847     
11848 C...Weighting using estimate of maximum of differential cross-section.  
11849       VIOL=SIGS/XSEC(ISUB,1)    
11850       IF(VIOL.LT.RLU(0)) GOTO 100   
11851     
11852 C...Check for possible violation of estimated maximum of differential   
11853 C...cross-section used in weighting.    
11854       IF(MSTP(123).LE.0) THEN   
11855         IF(VIOL.GT.1.) THEN 
11856           WRITE(MSTU(11),1000) VIOL,NGEN(0,3)+1 
11857           WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26) 
11858           STOP  
11859         ENDIF   
11860       ELSEIF(MSTP(123).EQ.1) THEN   
11861         IF(VIOL.GT.VINT(108)) THEN  
11862           VINT(108)=VIOL    
11863 C          IF(VIOL.GT.1.) THEN   
11864 C            WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1   
11865 C            WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),   
11866 C     &      VINT(26)    
11867 C          ENDIF 
11868         ENDIF   
11869       ELSEIF(VIOL.GT.VINT(108)) THEN    
11870         VINT(108)=VIOL  
11871         IF(VIOL.GT.1.) THEN 
11872           XDIF=XSEC(ISUB,1)*(VIOL-1.)   
11873           XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF    
11874           IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))    
11875      &    XSEC(0,1)=XSEC(0,1)+XDIF  
11876 C          WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1 
11877 C          WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26) 
11878 C          IF(ISUB.LE.9) THEN    
11879 C            WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)  
11880 C          ELSEIF(ISUB.LE.99) THEN   
11881 C            WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)  
11882 C          ELSE  
11883 C            WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)  
11884 C          ENDIF 
11885           VINT(108)=1.  
11886         ENDIF   
11887       ENDIF 
11888     
11889 C...Multiple interactions: choose impact parameter. 
11890       VINT(148)=1.  
11891       IF(MINT(43).EQ.4.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.MSTP(82).GE.3)    
11892      &THEN  
11893         CALL PYMULT(5)  
11894         IF(VINT(150).LT.RLU(0)) GOTO 100    
11895       ENDIF 
11896       IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN  
11897         IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1    
11898         IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1    
11899       ENDIF 
11900       IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1  
11901     
11902 C...Choose flavour of reacting partons (and subprocess).    
11903       RSIGS=SIGS*RLU(0) 
11904       QT2=VINT(48)  
11905       RQQBAR=PARP(87)*(1.-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)    
11906       IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.    
11907      &RLU(0).GT.RQQBAR)) THEN   
11908         DO 190 ICHN=1,NCHN  
11909         KFL1=ISIG(ICHN,1)   
11910         KFL2=ISIG(ICHN,2)   
11911         MINT(2)=ISIG(ICHN,3)    
11912         RSIGS=RSIGS-SIGH(ICHN)  
11913         IF(RSIGS.LE.0.) GOTO 210    
11914   190   CONTINUE    
11915     
11916 C...Multiple interactions: choose qqbar preferentially at small pT. 
11917       ELSEIF(ISUB.EQ.96) THEN   
11918         CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)    
11919         CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)    
11920         MINT(1)=11  
11921         MINT(2)=1   
11922         IF(KFL1.EQ.KFL2.AND.RLU(0).LT.0.5) MINT(2)=2    
11923     
11924 C...Low-pT: choose string drawing configuration.    
11925       ELSE  
11926         KFL1=21 
11927         KFL2=21 
11928         RSIGS=6.*RLU(0) 
11929         MINT(2)=1   
11930         IF(RSIGS.GT.1.) MINT(2)=2   
11931         IF(RSIGS.GT.2.) MINT(2)=3   
11932       ENDIF 
11933     
11934 C...Reassign QCD process. Partons before initial state radiation.   
11935   210 IF(MINT(2).GT.10) THEN    
11936         MINT(1)=MINT(2)/10  
11937         MINT(2)=MOD(MINT(2),10) 
11938       ENDIF 
11939       MINT(15)=KFL1 
11940       MINT(16)=KFL2 
11941       MINT(13)=MINT(15) 
11942       MINT(14)=MINT(16) 
11943       VINT(141)=VINT(41)    
11944       VINT(142)=VINT(42)    
11945     
11946 C...Format statements for differential cross-section maximum violations.    
11947  1000 FORMAT(1X,'Error: maximum violated by',1P,E11.3,1X,   
11948      &'in event',1X,I7,'.'/1X,'Execution stopped!') 
11949  1100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P, 
11950      &E11.3,', y* =',E11.3,', cthe = ',0P,F11.7,', tau'' =',1P,E11.3)   
11951 C 1200 FORMAT(1X,'Warning: maximum violated by',1P,E11.3,1X, 
11952 C     &'in event',1X,I7) 
11953 C 1300 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,E11.3) 
11954 C 1400 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,E11.3) 
11955 C 1500 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,E11.3) 
11956     
11957       RETURN    
11958       END   
11959     
11960 C*********************************************************************  
11961     
11962       SUBROUTINE PYSCAT 
11963     
11964 C...Finds outgoing flavours and event type; sets up the kinematics  
11965 C...and colour flow of the hard scattering. 
11966       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
11967       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
11968       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
11969       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
11970       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
11971       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
11972       COMMON/PYINT1/MINT(400),VINT(400) 
11973       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
11974       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
11975       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
11976       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
11977       DIMENSION WDTP(0:40),WDTE(0:40,0:5),PMQ(2),Z(2),CTHE(2),PHI(2)    
11978       SAVE
11979 
11980 C...Choice of subprocess, number of documentation lines.    
11981       ISUB=MINT(1)  
11982       IDOC=6+ISET(ISUB) 
11983       IF(ISUB.EQ.95) IDOC=8 
11984       MINT(3)=IDOC-6    
11985       IF(IDOC.GE.9) IDOC=IDOC+2 
11986       MINT(4)=IDOC  
11987       IPU1=MINT(84)+1   
11988       IPU2=MINT(84)+2   
11989       IPU3=MINT(84)+3   
11990       IPU4=MINT(84)+4   
11991       IPU5=MINT(84)+5   
11992       IPU6=MINT(84)+6   
11993     
11994 C...Reset K, P and V vectors. Store incoming particles. 
11995       DO 100 JT=1,MSTP(126)+10  
11996       I=MINT(83)+JT 
11997       DO 100 J=1,5  
11998       K(I,J)=0  
11999       P(I,J)=0. 
12000   100 V(I,J)=0. 
12001       DO 110 JT=1,2 
12002       I=MINT(83)+JT 
12003       K(I,1)=21 
12004       K(I,2)=MINT(10+JT)    
12005       P(I,1)=0. 
12006       P(I,2)=0. 
12007       P(I,5)=VINT(2+JT) 
12008       P(I,3)=VINT(5)*(-1)**(JT+1)   
12009   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)  
12010       MINT(6)=2 
12011       KFRES=0   
12012     
12013 C...Store incoming partons in their CM-frame.   
12014       SH=VINT(44)   
12015       SHR=SQRT(SH)  
12016       SHP=VINT(26)*VINT(2)  
12017       SHPR=SQRT(SHP)    
12018       SHUSER=SHR    
12019       IF(ISET(ISUB).GE.3) SHUSER=SHPR   
12020       DO 120 JT=1,2 
12021       I=MINT(84)+JT 
12022       K(I,1)=14 
12023       K(I,2)=MINT(14+JT)    
12024       K(I,3)=MINT(83)+2+JT  
12025   120 P(I,5)=ULMASS(K(I,2)) 
12026       IF(P(IPU1,5)+P(IPU2,5).GE.SHUSER) THEN    
12027         P(IPU1,5)=0.    
12028         P(IPU2,5)=0.    
12029       ENDIF 
12030       P(IPU1,4)=0.5*(SHUSER+(P(IPU1,5)**2-P(IPU2,5)**2)/SHUSER) 
12031       P(IPU1,3)=SQRT(MAX(0.,P(IPU1,4)**2-P(IPU1,5)**2)) 
12032       P(IPU2,4)=SHUSER-P(IPU1,4)    
12033       P(IPU2,3)=-P(IPU1,3)  
12034     
12035 C...Copy incoming partons to documentation lines.   
12036       DO 130 JT=1,2 
12037       I1=MINT(83)+4+JT  
12038       I2=MINT(84)+JT    
12039       K(I1,1)=21    
12040       K(I1,2)=K(I2,2)   
12041       K(I1,3)=I1-2  
12042       DO 130 J=1,5  
12043   130 P(I1,J)=P(I2,J)   
12044     
12045 C...Choose new quark flavour for relevant annihilation graphs.  
12046       IF(ISUB.EQ.12.OR.ISUB.EQ.53) THEN 
12047         CALL PYWIDT(21,SHR,WDTP,WDTE)   
12048         RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*RLU(0) 
12049         DO 140 I=1,2*MSTP(1)    
12050         KFLQ=I  
12051         RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))   
12052         IF(RKFL.LE.0.) GOTO 150 
12053   140   CONTINUE    
12054   150   CONTINUE    
12055       ENDIF 
12056     
12057 C...Final state flavours and colour flow: default values.   
12058       JS=1  
12059       MINT(21)=MINT(15) 
12060       MINT(22)=MINT(16) 
12061       MINT(23)=0    
12062       MINT(24)=0    
12063       KCC=20    
12064       KCS=ISIGN(1,MINT(15)) 
12065     
12066       IF(ISUB.LE.10) THEN   
12067       IF(ISUB.EQ.1) THEN    
12068 C...f + fb -> gamma*/Z0.    
12069         KFRES=23    
12070     
12071       ELSEIF(ISUB.EQ.2) THEN    
12072 C...f + fb' -> W+/- .   
12073         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
12074         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
12075         KFRES=ISIGN(24,KCH1+KCH2)   
12076     
12077       ELSEIF(ISUB.EQ.3) THEN    
12078 C...f + fb -> H0.   
12079         KFRES=25    
12080     
12081       ELSEIF(ISUB.EQ.4) THEN    
12082 C...gamma + W+/- -> W+/-.   
12083     
12084       ELSEIF(ISUB.EQ.5) THEN    
12085 C...Z0 + Z0 -> H0.  
12086         XH=SH/SHP   
12087         MINT(21)=MINT(15)   
12088         MINT(22)=MINT(16)   
12089         PMQ(1)=ULMASS(MINT(21)) 
12090         PMQ(2)=ULMASS(MINT(22)) 
12091   240   JT=INT(1.5+RLU(0))  
12092         ZMIN=2.*PMQ(JT)/SHPR    
12093         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
12094         ZMAX=MIN(1.-XH,ZMAX)    
12095         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
12096         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
12097      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 240 
12098         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
12099         IF(SQC1.LT.1.E-8) GOTO 240  
12100         C1=SQRT(SQC1)   
12101         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
12102         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
12103         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
12104         Z(3-JT)=1.-XH/(1.-Z(JT))    
12105         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
12106         IF(SQC1.LT.1.E-8) GOTO 240  
12107         C1=SQRT(SQC1)   
12108         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
12109         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
12110         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
12111         PHIR=PARU(2)*RLU(0) 
12112         CPHI=COS(PHIR)  
12113         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
12114         Z1=2.-Z(JT) 
12115         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
12116         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
12117         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
12118      &  PMQ(3-JT)**2/SHP))  
12119         ZMIN=2.*PMQ(3-JT)/SHPR  
12120         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
12121         ZMAX=MIN(1.-XH,ZMAX)    
12122         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 240 
12123         KCC=22  
12124         KFRES=25    
12125     
12126       ELSEIF(ISUB.EQ.6) THEN    
12127 C...Z0 + W+/- -> W+/-.  
12128     
12129       ELSEIF(ISUB.EQ.7) THEN    
12130 C...W+ + W- -> Z0.  
12131     
12132       ELSEIF(ISUB.EQ.8) THEN    
12133 C...W+ + W- -> H0.  
12134         XH=SH/SHP   
12135   250   DO 280 JT=1,2   
12136         I=MINT(14+JT)   
12137         IA=IABS(I)  
12138         IF(IA.LE.10) THEN   
12139           RVCKM=VINT(180+I)*RLU(0)  
12140           DO 270 J=1,MSTP(1)    
12141           IB=2*J-1+MOD(IA,2)    
12142           IPM=(5-ISIGN(1,I))/2  
12143           IDC=J+MDCY(IA,2)+2    
12144           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270  
12145           MINT(20+JT)=ISIGN(IB,I)   
12146           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)   
12147           IF(RVCKM.LE.0.) GOTO 280  
12148   270     CONTINUE  
12149         ELSE    
12150           IB=2*((IA+1)/2)-1+MOD(IA,2)   
12151           MINT(20+JT)=ISIGN(IB,I)   
12152         ENDIF   
12153   280   PMQ(JT)=ULMASS(MINT(20+JT)) 
12154         JT=INT(1.5+RLU(0))  
12155         ZMIN=2.*PMQ(JT)/SHPR    
12156         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
12157         ZMAX=MIN(1.-XH,ZMAX)    
12158         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
12159         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
12160      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 250 
12161         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
12162         IF(SQC1.LT.1.E-8) GOTO 250  
12163         C1=SQRT(SQC1)   
12164         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
12165         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
12166         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
12167         Z(3-JT)=1.-XH/(1.-Z(JT))    
12168         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
12169         IF(SQC1.LT.1.E-8) GOTO 250  
12170         C1=SQRT(SQC1)   
12171         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
12172         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
12173         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
12174         PHIR=PARU(2)*RLU(0) 
12175         CPHI=COS(PHIR)  
12176         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
12177         Z1=2.-Z(JT) 
12178         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
12179         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
12180         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
12181      &  PMQ(3-JT)**2/SHP))  
12182         ZMIN=2.*PMQ(3-JT)/SHPR  
12183         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
12184         ZMAX=MIN(1.-XH,ZMAX)    
12185         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 250 
12186         KCC=22  
12187         KFRES=25    
12188       ENDIF 
12189     
12190       ELSEIF(ISUB.LE.20) THEN   
12191       IF(ISUB.EQ.11) THEN   
12192 C...f + f' -> f + f'; th = (p(f)-p(f))**2.  
12193         KCC=MINT(2) 
12194         IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2    
12195     
12196       ELSEIF(ISUB.EQ.12) THEN   
12197 C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.   
12198         MINT(21)=ISIGN(KFLQ,MINT(15))   
12199         MINT(22)=-MINT(21)  
12200         KCC=4   
12201     
12202       ELSEIF(ISUB.EQ.13) THEN   
12203 C...f + fb -> g + g; th arbitrary.  
12204         MINT(21)=21 
12205         MINT(22)=21 
12206         KCC=MINT(2)+4   
12207     
12208       ELSEIF(ISUB.EQ.14) THEN   
12209 C...f + fb -> g + gam; th arbitrary.    
12210         IF(RLU(0).GT.0.5) JS=2  
12211         MINT(20+JS)=21  
12212         MINT(23-JS)=22  
12213         KCC=17+JS   
12214     
12215       ELSEIF(ISUB.EQ.15) THEN   
12216 C...f + fb -> g + Z0; th arbitrary. 
12217         IF(RLU(0).GT.0.5) JS=2  
12218         MINT(20+JS)=21  
12219         MINT(23-JS)=23  
12220         KCC=17+JS   
12221     
12222       ELSEIF(ISUB.EQ.16) THEN   
12223 C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 
12224         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
12225         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
12226         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2  
12227         MINT(20+JS)=21  
12228         MINT(23-JS)=ISIGN(24,KCH1+KCH2) 
12229         KCC=17+JS   
12230     
12231       ELSEIF(ISUB.EQ.17) THEN   
12232 C...f + fb -> g + H0; th arbitrary. 
12233         IF(RLU(0).GT.0.5) JS=2  
12234         MINT(20+JS)=21  
12235         MINT(23-JS)=25  
12236         KCC=17+JS   
12237     
12238       ELSEIF(ISUB.EQ.18) THEN   
12239 C...f + fb -> gamma + gamma; th arbitrary.  
12240         MINT(21)=22 
12241         MINT(22)=22 
12242     
12243       ELSEIF(ISUB.EQ.19) THEN   
12244 C...f + fb -> gamma + Z0; th arbitrary. 
12245         IF(RLU(0).GT.0.5) JS=2  
12246         MINT(20+JS)=22  
12247         MINT(23-JS)=23  
12248     
12249       ELSEIF(ISUB.EQ.20) THEN   
12250 C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 
12251         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
12252         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
12253         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2  
12254         MINT(20+JS)=22  
12255         MINT(23-JS)=ISIGN(24,KCH1+KCH2) 
12256       ENDIF 
12257     
12258       ELSEIF(ISUB.LE.30) THEN   
12259       IF(ISUB.EQ.21) THEN   
12260 C...f + fb -> gamma + H0; th arbitrary. 
12261         IF(RLU(0).GT.0.5) JS=2  
12262         MINT(20+JS)=22  
12263         MINT(23-JS)=25  
12264     
12265       ELSEIF(ISUB.EQ.22) THEN   
12266 C...f + fb -> Z0 + Z0; th arbitrary.    
12267         MINT(21)=23 
12268         MINT(22)=23 
12269     
12270       ELSEIF(ISUB.EQ.23) THEN   
12271 C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    
12272         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
12273         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
12274         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2  
12275         MINT(20+JS)=23  
12276         MINT(23-JS)=ISIGN(24,KCH1+KCH2) 
12277     
12278       ELSEIF(ISUB.EQ.24) THEN   
12279 C...f + fb -> Z0 + H0; th arbitrary.    
12280         IF(RLU(0).GT.0.5) JS=2  
12281         MINT(20+JS)=23  
12282         MINT(23-JS)=25  
12283     
12284       ELSEIF(ISUB.EQ.25) THEN   
12285 C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.    
12286         MINT(21)=-ISIGN(24,MINT(15))    
12287         MINT(22)=-MINT(21)  
12288     
12289       ELSEIF(ISUB.EQ.26) THEN   
12290 C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    
12291         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
12292         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
12293         IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2  
12294         MINT(20+JS)=ISIGN(24,KCH1+KCH2) 
12295         MINT(23-JS)=25  
12296     
12297       ELSEIF(ISUB.EQ.27) THEN   
12298 C...f + fb -> H0 + H0.  
12299     
12300       ELSEIF(ISUB.EQ.28) THEN   
12301 C...f + g -> f + g; th = (p(f)-p(f))**2.    
12302         KCC=MINT(2)+6   
12303         IF(MINT(15).EQ.21) KCC=KCC+2    
12304         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))    
12305         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))    
12306     
12307       ELSEIF(ISUB.EQ.29) THEN   
12308 C...f + g -> f + gamma; th = (p(f)-p(f))**2.    
12309         IF(MINT(15).EQ.21) JS=2 
12310         MINT(23-JS)=22  
12311         KCC=15+JS   
12312         KCS=ISIGN(1,MINT(14+JS))    
12313     
12314       ELSEIF(ISUB.EQ.30) THEN   
12315 C...f + g -> f + Z0; th = (p(f)-p(f))**2.   
12316         IF(MINT(15).EQ.21) JS=2 
12317         MINT(23-JS)=23  
12318         KCC=15+JS   
12319         KCS=ISIGN(1,MINT(14+JS))    
12320       ENDIF 
12321     
12322       ELSEIF(ISUB.LE.40) THEN   
12323       IF(ISUB.EQ.31) THEN   
12324 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.    
12325         IF(MINT(15).EQ.21) JS=2 
12326         I=MINT(14+JS)   
12327         IA=IABS(I)  
12328         MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)  
12329         RVCKM=VINT(180+I)*RLU(0)    
12330         DO 220 J=1,MSTP(1)  
12331         IB=2*J-1+MOD(IA,2)  
12332         IPM=(5-ISIGN(1,I))/2    
12333         IDC=J+MDCY(IA,2)+2  
12334         IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 220    
12335         MINT(20+JS)=ISIGN(IB,I) 
12336         RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) 
12337         IF(RVCKM.LE.0.) GOTO 230    
12338   220   CONTINUE    
12339   230   KCC=15+JS   
12340         KCS=ISIGN(1,MINT(14+JS))    
12341     
12342       ELSEIF(ISUB.EQ.32) THEN   
12343 C...f + g -> f + H0; th = (p(f)-p(f))**2.   
12344         IF(MINT(15).EQ.21) JS=2 
12345         MINT(23-JS)=25  
12346         KCC=15+JS   
12347         KCS=ISIGN(1,MINT(14+JS))    
12348     
12349       ELSEIF(ISUB.EQ.33) THEN   
12350 C...f + gamma -> f + g. 
12351     
12352       ELSEIF(ISUB.EQ.34) THEN   
12353 C...f + gamma -> f + gamma. 
12354     
12355       ELSEIF(ISUB.EQ.35) THEN   
12356 C...f + gamma -> f + Z0.    
12357     
12358       ELSEIF(ISUB.EQ.36) THEN   
12359 C...f + gamma -> f' + W+/-. 
12360     
12361       ELSEIF(ISUB.EQ.37) THEN   
12362 C...f + gamma -> f + H0.    
12363     
12364       ELSEIF(ISUB.EQ.38) THEN   
12365 C...f + Z0 -> f + g.    
12366     
12367       ELSEIF(ISUB.EQ.39) THEN   
12368 C...f + Z0 -> f + gamma.    
12369     
12370       ELSEIF(ISUB.EQ.40) THEN   
12371 C...f + Z0 -> f + Z0.   
12372       ENDIF 
12373     
12374       ELSEIF(ISUB.LE.50) THEN   
12375       IF(ISUB.EQ.41) THEN   
12376 C...f + Z0 -> f' + W+/-.    
12377     
12378       ELSEIF(ISUB.EQ.42) THEN   
12379 C...f + Z0 -> f + H0.   
12380     
12381       ELSEIF(ISUB.EQ.43) THEN   
12382 C...f + W+/- -> f' + g. 
12383     
12384       ELSEIF(ISUB.EQ.44) THEN   
12385 C...f + W+/- -> f' + gamma. 
12386     
12387       ELSEIF(ISUB.EQ.45) THEN   
12388 C...f + W+/- -> f' + Z0.    
12389     
12390       ELSEIF(ISUB.EQ.46) THEN   
12391 C...f + W+/- -> f' + W+/-.  
12392     
12393       ELSEIF(ISUB.EQ.47) THEN   
12394 C...f + W+/- -> f' + H0.    
12395     
12396       ELSEIF(ISUB.EQ.48) THEN   
12397 C...f + H0 -> f + g.    
12398     
12399       ELSEIF(ISUB.EQ.49) THEN   
12400 C...f + H0 -> f + gamma.    
12401     
12402       ELSEIF(ISUB.EQ.50) THEN   
12403 C...f + H0 -> f + Z0.   
12404       ENDIF 
12405     
12406       ELSEIF(ISUB.LE.60) THEN   
12407       IF(ISUB.EQ.51) THEN   
12408 C...f + H0 -> f' + W+/-.    
12409     
12410       ELSEIF(ISUB.EQ.52) THEN   
12411 C...f + H0 -> f + H0.   
12412     
12413       ELSEIF(ISUB.EQ.53) THEN   
12414 C...g + g -> f + fb; th arbitrary.  
12415         KCS=(-1)**INT(1.5+RLU(0))   
12416         MINT(21)=ISIGN(KFLQ,KCS)    
12417         MINT(22)=-MINT(21)  
12418         KCC=MINT(2)+10  
12419     
12420       ELSEIF(ISUB.EQ.54) THEN   
12421 C...g + gamma -> f + fb.    
12422     
12423       ELSEIF(ISUB.EQ.55) THEN   
12424 C...g + Z0 -> f + fb.   
12425     
12426       ELSEIF(ISUB.EQ.56) THEN   
12427 C...g + W+/- -> f + fb'.    
12428     
12429       ELSEIF(ISUB.EQ.57) THEN   
12430 C...g + H0 -> f + fb.   
12431     
12432       ELSEIF(ISUB.EQ.58) THEN   
12433 C...gamma + gamma -> f + fb.    
12434     
12435       ELSEIF(ISUB.EQ.59) THEN   
12436 C...gamma + Z0 -> f + fb.   
12437     
12438       ELSEIF(ISUB.EQ.60) THEN   
12439 C...gamma + W+/- -> f + fb'.    
12440       ENDIF 
12441     
12442       ELSEIF(ISUB.LE.70) THEN   
12443       IF(ISUB.EQ.61) THEN   
12444 C...gamma + H0 -> f + fb.   
12445     
12446       ELSEIF(ISUB.EQ.62) THEN   
12447 C...Z0 + Z0 -> f + fb.  
12448     
12449       ELSEIF(ISUB.EQ.63) THEN   
12450 C...Z0 + W+/- -> f + fb'.   
12451     
12452       ELSEIF(ISUB.EQ.64) THEN   
12453 C...Z0 + H0 -> f + fb.  
12454     
12455       ELSEIF(ISUB.EQ.65) THEN   
12456 C...W+ + W- -> f + fb.  
12457     
12458       ELSEIF(ISUB.EQ.66) THEN   
12459 C...W+/- + H0 -> f + fb'.   
12460     
12461       ELSEIF(ISUB.EQ.67) THEN   
12462 C...H0 + H0 -> f + fb.  
12463     
12464       ELSEIF(ISUB.EQ.68) THEN   
12465 C...g + g -> g + g; th arbitrary.   
12466         KCC=MINT(2)+12  
12467         KCS=(-1)**INT(1.5+RLU(0))   
12468     
12469       ELSEIF(ISUB.EQ.69) THEN   
12470 C...gamma + gamma -> W+ + W-.   
12471     
12472       ELSEIF(ISUB.EQ.70) THEN   
12473 C...gamma + W+/- -> gamma + W+/-    
12474       ENDIF 
12475     
12476       ELSEIF(ISUB.LE.80) THEN   
12477       IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN 
12478 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-. 
12479         XH=SH/SHP   
12480         MINT(21)=MINT(15)   
12481         MINT(22)=MINT(16)   
12482         PMQ(1)=ULMASS(MINT(21)) 
12483         PMQ(2)=ULMASS(MINT(22)) 
12484   290   JT=INT(1.5+RLU(0))  
12485         ZMIN=2.*PMQ(JT)/SHPR    
12486         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
12487         ZMAX=MIN(1.-XH,ZMAX)    
12488         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
12489         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
12490      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 290 
12491         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
12492         IF(SQC1.LT.1.E-8) GOTO 290  
12493         C1=SQRT(SQC1)   
12494         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
12495         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
12496         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
12497         Z(3-JT)=1.-XH/(1.-Z(JT))    
12498         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
12499         IF(SQC1.LT.1.E-8) GOTO 290  
12500         C1=SQRT(SQC1)   
12501         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
12502         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
12503         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
12504         PHIR=PARU(2)*RLU(0) 
12505         CPHI=COS(PHIR)  
12506         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
12507         Z1=2.-Z(JT) 
12508         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
12509         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
12510         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
12511      &  PMQ(3-JT)**2/SHP))  
12512         ZMIN=2.*PMQ(3-JT)/SHPR  
12513         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
12514         ZMAX=MIN(1.-XH,ZMAX)    
12515         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 290 
12516         KCC=22  
12517     
12518       ELSEIF(ISUB.EQ.73) THEN   
12519 C...Z0 + W+/- -> Z0 + W+/-. 
12520         XH=SH/SHP   
12521   300   JT=INT(1.5+RLU(0))  
12522         I=MINT(14+JT)   
12523         IA=IABS(I)  
12524         IF(IA.LE.10) THEN   
12525           RVCKM=VINT(180+I)*RLU(0)  
12526           DO 320 J=1,MSTP(1)    
12527           IB=2*J-1+MOD(IA,2)    
12528           IPM=(5-ISIGN(1,I))/2  
12529           IDC=J+MDCY(IA,2)+2    
12530           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 320  
12531           MINT(20+JT)=ISIGN(IB,I)   
12532           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)   
12533           IF(RVCKM.LE.0.) GOTO 330  
12534   320     CONTINUE  
12535         ELSE    
12536           IB=2*((IA+1)/2)-1+MOD(IA,2)   
12537           MINT(20+JT)=ISIGN(IB,I)   
12538         ENDIF   
12539   330   PMQ(JT)=ULMASS(MINT(20+JT)) 
12540         MINT(23-JT)=MINT(17-JT) 
12541         PMQ(3-JT)=ULMASS(MINT(23-JT))   
12542         JT=INT(1.5+RLU(0))  
12543         ZMIN=2.*PMQ(JT)/SHPR    
12544         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
12545         ZMAX=MIN(1.-XH,ZMAX)    
12546         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
12547         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
12548      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 300 
12549         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
12550         IF(SQC1.LT.1.E-8) GOTO 300  
12551         C1=SQRT(SQC1)   
12552         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
12553         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
12554         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
12555         Z(3-JT)=1.-XH/(1.-Z(JT))    
12556         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
12557         IF(SQC1.LT.1.E-8) GOTO 300  
12558         C1=SQRT(SQC1)   
12559         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
12560         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
12561         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
12562         PHIR=PARU(2)*RLU(0) 
12563         CPHI=COS(PHIR)  
12564         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
12565         Z1=2.-Z(JT) 
12566         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
12567         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
12568         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
12569      &  PMQ(3-JT)**2/SHP))  
12570         ZMIN=2.*PMQ(3-JT)/SHPR  
12571         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
12572         ZMAX=MIN(1.-XH,ZMAX)    
12573         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 300 
12574         KCC=22  
12575     
12576       ELSEIF(ISUB.EQ.74) THEN   
12577 C...Z0 + H0 -> Z0 + H0. 
12578     
12579       ELSEIF(ISUB.EQ.75) THEN   
12580 C...W+ + W- -> gamma + gamma.   
12581     
12582       ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN 
12583 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-. 
12584         XH=SH/SHP   
12585   340   DO 370 JT=1,2   
12586         I=MINT(14+JT)   
12587         IA=IABS(I)  
12588         IF(IA.LE.10) THEN   
12589           RVCKM=VINT(180+I)*RLU(0)  
12590           DO 360 J=1,MSTP(1)    
12591           IB=2*J-1+MOD(IA,2)    
12592           IPM=(5-ISIGN(1,I))/2  
12593           IDC=J+MDCY(IA,2)+2    
12594           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 360  
12595           MINT(20+JT)=ISIGN(IB,I)   
12596           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)   
12597           IF(RVCKM.LE.0.) GOTO 370  
12598   360     CONTINUE  
12599         ELSE    
12600           IB=2*((IA+1)/2)-1+MOD(IA,2)   
12601           MINT(20+JT)=ISIGN(IB,I)   
12602         ENDIF   
12603   370   PMQ(JT)=ULMASS(MINT(20+JT)) 
12604         JT=INT(1.5+RLU(0))  
12605         ZMIN=2.*PMQ(JT)/SHPR    
12606         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
12607         ZMAX=MIN(1.-XH,ZMAX)    
12608         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
12609         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
12610      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 340 
12611         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
12612         IF(SQC1.LT.1.E-8) GOTO 340  
12613         C1=SQRT(SQC1)   
12614         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
12615         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
12616         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
12617         Z(3-JT)=1.-XH/(1.-Z(JT))    
12618         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
12619         IF(SQC1.LT.1.E-8) GOTO 340  
12620         C1=SQRT(SQC1)   
12621         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
12622         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
12623         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
12624         PHIR=PARU(2)*RLU(0) 
12625         CPHI=COS(PHIR)  
12626         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
12627         Z1=2.-Z(JT) 
12628         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
12629         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
12630         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
12631      &  PMQ(3-JT)**2/SHP))  
12632         ZMIN=2.*PMQ(3-JT)/SHPR  
12633         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
12634         ZMAX=MIN(1.-XH,ZMAX)    
12635         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340 
12636         KCC=22  
12637     
12638       ELSEIF(ISUB.EQ.78) THEN   
12639 C...W+/- + H0 -> W+/- + H0. 
12640     
12641       ELSEIF(ISUB.EQ.79) THEN   
12642 C...H0 + H0 -> H0 + H0. 
12643       ENDIF 
12644     
12645       ELSEIF(ISUB.LE.90) THEN   
12646       IF(ISUB.EQ.81) THEN   
12647 C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.   
12648         MINT(21)=ISIGN(MINT(46),MINT(15))   
12649         MINT(22)=-MINT(21)  
12650         KCC=4   
12651     
12652       ELSEIF(ISUB.EQ.82) THEN   
12653 C...g + g -> Q + Qb; th arbitrary.  
12654         KCS=(-1)**INT(1.5+RLU(0))   
12655         MINT(21)=ISIGN(MINT(46),KCS)    
12656         MINT(22)=-MINT(21)  
12657         KCC=MINT(2)+10  
12658       ENDIF 
12659     
12660       ELSEIF(ISUB.LE.100) THEN  
12661       IF(ISUB.EQ.95) THEN   
12662 C...Low-pT ( = energyless g + g -> g + g).  
12663         KCC=MINT(2)+12  
12664         KCS=(-1)**INT(1.5+RLU(0))   
12665     
12666       ELSEIF(ISUB.EQ.96) THEN   
12667 C...Multiple interactions (should be reassigned to QCD process).    
12668       ENDIF 
12669     
12670       ELSEIF(ISUB.LE.110) THEN  
12671       IF(ISUB.EQ.101) THEN  
12672 C...g + g -> gamma*/Z0. 
12673         KCC=21  
12674         KFRES=22    
12675     
12676       ELSEIF(ISUB.EQ.102) THEN  
12677 C...g + g -> H0.    
12678         KCC=21  
12679         KFRES=25    
12680       ENDIF 
12681     
12682       ELSEIF(ISUB.LE.120) THEN  
12683       IF(ISUB.EQ.111) THEN  
12684 C...f + fb -> g + H0; th arbitrary. 
12685         IF(RLU(0).GT.0.5) JS=2  
12686         MINT(20+JS)=21  
12687         MINT(23-JS)=25  
12688         KCC=17+JS   
12689     
12690       ELSEIF(ISUB.EQ.112) THEN  
12691 C...f + g -> f + H0; th = (p(f) - p(f))**2. 
12692         IF(MINT(15).EQ.21) JS=2 
12693         MINT(23-JS)=25  
12694         KCC=15+JS   
12695         KCS=ISIGN(1,MINT(14+JS))    
12696     
12697       ELSEIF(ISUB.EQ.113) THEN  
12698 C...g + g -> g + H0; th arbitrary.  
12699         IF(RLU(0).GT.0.5) JS=2  
12700         MINT(23-JS)=25  
12701         KCC=22+JS   
12702         KCS=(-1)**INT(1.5+RLU(0))   
12703     
12704       ELSEIF(ISUB.EQ.114) THEN  
12705 C...g + g -> gamma + gamma; th arbitrary.   
12706         IF(RLU(0).GT.0.5) JS=2  
12707         MINT(21)=22 
12708         MINT(22)=22 
12709         KCC=21  
12710     
12711       ELSEIF(ISUB.EQ.115) THEN  
12712 C...g + g -> gamma + Z0.    
12713     
12714       ELSEIF(ISUB.EQ.116) THEN  
12715 C...g + g -> Z0 + Z0.   
12716     
12717       ELSEIF(ISUB.EQ.117) THEN  
12718 C...g + g -> W+ + W-.   
12719       ENDIF 
12720     
12721       ELSEIF(ISUB.LE.140) THEN  
12722       IF(ISUB.EQ.121) THEN  
12723 C...g + g -> f + fb + H0.   
12724       ENDIF 
12725     
12726       ELSEIF(ISUB.LE.160) THEN  
12727       IF(ISUB.EQ.141) THEN  
12728 C...f + fb -> gamma*/Z0/Z'0.    
12729         KFRES=32    
12730     
12731       ELSEIF(ISUB.EQ.142) THEN  
12732 C...f + fb' -> H+/-.    
12733         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
12734         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
12735         KFRES=ISIGN(37,KCH1+KCH2)   
12736     
12737       ELSEIF(ISUB.EQ.143) THEN  
12738 C...f + fb' -> R.   
12739         KFRES=ISIGN(40,MINT(15)+MINT(16))   
12740       ENDIF 
12741     
12742       ELSE  
12743       IF(ISUB.EQ.161) THEN  
12744 C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.    
12745         IF(MINT(16).EQ.21) JS=2 
12746         IA=IABS(MINT(17-JS))    
12747         MINT(20+JS)=ISIGN(37,KCHG(IA,1)*MINT(17-JS))    
12748         JA=IA+MOD(IA,2)-MOD(IA+1,2) 
12749         MINT(23-JS)=ISIGN(JA,MINT(17-JS))   
12750         KCC=18-JS   
12751         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))    
12752         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))    
12753       ENDIF 
12754       ENDIF 
12755     
12756       IF(IDOC.EQ.7) THEN    
12757 C...Resonance not decaying: store colour connection indices.    
12758         I=MINT(83)+7    
12759         K(IPU3,1)=1 
12760         K(IPU3,2)=KFRES 
12761         K(IPU3,3)=I 
12762         P(IPU3,4)=SHUSER    
12763         P(IPU3,5)=SHUSER    
12764         K(IPU1,4)=IPU2  
12765         K(IPU1,5)=IPU2  
12766         K(IPU2,4)=IPU1  
12767         K(IPU2,5)=IPU1  
12768         K(I,1)=21   
12769         K(I,2)=KFRES    
12770         P(I,4)=SHUSER   
12771         P(I,5)=SHUSER   
12772         N=IPU3  
12773         MINT(21)=KFRES  
12774         MINT(22)=0  
12775     
12776       ELSEIF(IDOC.EQ.8) THEN    
12777 C...2 -> 2 processes: store outgoing partons in their CM-frame. 
12778         DO 390 JT=1,2   
12779         I=MINT(84)+2+JT 
12780         K(I,1)=1    
12781         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3   
12782         K(I,2)=MINT(20+JT)  
12783         K(I,3)=MINT(83)+IDOC+JT-2   
12784         IF(IABS(K(I,2)).LE.10.OR.K(I,2).EQ.21) THEN 
12785           P(I,5)=ULMASS(K(I,2)) 
12786         ELSE    
12787           P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))    
12788         ENDIF   
12789   390   CONTINUE    
12790         IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN 
12791           KFA1=IABS(MINT(21))   
12792           KFA2=IABS(MINT(22))   
12793           IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))  
12794      &    THEN  
12795             MINT(51)=1  
12796             RETURN  
12797           ENDIF 
12798           P(IPU3,5)=0.  
12799           P(IPU4,5)=0.  
12800         ENDIF   
12801         P(IPU3,4)=0.5*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR) 
12802         P(IPU3,3)=SQRT(MAX(0.,P(IPU3,4)**2-P(IPU3,5)**2))   
12803         P(IPU4,4)=SHR-P(IPU3,4) 
12804         P(IPU4,3)=-P(IPU3,3)    
12805         N=IPU4  
12806         MINT(7)=MINT(83)+7  
12807         MINT(8)=MINT(83)+8  
12808     
12809 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4). 
12810         CALL LUDBRB(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)  
12811     
12812       ELSEIF(IDOC.EQ.9) THEN    
12813 C'''2 -> 3 processes:   
12814     
12815       ELSEIF(IDOC.EQ.11) THEN   
12816 C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons. 
12817         PHI(1)=PARU(2)*RLU(0)   
12818         PHI(2)=PHI(1)-PHIR  
12819         DO 400 JT=1,2   
12820         I=MINT(84)+2+JT 
12821         K(I,1)=1    
12822         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3   
12823         K(I,2)=MINT(20+JT)  
12824         K(I,3)=MINT(83)+IDOC+JT-2   
12825         P(I,5)=ULMASS(K(I,2))   
12826         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.  
12827         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))    
12828         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2)) 
12829         P(I,1)=PTABS*COS(PHI(JT))   
12830         P(I,2)=PTABS*SIN(PHI(JT))   
12831         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)   
12832         P(I,4)=0.5*SHPR*Z(JT)   
12833         IZW=MINT(83)+6+JT   
12834         K(IZW,1)=21 
12835         K(IZW,2)=23 
12836         IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT)))    
12837         K(IZW,3)=IZW-2  
12838         P(IZW,1)=-P(I,1)    
12839         P(IZW,2)=-P(I,2)    
12840         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)  
12841         P(IZW,4)=0.5*SHPR*(1.-Z(JT))    
12842   400   P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))    
12843         I=MINT(83)+9    
12844         K(IPU5,1)=1 
12845         K(IPU5,2)=KFRES 
12846         K(IPU5,3)=I 
12847         P(IPU5,5)=SHR   
12848         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)  
12849         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)  
12850         P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)  
12851         P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)  
12852         K(I,1)=21   
12853         K(I,2)=KFRES    
12854         DO 410 J=1,5    
12855   410   P(I,J)=P(IPU5,J)    
12856         N=IPU5  
12857         MINT(23)=KFRES  
12858     
12859       ELSEIF(IDOC.EQ.12) THEN   
12860 C...Z0 and W+/- scattering: store bosons and outgoing partons.  
12861         PHI(1)=PARU(2)*RLU(0)   
12862         PHI(2)=PHI(1)-PHIR  
12863         DO 420 JT=1,2   
12864         I=MINT(84)+2+JT 
12865         K(I,1)=1    
12866         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3   
12867         K(I,2)=MINT(20+JT)  
12868         K(I,3)=MINT(83)+IDOC+JT-2   
12869         P(I,5)=ULMASS(K(I,2))   
12870         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.  
12871         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))    
12872         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2)) 
12873         P(I,1)=PTABS*COS(PHI(JT))   
12874         P(I,2)=PTABS*SIN(PHI(JT))   
12875         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)   
12876         P(I,4)=0.5*SHPR*Z(JT)   
12877         IZW=MINT(83)+6+JT   
12878         K(IZW,1)=21 
12879         IF(MINT(14+JT).EQ.MINT(20+JT)) THEN 
12880           K(IZW,2)=23   
12881         ELSE    
12882           K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT))-LUCHGE(MINT(20+JT)))    
12883         ENDIF   
12884         K(IZW,3)=IZW-2  
12885         P(IZW,1)=-P(I,1)    
12886         P(IZW,2)=-P(I,2)    
12887         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)  
12888         P(IZW,4)=0.5*SHPR*(1.-Z(JT))    
12889         P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))    
12890         IPU=MINT(84)+4+JT   
12891         K(IPU,1)=3  
12892         K(IPU,2)=KFPR(ISUB,JT)  
12893         K(IPU,3)=MINT(83)+8+JT  
12894         IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN 
12895           P(IPU,5)=ULMASS(K(IPU,2)) 
12896         ELSE    
12897           P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))  
12898         ENDIF   
12899         MINT(22+JT)=K(IZW,2)    
12900   420   CONTINUE    
12901         IF(ISUB.EQ.72) K(MINT(84)+4+INT(1.5+RLU(0)),2)=-24  
12902 C...Find rotation and boost for hard scattering subsystem.  
12903         I1=MINT(83)+7   
12904         I2=MINT(83)+8   
12905         BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))   
12906         BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))   
12907         BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))   
12908         GAMCM=(P(I1,4)+P(I2,4))/SHR 
12909         BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3) 
12910         PX=P(I1,1)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEXCM 
12911         PY=P(I1,2)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEYCM 
12912         PZ=P(I1,3)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEZCM 
12913         THECM=ULANGL(PZ,SQRT(PX**2+PY**2))  
12914         PHICM=ULANGL(PX,PY) 
12915 C...Store hard scattering subsystem. Rotate and boost it.   
12916         SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4.*P(IPU5,5)**2*    
12917      &  P(IPU6,5)**2    
12918         PABS=SQRT(MAX(0.,SQLAM/(4.*SH)))    
12919         CTHWZ=VINT(23)  
12920         STHWZ=SQRT(MAX(0.,1.-CTHWZ**2)) 
12921         PHIWZ=VINT(24)-PHICM    
12922         P(IPU5,1)=PABS*STHWZ*COS(PHIWZ) 
12923         P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ) 
12924         P(IPU5,3)=PABS*CTHWZ    
12925         P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)    
12926         P(IPU6,1)=-P(IPU5,1)    
12927         P(IPU6,2)=-P(IPU5,2)    
12928         P(IPU6,3)=-P(IPU5,3)    
12929         P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)    
12930         CALL LUDBRB(IPU5,IPU6,THECM,PHICM,DBLE(BEXCM),DBLE(BEYCM),  
12931      &  DBLE(BEZCM))    
12932         DO 430 JT=1,2   
12933         I1=MINT(83)+8+JT    
12934         I2=MINT(84)+4+JT    
12935         K(I1,1)=21  
12936         K(I1,2)=K(I2,2) 
12937         DO 430 J=1,5    
12938   430   P(I1,J)=P(I2,J) 
12939         N=IPU6  
12940         MINT(7)=MINT(83)+9  
12941         MINT(8)=MINT(83)+10 
12942       ENDIF 
12943     
12944       IF(IDOC.GE.8) THEN    
12945 C...Store colour connection indices.    
12946         DO 440 J=1,2    
12947         JC=J    
12948         IF(KCS.EQ.-1) JC=3-J    
12949         IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=    
12950      &  K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC) 
12951         IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=    
12952      &  K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC) 
12953         IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= 
12954      &  MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))   
12955   440   IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= 
12956      &  MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))   
12957     
12958 C...Copy outgoing partons to documentation lines.   
12959         DO 450 I=1,2    
12960         I1=MINT(83)+IDOC-2+I    
12961         I2=MINT(84)+2+I 
12962         K(I1,1)=21  
12963         K(I1,2)=K(I2,2) 
12964         IF(IDOC.LE.9) K(I1,3)=0 
12965         IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I 
12966         DO 450 J=1,5    
12967   450   P(I1,J)=P(I2,J) 
12968       ENDIF 
12969       MINT(52)=N    
12970     
12971 C...Low-pT events: remove gluons used for string drawing purposes.  
12972       IF(ISUB.EQ.95) THEN   
12973         K(IPU3,1)=K(IPU3,1)+10  
12974         K(IPU4,1)=K(IPU4,1)+10  
12975         DO 460 J=41,66  
12976   460   VINT(J)=0.  
12977         DO 470 I=MINT(83)+5,MINT(83)+8  
12978         DO 470 J=1,5    
12979   470   P(I,J)=0.   
12980       ENDIF 
12981     
12982       RETURN    
12983       END   
12984     
12985 C*********************************************************************  
12986     
12987       SUBROUTINE PYSSPA(IPU1,IPU2)  
12988     
12989 C...Generates spacelike parton showers. 
12990       IMPLICIT DOUBLE PRECISION(D)  
12991       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
12992       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
12993       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
12994       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
12995       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
12996       COMMON/PYINT1/MINT(400),VINT(400) 
12997       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
12998       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
12999       DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVS(2),ROBO(5),   
13000      &XFS(2,-6:6),XFA(-6:6),XFB(-6:6),XFN(-6:6),WTAP(-6:6),WTSF(-6:6),  
13001      &THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),DPB(4)   
13002       SAVE
13003     
13004 C...Calculate maximum virtuality and check that evolution possible. 
13005       IPUS1=IPU1    
13006       IPUS2=IPU2    
13007       ISUB=MINT(1)  
13008       Q2E=VINT(52)  
13009       IF(ISET(ISUB).EQ.1) THEN  
13010         Q2E=Q2E/PARP(67)    
13011       ELSEIF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN   
13012         Q2E=PMAS(23,1)**2   
13013         IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2E=PMAS(24,1)**2 
13014       ENDIF 
13015       TMAX=LOG(PARP(67)*PARP(63)*Q2E/PARP(61)**2)   
13016       IF(PARP(67)*Q2E.LT.MAX(PARP(62)**2,2.*PARP(61)**2).OR.    
13017      &TMAX.LT.0.2) RETURN   
13018     
13019 C...Common constants and initial values. Save normal Lambda value.  
13020       XE0=2.*PARP(65)/VINT(1)   
13021       ALAMS=PARU(111)   
13022       PARU(111)=PARP(61)    
13023       NS=N  
13024   100 N=NS  
13025       DO 110 JT=1,2 
13026       KFLS(JT)=MINT(14+JT)  
13027       KFLS(JT+2)=KFLS(JT)   
13028       XS(JT)=VINT(40+JT)    
13029       ZS(JT)=1. 
13030       Q2S(JT)=PARP(67)*Q2E  
13031       TEVS(JT)=TMAX 
13032       ALAM(JT)=PARP(61) 
13033       THE2(JT)=100. 
13034       DO 110 KFL=-6,6   
13035   110 XFS(JT,KFL)=XSFX(JT,KFL)  
13036       DSH=VINT(44)  
13037       IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) DSH=VINT(26)*VINT(2)   
13038     
13039 C...Pick up leg with highest virtuality.    
13040   120 N=N+1 
13041       JT=1  
13042       IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2   
13043       KFLB=KFLS(JT) 
13044       XB=XS(JT) 
13045       DO 130 KFL=-6,6   
13046   130 XFB(KFL)=XFS(JT,KFL)  
13047       DSHR=2D0*SQRT(DSH)    
13048       DSHZ=DSH/DBLE(ZS(JT)) 
13049       XE=MAX(XE0,XB*(1./(1.-PARP(66))-1.))  
13050       IF(XB+XE.GE.0.999) THEN   
13051         Q2B=0.  
13052         GOTO 220    
13053       ENDIF 
13054     
13055 C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.   
13056       IF(MSTP(62).LE.1) THEN    
13057         Q2B=0.5*(1./ZS(JT)+1.)*Q2S(JT)+0.5*(1./ZS(JT)-1.)*(Q2S(3-JT)-   
13058      &  SNGL(DSH)+SQRT((SNGL(DSH)+Q2S(1)+Q2S(2))**2+8.*Q2S(1)*Q2S(2)*   
13059      &  ZS(JT)/(1.-ZS(JT))))    
13060         TEVB=LOG(PARP(63)*Q2B/ALAM(JT)**2)  
13061       ELSE  
13062         Q2B=Q2S(JT) 
13063         TEVB=TEVS(JT)   
13064       ENDIF 
13065       ALSDUM=ULALPS(PARP(63)*Q2B)   
13066       TEVB=TEVB+2.*LOG(ALAM(JT)/PARU(117))  
13067       TEVBSV=TEVB   
13068       ALAM(JT)=PARU(117)    
13069       B0=(33.-2.*MSTU(118))/6.  
13070     
13071 C...Calculate Altarelli-Parisi and structure function weights.  
13072       DO 140 KFL=-6,6   
13073       WTAP(KFL)=0.  
13074   140 WTSF(KFL)=0.  
13075       IF(KFLB.EQ.21) THEN   
13076         WTAPQ=16.*(1.-SQRT(XB+XE))/(3.*SQRT(XB))    
13077         DO 150 KFL=-MSTP(54),MSTP(54)   
13078         IF(KFL.EQ.0) WTAP(KFL)=6.*LOG((1.-XB)/XE)   
13079   150   IF(KFL.NE.0) WTAP(KFL)=WTAPQ    
13080       ELSE  
13081         WTAP(0)=0.5*XB*(1./(XB+XE)-1.)  
13082         WTAP(KFLB)=8.*LOG((1.-XB)*(XB+XE)/XE)/3.    
13083       ENDIF 
13084   160 WTSUM=0.  
13085       IF(KFLB.NE.21) XFBO=XFB(KFLB) 
13086       IF(KFLB.EQ.21) XFBO=XFB(0)
13087 C***************************************************************
13088 C**********ERROR HAS OCCURED HERE
13089       IF(XFBO.EQ.0.0) THEN
13090                 WRITE(MSTU(11),1000)
13091                 WRITE(MSTU(11),1001) KFLB,XFB(KFLB)
13092                 XFBO=0.00001
13093       ENDIF
13094 C****************************************************************    
13095       DO 170 KFL=-MSTP(54),MSTP(54) 
13096       WTSF(KFL)=XFB(KFL)/XFBO   
13097   170 WTSUM=WTSUM+WTAP(KFL)*WTSF(KFL)   
13098       WTSUM=MAX(0.0001,WTSUM)   
13099     
13100 C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).  
13101   180 IF(MSTP(64).LE.0) THEN    
13102         TEVB=TEVB+LOG(RLU(0))*PARU(2)/(PARU(111)*WTSUM) 
13103       ELSEIF(MSTP(64).EQ.1) THEN    
13104         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/WTSUM))  
13105       ELSE  
13106         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/(5.*WTSUM))) 
13107       ENDIF 
13108   190 Q2REF=ALAM(JT)**2*EXP(TEVB)   
13109       Q2B=Q2REF/PARP(63)    
13110     
13111 C...Evolution ended or select flavour for branching parton. 
13112       IF(Q2B.LT.PARP(62)**2) THEN   
13113         Q2B=0.  
13114       ELSE  
13115         WTRAN=RLU(0)*WTSUM  
13116         KFLA=-MSTP(54)-1    
13117   200   KFLA=KFLA+1 
13118         WTRAN=WTRAN-WTAP(KFLA)*WTSF(KFLA)   
13119         IF(KFLA.LT.MSTP(54).AND.WTRAN.GT.0.) GOTO 200   
13120         IF(KFLA.EQ.0) KFLA=21   
13121     
13122 C...Choose z value and corrective weight.   
13123         IF(KFLB.EQ.21.AND.KFLA.EQ.21) THEN  
13124           Z=1./(1.+((1.-XB)/XB)*(XE/(1.-XB))**RLU(0))   
13125           WTZ=(1.-Z*(1.-Z))**2  
13126         ELSEIF(KFLB.EQ.21) THEN 
13127           Z=XB/(1.-RLU(0)*(1.-SQRT(XB+XE)))**2  
13128           WTZ=0.5*(1.+(1.-Z)**2)*SQRT(Z)    
13129         ELSEIF(KFLA.EQ.21) THEN 
13130           Z=XB*(1.+RLU(0)*(1./(XB+XE)-1.))  
13131           WTZ=1.-2.*Z*(1.-Z)    
13132         ELSE    
13133           Z=1.-(1.-XB)*(XE/((XB+XE)*(1.-XB)))**RLU(0)   
13134           WTZ=0.5*(1.+Z**2) 
13135         ENDIF   
13136     
13137 C...Option with resummation of soft gluon emission as effective z shift.    
13138         IF(MSTP(65).GE.1) THEN  
13139           RSOFT=6.  
13140           IF(KFLB.NE.21) RSOFT=8./3.    
13141           Z=Z*(TEVB/TEVS(JT))**(RSOFT*XE/((XB+XE)*B0))  
13142           IF(Z.LE.XB) GOTO 180  
13143         ENDIF   
13144     
13145 C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.   
13146         IF(MSTP(64).GE.2) THEN  
13147           IF((1.-Z)*Q2B.LT.PARP(62)**2) GOTO 180    
13148           ALPRAT=TEVB/(TEVB+LOG(1.-Z))  
13149           IF(ALPRAT.LT.5.*RLU(0)) GOTO 180  
13150           IF(ALPRAT.GT.5.) WTZ=WTZ*ALPRAT/5.    
13151         ENDIF   
13152     
13153 C...Option with angular ordering requirement.   
13154         IF(MSTP(62).GE.3) THEN  
13155           THE2T=(4.*Z**2*Q2B)/(VINT(2)*(1.-Z)*XB**2)    
13156           IF(THE2T.GT.THE2(JT)) GOTO 180    
13157         ENDIF   
13158     
13159 C...Weighting with new structure functions. 
13160         CALL PYSTFU(MINT(10+JT),XB,Q2REF,XFN,JT)   
13161         IF(KFLB.NE.21) XFBN=XFN(KFLB)   
13162         IF(KFLB.EQ.21) XFBN=XFN(0)  
13163         IF(XFBN.LT.1E-20) THEN  
13164           IF(KFLA.EQ.KFLB) THEN 
13165             TEVB=TEVBSV 
13166             WTAP(KFLB)=0.   
13167             GOTO 160    
13168           ELSEIF(TEVBSV-TEVB.GT.0.2) THEN   
13169             TEVB=0.5*(TEVBSV+TEVB)  
13170             GOTO 190    
13171           ELSE  
13172             XFBN=1E-10  
13173           ENDIF 
13174         ENDIF   
13175         DO 210 KFL=-MSTP(54),MSTP(54)   
13176   210   XFB(KFL)=XFN(KFL)   
13177         XA=XB/Z 
13178         CALL PYSTFU(MINT(10+JT),XA,Q2REF,XFA,JT)   
13179         IF(KFLA.NE.21) XFAN=XFA(KFLA)   
13180         IF(KFLA.EQ.21) XFAN=XFA(0)  
13181         IF(XFAN.LT.1E-20) GOTO 160  
13182         IF(KFLA.NE.21) WTSFA=WTSF(KFLA) 
13183         IF(KFLA.EQ.21) WTSFA=WTSF(0)    
13184         IF(WTZ*XFAN/XFBN.LT.RLU(0)*WTSFA) GOTO 160  
13185       ENDIF 
13186     
13187 C...Define two hard scatterers in their CM-frame.   
13188   220 IF(N.EQ.NS+2) THEN    
13189         DQ2(JT)=Q2B 
13190         DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR   
13191         DO 240 JR=1,2   
13192         I=NS+JR 
13193         IF(JR.EQ.1) IPO=IPUS1   
13194         IF(JR.EQ.2) IPO=IPUS2   
13195         DO 230 J=1,5    
13196         K(I,J)=0    
13197         P(I,J)=0.   
13198   230   V(I,J)=0.   
13199         K(I,1)=14   
13200         K(I,2)=KFLS(JR+2)   
13201         K(I,4)=IPO  
13202         K(I,5)=IPO  
13203         P(I,3)=DPLCM*(-1)**(JR+1)   
13204         P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR 
13205         P(I,5)=-SQRT(SNGL(DQ2(JR))) 
13206         K(IPO,1)=14 
13207         K(IPO,3)=I  
13208         K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I    
13209   240   K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I    
13210     
13211 C...Find maximum allowed mass of timelike parton.   
13212       ELSEIF(N.GT.NS+2) THEN    
13213         JR=3-JT 
13214         DQ2(3)=Q2B  
13215         DPC(1)=P(IS(1),4)   
13216         DPC(2)=P(IS(2),4)   
13217         DPC(3)=0.5*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))    
13218         DPD(1)=DSH+DQ2(JR)+DQ2(JT)  
13219         DPD(2)=DSHZ+DQ2(JR)+DQ2(3)  
13220         DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))  
13221         DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))   
13222         IKIN=0  
13223         IF(Q2S(JR).GE.(0.5*PARP(62))**2.AND.DPD(1)-DPD(3).GE.   
13224      &  1D-10*DPD(1)) IKIN=1    
13225         IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/DBLE(ZS(JT))-DQ2(3))*(DSH/ 
13226      &  (DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))    
13227         IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/(2.*  
13228      &  DQ2(JR))-DQ2(JT)-DQ2(3) 
13229     
13230 C...Generate timelike parton shower (if required).  
13231         IT=N    
13232         DO 250 J=1,5    
13233         K(IT,J)=0   
13234         P(IT,J)=0.  
13235   250   V(IT,J)=0.  
13236         K(IT,1)=3   
13237         K(IT,2)=21  
13238         IF(KFLB.EQ.21.AND.KFLS(JT+2).NE.21) K(IT,2)=-KFLS(JT+2) 
13239         IF(KFLB.NE.21.AND.KFLS(JT+2).EQ.21) K(IT,2)=KFLB    
13240         P(IT,5)=ULMASS(K(IT,2)) 
13241         IF(SNGL(DMSMA).LE.P(IT,5)**2) GOTO 100  
13242         IF(MSTP(63).GE.1) THEN  
13243           P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR    
13244           P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)   
13245           IF(MSTP(63).EQ.1) THEN    
13246             Q2TIM=DMSMA 
13247           ELSEIF(MSTP(63).EQ.2) THEN    
13248             Q2TIM=MIN(SNGL(DMSMA),PARP(71)*Q2S(JT)) 
13249           ELSE  
13250 C'''Here remains to introduce angular ordering in first branching.  
13251             Q2TIM=DMSMA 
13252           ENDIF 
13253           CALL LUSHOW(IT,0,SQRT(Q2TIM)) 
13254           IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)   
13255         ENDIF   
13256     
13257 C...Reconstruct kinematics of branching: timelike parton shower.    
13258         DMS=P(IT,5)**2  
13259         IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))  
13260         IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5*DPD(1)*DPD(2)+0.5*DPD(3)*   
13261      &  DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.*DSH*DPC(3)**2) 
13262         IF(DPT2.LT.0.) GOTO 100 
13263         DPB(1)=(0.5*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/  
13264      &  DSHR)/DPC(3)-DPC(3) 
13265         P(IT,1)=SQRT(SNGL(DPT2))    
13266         P(IT,3)=DPB(1)*(-1)**(JT+1) 
13267         P(IT,4)=(DSHZ-DSH-DMS)/DSHR 
13268         IF(N.GE.IT+1) THEN  
13269           DPB(1)=SQRT(DPB(1)**2+DPT2)   
13270           DPB(2)=SQRT(DPB(1)**2+DMS)    
13271           DPB(3)=P(IT+1,3)  
13272           DPB(4)=SQRT(DPB(3)**2+DMS)    
13273           DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)* 
13274      &    DPB(1))   
13275           CALL LUDBRB(IT+1,N,0.,0.,0D0,0D0,DBEZ)    
13276           THE=ULANGL(P(IT,3),P(IT,1))   
13277           CALL LUDBRB(IT+1,N,THE,0.,0D0,0D0,0D0)    
13278         ENDIF   
13279     
13280 C...Reconstruct kinematics of branching: spacelike parton.  
13281         DO 260 J=1,5    
13282         K(N+1,J)=0  
13283         P(N+1,J)=0. 
13284   260   V(N+1,J)=0. 
13285         K(N+1,1)=14 
13286         K(N+1,2)=KFLB   
13287         P(N+1,1)=P(IT,1)    
13288         P(N+1,3)=P(IT,3)+P(IS(JT),3)    
13289         P(N+1,4)=P(IT,4)+P(IS(JT),4)    
13290         P(N+1,5)=-SQRT(SNGL(DQ2(3)))    
13291     
13292 C...Define colour flow of branching.    
13293         K(IS(JT),3)=N+1 
13294         K(IT,3)=N+1 
13295         ID1=IT  
13296         IF((K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(ID1,2).GT.0.AND. 
13297      &  K(ID1,2).NE.21).OR.(K(N+1,2).LT.0.AND.K(ID1,2).EQ.21).OR.   
13298      &  (K(N+1,2).EQ.21.AND.K(ID1,2).EQ.21.AND.RLU(0).GT.0.5).OR.   
13299      &  (K(N+1,2).EQ.21.AND.K(ID1,2).LT.0)) ID1=IS(JT)  
13300         ID2=IT+IS(JT)-ID1   
13301         K(N+1,4)=K(N+1,4)+ID1   
13302         K(N+1,5)=K(N+1,5)+ID2   
13303         K(ID1,4)=K(ID1,4)+MSTU(5)*(N+1) 
13304         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2   
13305         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1   
13306         K(ID2,5)=K(ID2,5)+MSTU(5)*(N+1) 
13307         N=N+1   
13308     
13309 C...Boost to new CM-frame.  
13310         CALL LUDBRB(NS+1,N,0.,0.,-DBLE((P(N,1)+P(IS(JR),1))/(P(N,4)+    
13311      &  P(IS(JR),4))),0D0,-DBLE((P(N,3)+P(IS(JR),3))/(P(N,4)+   
13312      &  P(IS(JR),4))))  
13313         IR=N+(JT-1)*(IS(1)-N)   
13314         CALL LUDBRB(NS+1,N,-ULANGL(P(IR,3),P(IR,1)),PARU(2)*RLU(0), 
13315      &  0D0,0D0,0D0)    
13316       ENDIF 
13317     
13318 C...Save quantities, loop back. 
13319       IS(JT)=N  
13320       Q2S(JT)=Q2B   
13321       DQ2(JT)=Q2B   
13322       IF(MSTP(62).GE.3) THE2(JT)=THE2T  
13323       DSH=DSHZ  
13324       IF(Q2B.GE.(0.5*PARP(62))**2) THEN 
13325         KFLS(JT+2)=KFLS(JT) 
13326         KFLS(JT)=KFLA   
13327         XS(JT)=XA   
13328         ZS(JT)=Z    
13329         DO 270 KFL=-6,6 
13330   270   XFS(JT,KFL)=XFA(KFL)    
13331         TEVS(JT)=TEVB   
13332       ELSE  
13333         IF(JT.EQ.1) IPU1=N  
13334         IF(JT.EQ.2) IPU2=N  
13335       ENDIF 
13336       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN 
13337         CALL LUERRM(11,'(PYSSPA:) no more memory left in LUJETS')   
13338         IF(MSTU(21).GE.1) N=NS  
13339         IF(MSTU(21).GE.1) RETURN    
13340       ENDIF 
13341       IF(MAX(Q2S(1),Q2S(2)).GE.(0.5*PARP(62))**2.OR.N.LE.NS+1) GOTO 120 
13342     
13343 C...Boost hard scattering partons to frame of shower initiators.    
13344       DO 280 J=1,3  
13345   280 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4)) 
13346       DO 290 J=1,5  
13347   290 P(N+2,J)=P(NS+1,J)    
13348       ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2    
13349       IF(ROBOT.GE.0.999999) THEN    
13350         ROBOT=1.00001*SQRT(ROBOT)   
13351         ROBO(3)=ROBO(3)/ROBOT   
13352         ROBO(4)=ROBO(4)/ROBOT   
13353         ROBO(5)=ROBO(5)/ROBOT   
13354       ENDIF 
13355       CALL LUDBRB(N+2,N+2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),  
13356      &-DBLE(ROBO(5)))   
13357       ROBO(2)=ULANGL(P(N+2,1),P(N+2,2)) 
13358       ROBO(1)=ULANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))    
13359       CALL LUDBRB(MINT(83)+5,NS,ROBO(1),ROBO(2),DBLE(ROBO(3)),  
13360      &DBLE(ROBO(4)),DBLE(ROBO(5)))  
13361     
13362 C...Store user information. Reset Lambda value. 
13363       K(IPU1,3)=MINT(83)+3  
13364       K(IPU2,3)=MINT(83)+4  
13365       DO 300 JT=1,2 
13366       MINT(12+JT)=KFLS(JT)  
13367   300 VINT(140+JT)=XS(JT)   
13368       PARU(111)=ALAMS   
13369  1000 FORMAT(5X,'structure function has a zero point here')
13370  1001 FORMAT(5X,'xf(x,i=',I5,')=',F10.5)
13371 
13372       RETURN    
13373       END   
13374     
13375 C*********************************************************************  
13376     
13377       SUBROUTINE PYMULT(MMUL)   
13378     
13379 C...Initializes treatment of multiple interactions, selects kinematics  
13380 C...of hardest interaction if low-pT physics included in run, and   
13381 C...generates all non-hardest interactions. 
13382       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
13383       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
13384       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
13385       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
13386       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
13387       COMMON/PYINT1/MINT(400),VINT(400) 
13388       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
13389       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
13390       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
13391       DIMENSION NMUL(20),SIGM(20),KSTR(500,2)   
13392       SAVE
13393     
13394 C...Initialization of multiple interaction treatment.   
13395       IF(MMUL.EQ.1) THEN    
13396         IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(82)    
13397         ISUB=96 
13398         MINT(1)=96  
13399         VINT(63)=0. 
13400         VINT(64)=0. 
13401         VINT(143)=1.    
13402         VINT(144)=1.    
13403     
13404 C...Loop over phase space points: xT2 choice in 20 bins.    
13405   100   SIGSUM=0.   
13406         DO 120 IXT2=1,20    
13407         NMUL(IXT2)=MSTP(83) 
13408         SIGM(IXT2)=0.   
13409         DO 110 ITRY=1,MSTP(83)  
13410         RSCA=0.05*((21-IXT2)-RLU(0))    
13411         XT2=VINT(149)*(1.+VINT(149))/(VINT(149)+RSCA)-VINT(149) 
13412         XT2=MAX(0.01*VINT(149),XT2) 
13413         VINT(25)=XT2    
13414     
13415 C...Choose tau and y*. Calculate cos(theta-hat).    
13416         IF(RLU(0).LE.COEF(ISUB,1)) THEN 
13417           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)    
13418           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)    
13419         ELSE    
13420           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2) 
13421         ENDIF   
13422         VINT(21)=TAU    
13423         CALL PYKLIM(2)  
13424         RYST=RLU(0) 
13425         MYST=1  
13426         IF(RYST.GT.COEF(ISUB,7)) MYST=2 
13427         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3    
13428         CALL PYKMAP(2,MYST,RLU(0))  
13429         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0)) 
13430     
13431 C...Calculate differential cross-section.   
13432         VINT(71)=0.5*VINT(1)*SQRT(XT2)  
13433         CALL PYSIGH(NCHN,SIGS)  
13434   110   SIGM(IXT2)=SIGM(IXT2)+SIGS  
13435   120   SIGSUM=SIGSUM+SIGM(IXT2)    
13436         SIGSUM=SIGSUM/(20.*MSTP(83))    
13437     
13438 C...Reject result if sigma(parton-parton) is smaller than hadronic one. 
13439         IF(SIGSUM.LT.1.1*VINT(106)) THEN    
13440           IF(MSTP(122).GE.1) WRITE(MSTU(11),1100) PARP(82),SIGSUM   
13441           PARP(82)=0.9*PARP(82) 
13442           VINT(149)=4.*PARP(82)**2/VINT(2)  
13443           GOTO 100  
13444         ENDIF   
13445         IF(MSTP(122).GE.1) WRITE(MSTU(11),1200) PARP(82), SIGSUM    
13446     
13447 C...Start iteration to find k factor.   
13448         YKE=SIGSUM/VINT(106)    
13449         SO=0.5  
13450         XI=0.   
13451         YI=0.   
13452         XK=0.5  
13453         IIT=0   
13454   130   IF(IIT.EQ.0) THEN   
13455           XK=2.*XK  
13456         ELSEIF(IIT.EQ.1) THEN   
13457           XK=0.5*XK 
13458         ELSE    
13459           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)    
13460         ENDIF   
13461     
13462 C...Evaluate overlap integrals. 
13463         IF(MSTP(82).EQ.2) THEN  
13464           SP=0.5*PARU(1)*(1.-EXP(-XK))  
13465           SOP=SP/PARU(1)    
13466         ELSE    
13467           IF(MSTP(82).EQ.3) DELTAB=0.02 
13468           IF(MSTP(82).EQ.4) DELTAB=MIN(0.01,0.05*PARP(84))  
13469           SP=0. 
13470           SOP=0.    
13471           B=-0.5*DELTAB 
13472   140     B=B+DELTAB    
13473           IF(MSTP(82).EQ.3) THEN    
13474             OV=EXP(-B**2)/PARU(2)   
13475           ELSE  
13476             CQ2=PARP(84)**2 
13477             OV=((1.-PARP(83))**2*EXP(-MIN(100.,B**2))+2.*PARP(83)*  
13478      &      (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B**2*2./(1.+CQ2)))+ 
13479      &      PARP(83)**2/CQ2*EXP(-MIN(100.,B**2/CQ2)))/PARU(2)   
13480           ENDIF 
13481           PACC=1.-EXP(-MIN(100.,PARU(1)*XK*OV)) 
13482           SP=SP+PARU(2)*B*DELTAB*PACC   
13483           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC  
13484           IF(B.LT.1..OR.B*PACC.GT.1E-6) GOTO 140    
13485         ENDIF   
13486         YK=PARU(1)*XK*SO/SP 
13487     
13488 C...Continue iteration until convergence.   
13489         IF(YK.LT.YKE) THEN  
13490           XI=XK 
13491           YI=YK 
13492           IF(IIT.EQ.1) IIT=2    
13493         ELSE    
13494           XF=XK 
13495           YF=YK 
13496           IF(IIT.EQ.0) IIT=1    
13497         ENDIF   
13498         IF(ABS(YK-YKE).GE.1E-5*YKE) GOTO 130    
13499     
13500 C...Store some results for subsequent use.  
13501         VINT(145)=SIGSUM    
13502         VINT(146)=SOP/SO    
13503         VINT(147)=SOP/SP    
13504     
13505 C...Initialize iteration in xT2 for hardest interaction.    
13506       ELSEIF(MMUL.EQ.2) THEN    
13507         IF(MSTP(82).LE.0) THEN  
13508         ELSEIF(MSTP(82).EQ.1) THEN  
13509           XT2=1.    
13510           XT2FAC=XSEC(96,1)/VINT(106)*VINT(149)/(1.-VINT(149))  
13511         ELSEIF(MSTP(82).EQ.2) THEN  
13512           XT2=1.    
13513           XT2FAC=VINT(146)*XSEC(96,1)/VINT(106)*VINT(149)*(1.+VINT(149))    
13514         ELSE    
13515           XC2=4.*CKIN(3)**2/VINT(2) 
13516           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0.    
13517         ENDIF   
13518     
13519       ELSEIF(MMUL.EQ.3) THEN    
13520 C...Low-pT or multiple interactions (first semihard interaction):   
13521 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)    
13522 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).   
13523         ISUB=MINT(1)    
13524         IF(MSTP(82).LE.0) THEN  
13525           XT2=0.    
13526         ELSEIF(MSTP(82).EQ.1) THEN  
13527           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))   
13528         ELSEIF(MSTP(82).EQ.2) THEN  
13529           IF(XT2.LT.1..AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+ 
13530      &    VINT(149)))).GT.RLU(0)) XT2=1.    
13531           IF(XT2.GE.1.) THEN    
13532             XT2=(1.+VINT(149))*XT2FAC/(XT2FAC-(1.+VINT(149))*LOG(1.-    
13533      &      RLU(0)*(1.-EXP(-XT2FAC/(VINT(149)*(1.+VINT(149)))))))-  
13534      &      VINT(149)   
13535           ELSE  
13536             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+RLU(0)*    
13537      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))- 
13538      &      VINT(149)   
13539           ENDIF 
13540           XT2=MAX(0.01*VINT(149),XT2)   
13541         ELSE    
13542           XT2=(XC2+VINT(149))*(1.+VINT(149))/(1.+VINT(149)- 
13543      &    RLU(0)*(1.-XC2))-VINT(149)    
13544           XT2=MAX(0.01*VINT(149),XT2)   
13545         ENDIF   
13546         VINT(25)=XT2    
13547     
13548 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.   
13549         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN 
13550           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1   
13551           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1 
13552           ISUB=95   
13553           MINT(1)=ISUB  
13554           VINT(21)=0.01*VINT(149)   
13555           VINT(22)=0.   
13556           VINT(23)=0.   
13557           VINT(25)=0.01*VINT(149)   
13558     
13559         ELSE    
13560 C...Multiple interactions (first semihard interaction). 
13561 C...Choose tau and y*. Calculate cos(theta-hat).    
13562           IF(RLU(0).LE.COEF(ISUB,1)) THEN   
13563             TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)  
13564             TAU=XT2*(1.+TAUP)**2/(4.*TAUP)  
13565           ELSE  
13566             TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)   
13567           ENDIF 
13568           VINT(21)=TAU  
13569           CALL PYKLIM(2)    
13570           RYST=RLU(0)   
13571           MYST=1    
13572           IF(RYST.GT.COEF(ISUB,7)) MYST=2   
13573           IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3  
13574           CALL PYKMAP(2,MYST,RLU(0))    
13575           VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))   
13576         ENDIF   
13577         VINT(71)=0.5*VINT(1)*SQRT(VINT(25)) 
13578     
13579 C...Store results of cross-section calculation. 
13580       ELSEIF(MMUL.EQ.4) THEN    
13581         ISUB=MINT(1)    
13582         XTS=VINT(25)    
13583         IF(ISET(ISUB).EQ.1) XTS=VINT(21)    
13584         IF(ISET(ISUB).EQ.2) XTS=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/  
13585      &  VINT(2) 
13586         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XTS=VINT(26) 
13587         RBIN=MAX(0.000001,MIN(0.999999,XTS*(1.+VINT(149))/  
13588      &  (XTS+VINT(149))))   
13589         IRBIN=INT(1.+20.*RBIN)  
13590         IF(ISUB.EQ.96) NMUL(IRBIN)=NMUL(IRBIN)+1    
13591         IF(ISUB.EQ.96) SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)    
13592     
13593 C...Choose impact parameter.    
13594       ELSEIF(MMUL.EQ.5) THEN    
13595         IF(MSTP(82).EQ.3) THEN  
13596           VINT(148)=RLU(0)/(PARU(2)*VINT(147))  
13597         ELSE    
13598           RTYPE=RLU(0)  
13599           CQ2=PARP(84)**2   
13600           IF(RTYPE.LT.(1.-PARP(83))**2) THEN    
13601             B2=-LOG(RLU(0)) 
13602           ELSEIF(RTYPE.LT.1.-PARP(83)**2) THEN  
13603             B2=-0.5*(1.+CQ2)*LOG(RLU(0))    
13604           ELSE  
13605             B2=-CQ2*LOG(RLU(0)) 
13606           ENDIF 
13607           VINT(148)=((1.-PARP(83))**2*EXP(-MIN(100.,B2))+2.*PARP(83)*   
13608      &    (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B2*2./(1.+CQ2)))+ 
13609      &    PARP(83)**2/CQ2*EXP(-MIN(100.,B2/CQ2)))/(PARU(2)*VINT(147))   
13610         ENDIF   
13611     
13612 C...Multiple interactions (variable impact parameter) : reject with 
13613 C...probability exp(-overlap*cross-section above pT/normalization). 
13614         RNCOR=(IRBIN-20.*RBIN)*NMUL(IRBIN)  
13615         SIGCOR=(IRBIN-20.*RBIN)*SIGM(IRBIN) 
13616         DO 150 IBIN=IRBIN+1,20  
13617         RNCOR=RNCOR+NMUL(IBIN)  
13618   150   SIGCOR=SIGCOR+SIGM(IBIN)    
13619         SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1.-XTS)/(XTS+VINT(149))    
13620         VINT(150)=EXP(-MIN(100.,VINT(146)*VINT(148)*SIGABV/VINT(106)))  
13621     
13622 C...Generate additional multiple semihard interactions. 
13623       ELSEIF(MMUL.EQ.6) THEN    
13624     
13625 C...Reconstruct strings in hard scattering. 
13626         ISUB=MINT(1)    
13627         NMAX=MINT(84)+4 
13628         IF(ISET(ISUB).EQ.1) NMAX=MINT(84)+2 
13629         NSTR=0  
13630         DO 170 I=MINT(84)+1,NMAX    
13631         KCS=KCHG(LUCOMP(K(I,2)),2)*ISIGN(1,K(I,2))  
13632         IF(KCS.EQ.0) GOTO 170   
13633         DO 160 J=1,4    
13634         IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 160    
13635         IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 160   
13636         IF(J.LE.2) THEN 
13637           IST=MOD(K(I,J+3)/MSTU(5),MSTU(5)) 
13638         ELSE    
13639           IST=MOD(K(I,J+1),MSTU(5)) 
13640         ENDIF   
13641         IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 160    
13642         IF(KCHG(LUCOMP(K(IST,2)),2).EQ.0) GOTO 160  
13643         NSTR=NSTR+1 
13644         IF(J.EQ.1.OR.J.EQ.4) THEN   
13645           KSTR(NSTR,1)=I    
13646           KSTR(NSTR,2)=IST  
13647         ELSE    
13648           KSTR(NSTR,1)=IST  
13649           KSTR(NSTR,2)=I    
13650         ENDIF   
13651   160   CONTINUE    
13652   170   CONTINUE    
13653     
13654 C...Set up starting values for iteration in xT2.    
13655         XT2=VINT(25)    
13656         IF(ISET(ISUB).EQ.1) XT2=VINT(21)    
13657         IF(ISET(ISUB).EQ.2) XT2=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/  
13658      &  VINT(2) 
13659         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XT2=VINT(26) 
13660         ISUB=96 
13661         MINT(1)=96  
13662         IF(MSTP(82).LE.1) THEN  
13663           XT2FAC=XSEC(ISUB,1)*VINT(149)/((1.-VINT(149))*VINT(106))  
13664         ELSE    
13665           XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/VINT(106)*    
13666      &    VINT(149)*(1.+VINT(149))  
13667         ENDIF   
13668         VINT(63)=0. 
13669         VINT(64)=0. 
13670         VINT(151)=0.    
13671         VINT(152)=0.    
13672         VINT(143)=1.-VINT(141)  
13673         VINT(144)=1.-VINT(142)  
13674     
13675 C...Iterate downwards in xT2.   
13676   180   IF(MSTP(82).LE.1) THEN  
13677           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))   
13678           IF(XT2.LT.VINT(149)) GOTO 220 
13679         ELSE    
13680           IF(XT2.LE.0.01*VINT(149)) GOTO 220    
13681           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*   
13682      &    LOG(RLU(0)))-VINT(149)    
13683           IF(XT2.LE.0.) GOTO 220    
13684           XT2=MAX(0.01*VINT(149),XT2)   
13685         ENDIF   
13686         VINT(25)=XT2    
13687     
13688 C...Choose tau and y*. Calculate cos(theta-hat).    
13689         IF(RLU(0).LE.COEF(ISUB,1)) THEN 
13690           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)    
13691           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)    
13692         ELSE    
13693           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2) 
13694         ENDIF   
13695         VINT(21)=TAU    
13696         CALL PYKLIM(2)  
13697         RYST=RLU(0) 
13698         MYST=1  
13699         IF(RYST.GT.COEF(ISUB,7)) MYST=2 
13700         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3    
13701         CALL PYKMAP(2,MYST,RLU(0))  
13702         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0)) 
13703     
13704 C...Check that x not used up. Accept or reject kinematical variables.   
13705         X1M=SQRT(TAU)*EXP(VINT(22)) 
13706         X2M=SQRT(TAU)*EXP(-VINT(22))    
13707         IF(VINT(143)-X1M.LT.0.01.OR.VINT(144)-X2M.LT.0.01) GOTO 180 
13708         VINT(71)=0.5*VINT(1)*SQRT(XT2)  
13709         CALL PYSIGH(NCHN,SIGS)  
13710         IF(SIGS.LT.XSEC(ISUB,1)*RLU(0)) GOTO 180    
13711     
13712 C...Reset K, P and V vectors. Select some variables.    
13713         DO 190 I=N+1,N+2    
13714         DO 190 J=1,5    
13715         K(I,J)=0    
13716         P(I,J)=0.   
13717   190   V(I,J)=0.   
13718         RFLAV=RLU(0)    
13719         PT=0.5*VINT(1)*SQRT(XT2)    
13720         PHI=PARU(2)*RLU(0)  
13721         CTH=VINT(23)    
13722     
13723 C...Add first parton to event record.   
13724         K(N+1,1)=3  
13725         K(N+1,2)=21 
13726         IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=   
13727      &  1+INT((2.+PARJ(2))*RLU(0))  
13728         P(N+1,1)=PT*COS(PHI)    
13729         P(N+1,2)=PT*SIN(PHI)    
13730         P(N+1,3)=0.25*VINT(1)*(VINT(41)*(1.+CTH)-VINT(42)*(1.-CTH)) 
13731         P(N+1,4)=0.25*VINT(1)*(VINT(41)*(1.+CTH)+VINT(42)*(1.-CTH)) 
13732         P(N+1,5)=0. 
13733     
13734 C...Add second parton to event record.  
13735         K(N+2,1)=3  
13736         K(N+2,2)=21 
13737         IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)   
13738         P(N+2,1)=-P(N+1,1)  
13739         P(N+2,2)=-P(N+1,2)  
13740         P(N+2,3)=0.25*VINT(1)*(VINT(41)*(1.-CTH)-VINT(42)*(1.+CTH)) 
13741         P(N+2,4)=0.25*VINT(1)*(VINT(41)*(1.-CTH)+VINT(42)*(1.+CTH)) 
13742         P(N+2,5)=0. 
13743     
13744         IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN    
13745 C....Choose relevant string pieces to place gluons on.  
13746           DO 210 I=N+1,N+2  
13747           DMIN=1E8  
13748           DO 200 ISTR=1,NSTR    
13749           I1=KSTR(ISTR,1)   
13750           I2=KSTR(ISTR,2)   
13751           DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-   
13752      &    P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-   
13753      &    P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1.,P(I1,4)*P(I2,4)-    
13754      &    P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))  
13755           IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN    
13756             DMIN=DIST   
13757             IST1=I1 
13758             IST2=I2 
13759             ISTM=ISTR   
13760           ENDIF 
13761   200     CONTINUE  
13762     
13763 C....Colour flow adjustments, new string pieces.    
13764           IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+    
13765      &    MOD(K(IST1,4),MSTU(5))    
13766           IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)= 
13767      &    MSTU(5)*(K(IST1,5)/MSTU(5))+I 
13768           K(I,5)=MSTU(5)*IST1   
13769           K(I,4)=MSTU(5)*IST2   
13770           IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+    
13771      &    MOD(K(IST2,5),MSTU(5))    
13772           IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)= 
13773      &    MSTU(5)*(K(IST2,4)/MSTU(5))+I 
13774           KSTR(ISTM,2)=I    
13775           KSTR(NSTR+1,1)=I  
13776           KSTR(NSTR+1,2)=IST2   
13777   210     NSTR=NSTR+1   
13778     
13779 C...String drawing and colour flow for gluon loop.  
13780         ELSEIF(K(N+1,2).EQ.21) THEN 
13781           K(N+1,4)=MSTU(5)*(N+2)    
13782           K(N+1,5)=MSTU(5)*(N+2)    
13783           K(N+2,4)=MSTU(5)*(N+1)    
13784           K(N+2,5)=MSTU(5)*(N+1)    
13785           KSTR(NSTR+1,1)=N+1    
13786           KSTR(NSTR+1,2)=N+2    
13787           KSTR(NSTR+2,1)=N+2    
13788           KSTR(NSTR+2,2)=N+1    
13789           NSTR=NSTR+2   
13790     
13791 C...String drawing and colour flow for q-qbar pair. 
13792         ELSE    
13793           K(N+1,4)=MSTU(5)*(N+2)    
13794           K(N+2,5)=MSTU(5)*(N+1)    
13795           KSTR(NSTR+1,1)=N+1    
13796           KSTR(NSTR+1,2)=N+2    
13797           NSTR=NSTR+1   
13798         ENDIF   
13799     
13800 C...Update remaining energy; iterate.   
13801         N=N+2   
13802         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN   
13803           CALL LUERRM(11,'(PYMULT:) no more memory left in LUJETS') 
13804           IF(MSTU(21).GE.1) RETURN  
13805         ENDIF   
13806         MINT(31)=MINT(31)+1 
13807         VINT(151)=VINT(151)+VINT(41)    
13808         VINT(152)=VINT(152)+VINT(42)    
13809         VINT(143)=VINT(143)-VINT(41)    
13810         VINT(144)=VINT(144)-VINT(42)    
13811         IF(MINT(31).LT.240) GOTO 180    
13812   220   CONTINUE    
13813       ENDIF 
13814     
13815 C...Format statements for printout. 
13816  1000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter', 
13817      &'actions for MSTP(82) =',I2,' ******')    
13818  1100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,    
13819      &E9.2,' mb: rejected') 
13820  1200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,    
13821      &E9.2,' mb: accepted') 
13822     
13823       RETURN    
13824       END   
13825     
13826 C*********************************************************************  
13827     
13828       SUBROUTINE PYREMN(IPU1,IPU2)  
13829     
13830 C...Adds on target remnants (one or two from each side) and 
13831 C...includes primordial kT. 
13832       COMMON/HIPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
13833       COMMON/HISTRNG/NFP(300,15),PPHI(300,15),NFT(300,15),PTHI(300,15)
13834 C...COMMON BLOCK FROM HIJING
13835       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
13836       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
13837       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
13838       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
13839       COMMON/PYINT1/MINT(400),VINT(400) 
13840       DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)   
13841       SAVE
13842 C...Special case for lepton-lepton interaction. 
13843       IF(MINT(43).EQ.1) THEN    
13844         DO 100 JT=1,2   
13845         I=MINT(83)+JT+2 
13846         K(I,1)=21   
13847         K(I,2)=K(I-2,2) 
13848         K(I,3)=I-2  
13849         DO 100 J=1,5    
13850   100   P(I,J)=P(I-2,J) 
13851       ENDIF 
13852     
13853 C...Find event type, set pointers.  
13854       IF(IPU1.EQ.0.AND.IPU2.EQ.0) RETURN    
13855       ISUB=MINT(1)  
13856       ILEP=0    
13857       IF(IPU1.EQ.0) ILEP=1  
13858       IF(IPU2.EQ.0) ILEP=2  
13859       IF(ISUB.EQ.95) ILEP=-1    
13860       IF(ILEP.EQ.1) IQ=MINT(84)+1   
13861       IF(ILEP.EQ.2) IQ=MINT(84)+2   
13862       IP=MAX(IPU1,IPU2) 
13863       ILEPR=MINT(83)+5-ILEP 
13864       NS=N  
13865     
13866 C...Define initial partons, including primordial kT.    
13867   110 DO 130 JT=1,2 
13868       I=MINT(83)+JT+2   
13869       IF(JT.EQ.1) IPU=IPU1  
13870       IF(JT.EQ.2) IPU=IPU2  
13871       K(I,1)=21 
13872       K(I,3)=I-2    
13873       IF(ISUB.EQ.95) THEN   
13874         K(I,2)=21   
13875         SHS=0.  
13876       ELSEIF(MINT(40+JT).EQ.1.AND.IPU.NE.0) THEN    
13877         K(I,2)=K(IPU,2) 
13878         P(I,5)=P(IPU,5) 
13879         P(I,1)=0.   
13880         P(I,2)=0.   
13881         PMS(JT)=P(I,5)**2   
13882       ELSEIF(IPU.NE.0) THEN 
13883         K(I,2)=K(IPU,2) 
13884         P(I,5)=P(IPU,5) 
13885 C...No primordial kT or chosen according to truncated Gaussian or   
13886 C...exponential.
13887 C
13888 c     X.N. Wang (7.22.97)
13889 c
13890         RPT1=0.0
13891         RPT2=0.0
13892         SS_W2=(PPHI(IHNT2(11),4)+PTHI(IHNT2(12),4))**2
13893      &       -(PPHI(IHNT2(11),1)+PTHI(IHNT2(12),1))**2
13894      &       -(PPHI(IHNT2(11),2)+PTHI(IHNT2(12),2))**2
13895      &       -(PPHI(IHNT2(11),3)+PTHI(IHNT2(12),3))**2
13896 C
13897 C********this is s of the current NN collision
13898         IF(SS_W2.LE.4.0*PARP(93)**2) GOTO 1211
13899 c
13900         IF(IHPR2(5).LE.0) THEN
13901 120          IF(MSTP(91).LE.0) THEN
13902                PT=0. 
13903              ELSEIF(MSTP(91).EQ.1) THEN
13904                PT=PARP(91)*SQRT(-LOG(RLU(0)))
13905              ELSE    
13906                RPT1=RLU(0)   
13907                RPT2=RLU(0)   
13908                PT=-PARP(92)*LOG(RPT1*RPT2)   
13909              ENDIF   
13910              IF(PT.GT.PARP(93)) GOTO 120 
13911              PHI=PARU(2)*RLU(0)  
13912              RPT1=PT*COS(PHI)  
13913              RPT2=PT*SIN(PHI)
13914         ELSE IF(IHPR2(5).EQ.1) THEN
13915              IF(JT.EQ.1) JPT=NFP(IHNT2(11),11)
13916              IF(JT.EQ.2) JPT=NFT(IHNT2(12),11)
13917 1205         PTGS=PARP(91)*SQRT(-LOG(RLU(0)))
13918              IF(PTGS.GT.PARP(93)) GO TO 1205
13919              PHI=2.0*HIPR1(40)*RLU(0)
13920              RPT1=PTGS*COS(PHI)
13921              RPT2=PTGS*SIN(PHI)
13922              DO 1210 I_INT=1,JPT-1
13923                 PKCSQ=PARP(91)*SQRT(-LOG(RLU(0)))
13924                 PHI=2.0*HIPR1(40)*RLU(0)
13925                 RPT1=RPT1+PKCSQ*COS(PHI)
13926                 RPT2=RPT2+PKCSQ*SIN(PHI)
13927 1210         CONTINUE
13928              IF(RPT1**2+RPT2**2.GE.SS_W2/4.0) GO TO 1205
13929         ENDIF
13930 C     X.N. Wang
13931 C                       ********When initial interaction among soft partons is
13932 C                               assumed the primordial pt comes from the sum of
13933 C                               pt of JPT-1 number of initial interaction, JPT
13934 C                               is the number of interaction including present
13935 C                               one that nucleon hassuffered 
13936 1211    P(I,1)=RPT1
13937         P(I,2)=RPT2  
13938         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2   
13939       ELSE  
13940         K(I,2)=K(IQ,2)  
13941         Q2=VINT(52) 
13942         P(I,5)=-SQRT(Q2)    
13943         PMS(JT)=-Q2 
13944         SHS=(1.-VINT(43-JT))*Q2/VINT(43-JT)+VINT(5-JT)**2   
13945       ENDIF 
13946   130 CONTINUE  
13947     
13948 C...Kinematics construction for initial partons.    
13949       I1=MINT(83)+3 
13950       I2=MINT(83)+4 
13951       IF(ILEP.EQ.0) SHS=VINT(141)*VINT(142)*VINT(2)+    
13952      &(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2 
13953       SHR=SQRT(MAX(0.,SHS)) 
13954       IF(ILEP.EQ.0) THEN    
13955         IF((SHS-PMS(1)-PMS(2))**2-4.*PMS(1)*PMS(2).LE.0.) GOTO 110  
13956         P(I1,4)=0.5*(SHR+(PMS(1)-PMS(2))/SHR)   
13957         P(I1,3)=SQRT(MAX(0.,P(I1,4)**2-PMS(1))) 
13958         P(I2,4)=SHR-P(I1,4) 
13959         P(I2,3)=-P(I1,3)    
13960       ELSEIF(ILEP.EQ.1) THEN    
13961         P(I1,4)=P(IQ,4) 
13962         P(I1,3)=P(IQ,3) 
13963         P(I2,4)=P(IP,4) 
13964         P(I2,3)=P(IP,3) 
13965       ELSEIF(ILEP.EQ.2) THEN    
13966         P(I1,4)=P(IP,4) 
13967         P(I1,3)=P(IP,3) 
13968         P(I2,4)=P(IQ,4) 
13969         P(I2,3)=P(IQ,3) 
13970       ENDIF 
13971       IF(MINT(43).EQ.1) RETURN  
13972     
13973 C...Transform partons to overall CM-frame (not for leptoproduction).    
13974       IF(ILEP.EQ.0) THEN    
13975         ROBO(3)=(P(I1,1)+P(I2,1))/SHR   
13976         ROBO(4)=(P(I1,2)+P(I2,2))/SHR   
13977         CALL LUDBRB(I1,I2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),0D0)  
13978         ROBO(2)=ULANGL(P(I1,1),P(I1,2)) 
13979         CALL LUDBRB(I1,I2,0.,-ROBO(2),0D0,0D0,0D0)  
13980         ROBO(1)=ULANGL(P(I1,3),P(I1,1)) 
13981         CALL LUDBRB(I1,I2,-ROBO(1),0.,0D0,0D0,0D0)  
13982         NMAX=MAX(MINT(52),IPU1,IPU2)    
13983         CALL LUDBRB(I1,NMAX,ROBO(1),ROBO(2),DBLE(ROBO(3)),DBLE(ROBO(4)),    
13984      &  0D0)    
13985         ROBO(5)=MAX(-0.999999,MIN(0.999999,(VINT(141)-VINT(142))/   
13986      &  (VINT(141)+VINT(142)))) 
13987         CALL LUDBRB(I1,NMAX,0.,0.,0D0,0D0,DBLE(ROBO(5)))    
13988       ENDIF 
13989     
13990 C...Check invariant mass of remnant system: 
13991 C...hadronic events or leptoproduction. 
13992       IF(ILEP.LE.0) THEN    
13993         IF(MSTP(81).LE.0.OR.MSTP(82).LE.0.OR.ISUB.EQ.95) THEN   
13994           VINT(151)=0.  
13995           VINT(152)=0.  
13996         ENDIF   
13997         PEH=P(I1,4)+P(I2,4)+0.5*VINT(1)*(VINT(151)+VINT(152))   
13998         PZH=P(I1,3)+P(I2,3)+0.5*VINT(1)*(VINT(151)-VINT(152))   
13999         SHH=(VINT(1)-PEH)**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+P(I2,2))**2- 
14000      &  PZH**2  
14001         PMMIN=P(MINT(83)+1,5)+P(MINT(83)+2,5)+ULMASS(K(I1,2))+  
14002      &  ULMASS(K(I2,2)) 
14003         IF(SHR.GE.VINT(1).OR.SHH.LE.(PMMIN+PARP(111))**2) THEN  
14004           MINT(51)=1    
14005           RETURN    
14006         ENDIF   
14007         SHR=SQRT(SHH+(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2) 
14008       ELSE  
14009         PEI=P(IQ,4)+P(IP,4) 
14010         PZI=P(IQ,3)+P(IP,3) 
14011         PMS(ILEP)=MAX(0.,PEI**2-PZI**2) 
14012         PMMIN=P(ILEPR-2,5)+ULMASS(K(ILEPR,2))+SQRT(PMS(ILEP))   
14013         IF(SHR.LE.PMMIN+PARP(111)) THEN 
14014           MINT(51)=1    
14015           RETURN    
14016         ENDIF   
14017       ENDIF 
14018     
14019 C...Subdivide remnant if necessary, store first parton. 
14020   140 I=NS  
14021       DO 190 JT=1,2 
14022       IF(JT.EQ.ILEP) GOTO 190   
14023       IF(JT.EQ.1) IPU=IPU1  
14024       IF(JT.EQ.2) IPU=IPU2  
14025       CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))  
14026       I=I+1 
14027       IS(JT)=I  
14028       DO 150 J=1,5  
14029       K(I,J)=0  
14030       P(I,J)=0. 
14031   150 V(I,J)=0. 
14032       K(I,1)=3  
14033       K(I,2)=KFLSP(JT)  
14034       K(I,3)=MINT(83)+JT    
14035       P(I,5)=ULMASS(K(I,2)) 
14036     
14037 C...First parton colour connections and transverse mass.    
14038       KFLS=(3-KCHG(LUCOMP(KFLSP(JT)),2)*ISIGN(1,KFLSP(JT)))/2   
14039       K(I,KFLS+3)=IPU   
14040       K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I    
14041       IF(KFLCH(JT).EQ.0) THEN   
14042         P(I,1)=-P(MINT(83)+JT+2,1)  
14043         P(I,2)=-P(MINT(83)+JT+2,2)  
14044         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2   
14045     
14046 C...When extra remnant parton or hadron: find relative pT, store.   
14047       ELSE  
14048         CALL LUPTDI(1,P(I,1),P(I,2))    
14049         PMS(JT+2)=P(I,5)**2+P(I,1)**2+P(I,2)**2 
14050         I=I+1   
14051         DO 160 J=1,5    
14052         K(I,J)=0    
14053         P(I,J)=0.   
14054   160   V(I,J)=0.   
14055         K(I,1)=1    
14056         K(I,2)=KFLCH(JT)    
14057         K(I,3)=MINT(83)+JT  
14058         P(I,5)=ULMASS(K(I,2))   
14059         P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1) 
14060         P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2) 
14061         PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 
14062 C...Relative distribution of energy for particle into two jets. 
14063         IMB=1   
14064         IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2 
14065         IF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN   
14066           CHIK=PARP(92+2*IMB)   
14067           IF(MSTP(92).LE.1) THEN    
14068             IF(IMB.EQ.1) CHI(JT)=RLU(0) 
14069             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))    
14070           ELSEIF(MSTP(92).EQ.2) THEN    
14071             CHI(JT)=1.-RLU(0)**(1./(1.+CHIK))   
14072           ELSEIF(MSTP(92).EQ.3) THEN    
14073             CUT=2.*0.3/VINT(1)  
14074   170       CHI(JT)=RLU(0)**2   
14075             IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25*(1.-CHI(JT))**CHIK    
14076      &      .LT.RLU(0)) GOTO 170    
14077           ELSE  
14078             CUT=2.*0.3/VINT(1)  
14079             CUTR=(1.+SQRT(1.+CUT**2))/CUT   
14080   180       CHIR=CUT*CUTR**RLU(0)   
14081             CHI(JT)=(CHIR**2-CUT**2)/(2.*CHIR)  
14082             IF((1.-CHI(JT))**CHIK.LT.RLU(0)) GOTO 180   
14083           ENDIF 
14084 C...Relative distribution of energy for particle into jet plus particle.    
14085         ELSE    
14086           IF(MSTP(92).LE.1) THEN    
14087             IF(IMB.EQ.1) CHI(JT)=RLU(0) 
14088             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))    
14089           ELSE  
14090             CHI(JT)=1.-RLU(0)**(1./(1.+PARP(93+2*IMB))) 
14091           ENDIF 
14092           IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1.-CHI(JT)    
14093         ENDIF   
14094         PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1.-CHI(JT))    
14095         KFLS=KCHG(LUCOMP(KFLCH(JT)),2)*ISIGN(1,KFLCH(JT))   
14096         IF(KFLS.NE.0) THEN  
14097           K(I,1)=3  
14098           KFLS=(3-KFLS)/2   
14099           K(I,KFLS+3)=IPU   
14100           K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I    
14101         ENDIF   
14102       ENDIF 
14103   190 CONTINUE  
14104       IF(SHR.LE.SQRT(PMS(1))+SQRT(PMS(2))) GOTO 140 
14105       N=I   
14106     
14107 C...Reconstruct kinematics of remnants. 
14108       DO 200 JT=1,2 
14109       IF(JT.EQ.ILEP) GOTO 200   
14110       PE=0.5*(SHR+(PMS(JT)-PMS(3-JT))/SHR)  
14111       PZ=SQRT(PE**2-PMS(JT))    
14112       IF(KFLCH(JT).EQ.0) THEN   
14113         P(IS(JT),4)=PE  
14114         P(IS(JT),3)=PZ*(-1)**(JT-1) 
14115       ELSE  
14116         PW1=CHI(JT)*(PE+PZ) 
14117         P(IS(JT)+1,4)=0.5*(PW1+PMS(JT+4)/PW1)   
14118         P(IS(JT)+1,3)=0.5*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)  
14119         P(IS(JT),4)=PE-P(IS(JT)+1,4)    
14120         P(IS(JT),3)=PZ*(-1)**(JT-1)-P(IS(JT)+1,3)   
14121       ENDIF 
14122   200 CONTINUE  
14123     
14124 C...Hadronic events: boost remnants to correct longitudinal frame.  
14125       IF(ILEP.LE.0) THEN    
14126         CALL LUDBRB(NS+1,N,0.,0.,0D0,0D0,-DBLE(PZH/(VINT(1)-PEH)))  
14127 C...Leptoproduction events: boost colliding subsystem.  
14128       ELSE  
14129         NMAX=MAX(IP,MINT(52))   
14130         PEF=SHR-PE  
14131         PZF=PZ*(-1)**(ILEP-1)   
14132         PT2=P(ILEPR,1)**2+P(ILEPR,2)**2 
14133         PHIPT=ULANGL(P(ILEPR,1),P(ILEPR,2)) 
14134         CALL LUDBRB(MINT(84)+1,NMAX,0.,-PHIPT,0D0,0D0,0D0)  
14135         RQP=P(IQ,3)*(PT2+PEI**2)-P(IQ,4)*PEI*PZI    
14136         SINTH=P(IQ,4)*SQRT(PT2*(PT2+PEI**2)/(RQP**2+PT2*    
14137      &  P(IQ,4)**2*PZI**2))*SIGN(1.,-RQP)   
14138         CALL LUDBRB(MINT(84)+1,NMAX,ASIN(SINTH),0.,0D0,0D0,0D0) 
14139         BETAX=(-PEI*PZI*SINTH+SQRT(PT2*(PT2+PEI**2-(PZI*SINTH)**2)))/   
14140      &  (PT2+PEI**2)    
14141         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,DBLE(BETAX),0D0,0D0)  
14142         CALL LUDBRB(MINT(84)+1,NMAX,0.,PHIPT,0D0,0D0,0D0)   
14143         PEM=P(IQ,4)+P(IP,4) 
14144         PZM=P(IQ,3)+P(IP,3) 
14145         BETAZ=(-PEM*PZM+PZF*SQRT(PZF**2+PEM**2-PZM**2))/(PZF**2+PEM**2) 
14146         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,0D0,0D0,DBLE(BETAZ))  
14147         CALL LUDBRB(I1,I2,ASIN(SINTH),0.,DBLE(BETAX),0D0,0D0)   
14148         CALL LUDBRB(I1,I2,0.,PHIPT,0D0,0D0,DBLE(BETAZ)) 
14149       ENDIF 
14150     
14151       RETURN    
14152       END   
14153     
14154 C*********************************************************************  
14155     
14156       SUBROUTINE PYRESD 
14157     
14158 C...Allows resonances to decay (including parton showers for hadronic   
14159 C...channels).  
14160       IMPLICIT DOUBLE PRECISION(D)  
14161       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
14162       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14163       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
14164       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
14165       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
14166       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
14167       COMMON/PYINT1/MINT(400),VINT(400) 
14168       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
14169       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
14170       DIMENSION IREF(10,6),KDCY(2),KFL1(2),KFL2(2),NSD(2),ILIN(6),  
14171      &COUP(6,4),PK(6,4),PKK(6,6),CTHE(2),PHI(2),WDTP(0:40), 
14172      &WDTE(0:40,0:5)    
14173       COMPLEX FGK,HA(6,6),HC(6,6)   
14174       SAVE
14175     
14176 C...The F, Xi and Xj functions of Gunion and Kunszt 
14177 C...(Phys. Rev. D33, 665, plus errata from the authors).    
14178       FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)* 
14179      &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))    
14180       DIGK(DT,DU)=-4.*D34*D56+DT*(3.*DT+4.*DU)+DT**2*(DT*DU/(D34*D56)-  
14181      &2.*(1./D34+1./D56)*(DT+DU)+2.*(D34/D56+D56/D34))  
14182       DJGK(DT,DU)=8.*(D34+D56)**2-8.*(D34+D56)*(DT+DU)-6.*DT*DU-    
14183      &2.*DT*DU*(DT*DU/(D34*D56)-2.*(1./D34+1./D56)*(DT+DU)+ 
14184      &2.*(D34/D56+D56/D34)) 
14185     
14186 C...Define initial two objects, initialize loop.    
14187       ISUB=MINT(1)  
14188       SH=VINT(44)   
14189       IREF(1,5)=0   
14190       IREF(1,6)=0   
14191       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN   
14192         IREF(1,1)=MINT(84)+2+ISET(ISUB) 
14193         IREF(1,2)=0 
14194         IREF(1,3)=MINT(83)+6+ISET(ISUB) 
14195         IREF(1,4)=0 
14196       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN   
14197         IREF(1,1)=MINT(84)+1+ISET(ISUB) 
14198         IREF(1,2)=MINT(84)+2+ISET(ISUB) 
14199         IREF(1,3)=MINT(83)+5+ISET(ISUB) 
14200         IREF(1,4)=MINT(83)+6+ISET(ISUB) 
14201       ENDIF 
14202       NP=1  
14203       IP=0  
14204   100 IP=IP+1   
14205       NINH=0    
14206     
14207 C...Loop over one/two resonances; reset decay rates.    
14208       JTMAX=2   
14209       IF(IP.EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3)) JTMAX=1  
14210       DO 140 JT=1,JTMAX 
14211       KDCY(JT)=0    
14212       KFL1(JT)=0    
14213       KFL2(JT)=0    
14214       NSD(JT)=IREF(IP,JT)   
14215       ID=IREF(IP,JT)    
14216       IF(ID.EQ.0) GOTO 140  
14217       KFA=IABS(K(ID,2)) 
14218       IF(KFA.LT.23.OR.KFA.GT.40) GOTO 140   
14219       IF(MDCY(KFA,1).NE.0) THEN 
14220         IF(ISUB.EQ.1.OR.ISUB.EQ.141) MINT(61)=1 
14221         CALL PYWIDT(KFA,P(ID,5),WDTP,WDTE)  
14222         IF(KCHG(KFA,3).EQ.0) THEN   
14223           IPM=2 
14224         ELSE    
14225           IPM=(5+ISIGN(1,K(ID,2)))/2    
14226         ENDIF   
14227         IF(JTMAX.EQ.1.OR.IABS(K(IREF(IP,1),2)).NE.IABS(K(IREF(IP,2),2)))    
14228      &  THEN    
14229           I12=4 
14230         ELSE    
14231           IF(JT.EQ.1) I12=INT(4.5+RLU(0))   
14232           I12=9-I12 
14233         ENDIF   
14234         RKFL=(WDTE(0,1)+WDTE(0,IPM)+WDTE(0,I12))*RLU(0) 
14235         DO 120 I=1,MDCY(KFA,3)  
14236         IDC=I+MDCY(KFA,2)-1 
14237         KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))   
14238         KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))   
14239         RKFL=RKFL-(WDTE(I,1)+WDTE(I,IPM)+WDTE(I,I12))   
14240         IF(RKFL.LE.0.) GOTO 130 
14241   120   CONTINUE    
14242   130   CONTINUE    
14243       ENDIF 
14244     
14245 C...Summarize result on decay channel chosen.   
14246       IF((KFA.EQ.23.OR.KFA.EQ.24).AND.KFL1(JT).EQ.0) NINH=NINH+1    
14247       IF(KFL1(JT).EQ.0) GOTO 140    
14248       KDCY(JT)=2    
14249       IF(IABS(KFL1(JT)).LE.10.OR.KFL1(JT).EQ.21) KDCY(JT)=1 
14250       IF((IABS(KFL1(JT)).GE.23.AND.IABS(KFL1(JT)).LE.25).OR.    
14251      &(IABS(KFL1(JT)).EQ.37)) KDCY(JT)=3    
14252       NSD(JT)=N 
14253     
14254 C...Fill decay products, prepared for parton showers for quarks.    
14255       IF(KDCY(JT).EQ.1) THEN    
14256         CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),P(ID,5))   
14257       ELSE  
14258         CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))  
14259       ENDIF 
14260       IF(JTMAX.EQ.1) THEN   
14261         CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*RLU(0)  
14262         IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)    
14263         PHI(JT)=VINT(24)    
14264       ELSE  
14265         CTHE(JT)=2.*RLU(0)-1.   
14266         PHI(JT)=PARU(2)*RLU(0)  
14267       ENDIF 
14268   140 CONTINUE  
14269       IF(MINT(3).EQ.1.AND.IP.EQ.1) THEN 
14270         MINT(25)=KFL1(1)    
14271         MINT(26)=KFL2(1)    
14272       ENDIF 
14273       IF(JTMAX.EQ.1.AND.KDCY(1).EQ.0) GOTO 530  
14274       IF(JTMAX.EQ.2.AND.KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 530 
14275       IF(MSTP(45).LE.0.OR.IREF(IP,2).EQ.0.OR.NINH.GE.1) GOTO 500    
14276       IF(K(IREF(1,1),2).EQ.25.AND.IP.EQ.1) GOTO 500 
14277       IF(K(IREF(1,1),2).EQ.25.AND.KDCY(1)*KDCY(2).EQ.0) GOTO 500    
14278     
14279 C...Order incoming partons and outgoing resonances. 
14280       ILIN(1)=MINT(84)+1    
14281       IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2   
14282       IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)   
14283       ILIN(2)=2*MINT(84)+3-ILIN(1)  
14284       IMIN=1    
14285       IF(IREF(IP,5).EQ.25) IMIN=3   
14286       IMAX=2    
14287       IORD=1    
14288       IF(K(IREF(IP,1),2).EQ.23) IORD=2  
14289       IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2   
14290       IF(IABS(K(IREF(IP,IORD),2)).EQ.25) IORD=3-IORD    
14291       IF(KDCY(IORD).EQ.0) IORD=3-IORD   
14292     
14293 C...Order decay products of resonances. 
14294       DO 390 JT=IORD,3-IORD,3-2*IORD    
14295       IF(KDCY(JT).EQ.0) THEN    
14296         ILIN(IMAX+1)=NSD(JT)    
14297         IMAX=IMAX+1 
14298       ELSEIF(K(NSD(JT)+1,2).GT.0) THEN  
14299         ILIN(IMAX+1)=N+2*JT-1   
14300         ILIN(IMAX+2)=N+2*JT 
14301         IMAX=IMAX+2 
14302         K(N+2*JT-1,2)=K(NSD(JT)+1,2)    
14303         K(N+2*JT,2)=K(NSD(JT)+2,2)  
14304       ELSE  
14305         ILIN(IMAX+1)=N+2*JT 
14306         ILIN(IMAX+2)=N+2*JT-1   
14307         IMAX=IMAX+2 
14308         K(N+2*JT-1,2)=K(NSD(JT)+1,2)    
14309         K(N+2*JT,2)=K(NSD(JT)+2,2)  
14310       ENDIF 
14311   390 CONTINUE  
14312     
14313 C...Find charge, isospin, left- and righthanded couplings.  
14314       XW=PARU(102)  
14315       DO 410 I=IMIN,IMAX    
14316       DO 400 J=1,4  
14317   400 COUP(I,J)=0.  
14318       KFA=IABS(K(ILIN(I),2))    
14319       IF(KFA.GT.20) GOTO 410    
14320       COUP(I,1)=LUCHGE(KFA)/3.  
14321       COUP(I,2)=(-1)**MOD(KFA,2)    
14322       COUP(I,4)=-2.*COUP(I,1)*XW    
14323       COUP(I,3)=COUP(I,2)+COUP(I,4) 
14324   410 CONTINUE  
14325       SQMZ=PMAS(23,1)**2    
14326       GZMZ=PMAS(23,1)*PMAS(23,2)    
14327       SQMW=PMAS(24,1)**2    
14328       GZMW=PMAS(24,1)*PMAS(24,2)    
14329       SQMZP=PMAS(32,1)**2   
14330       GZMZP=PMAS(32,1)*PMAS(32,2)   
14331     
14332 C...Select random angles; construct massless four-vectors.  
14333   420 DO 430 I=N+1,N+4  
14334       K(I,1)=1  
14335       DO 430 J=1,5  
14336   430 P(I,J)=0. 
14337       DO 440 JT=1,JTMAX 
14338       IF(KDCY(JT).EQ.0) GOTO 440    
14339       ID=IREF(IP,JT)    
14340       P(N+2*JT-1,3)=0.5*P(ID,5) 
14341       P(N+2*JT-1,4)=0.5*P(ID,5) 
14342       P(N+2*JT,3)=-0.5*P(ID,5)  
14343       P(N+2*JT,4)=0.5*P(ID,5)   
14344       CTHE(JT)=2.*RLU(0)-1. 
14345       PHI(JT)=PARU(2)*RLU(0)    
14346       CALL LUDBRB(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),   
14347      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))    
14348   440 CONTINUE  
14349     
14350 C...Store incoming and outgoing momenta, with random rotation to    
14351 C...avoid accidental zeroes in HA expressions.  
14352       DO 450 I=1,IMAX   
14353       K(N+4+I,1)=1  
14354       P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+  
14355      &P(ILIN(I),5)**2)  
14356       P(N+4+I,5)=P(ILIN(I),5)   
14357       DO 450 J=1,3  
14358   450 P(N+4+I,J)=P(ILIN(I),J)   
14359       THERR=ACOS(2.*RLU(0)-1.)  
14360       PHIRR=PARU(2)*RLU(0)  
14361       CALL LUDBRB(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0) 
14362       DO 460 I=1,IMAX   
14363       DO 460 J=1,4  
14364   460 PK(I,J)=P(N+4+I,J)    
14365     
14366 C...Calculate internal products.    
14367       IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25) THEN   
14368         DO 470 I1=IMIN,IMAX-1   
14369         DO 470 I2=I1+1,IMAX 
14370         HA(I1,I2)=SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+PK(I2,3))/ 
14371      &  (1E-20+PK(I1,1)**2+PK(I1,2)**2))*CMPLX(PK(I1,1),PK(I1,2))-  
14372      &  SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/   
14373      &  (1E-20+PK(I2,1)**2+PK(I2,2)**2))*CMPLX(PK(I2,1),PK(I2,2))   
14374         HC(I1,I2)=CONJG(HA(I1,I2))  
14375         IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)    
14376         IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)    
14377         HA(I2,I1)=-HA(I1,I2)    
14378   470   HC(I2,I1)=-HC(I1,I2)    
14379       ENDIF 
14380       DO 480 I=1,2  
14381       DO 480 J=1,4  
14382   480 PK(I,J)=-PK(I,J)  
14383       DO 490 I1=IMIN,IMAX-1 
14384       DO 490 I2=I1+1,IMAX   
14385       PKK(I1,I2)=2.*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-   
14386      &PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))  
14387   490 PKK(I2,I1)=PKK(I1,I2) 
14388     
14389       IF(IREF(IP,5).EQ.25) THEN 
14390 C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons 
14391         WT=16.*PKK(3,5)*PKK(4,6)    
14392         IF(IP.EQ.1) WTMAX=SH**2 
14393         IF(IP.GE.2) WTMAX=P(IREF(IP,6),5)**4    
14394     
14395       ELSEIF(ISUB.EQ.1) THEN    
14396         IF(KFA.NE.37) THEN  
14397 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons    
14398           EI=KCHG(IABS(MINT(15)),1)/3.  
14399           AI=SIGN(1.,EI+0.1)    
14400           VI=AI-4.*EI*XW    
14401           EF=KCHG(KFA,1)/3. 
14402           AF=SIGN(1.,EF+0.1)    
14403           VF=AF-4.*EF*XW    
14404           GG=1. 
14405           GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2) 
14406           ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)    
14407           IF(MSTP(43).EQ.1) THEN    
14408 C...Only gamma* production included 
14409             GZ=0.   
14410             ZZ=0.   
14411           ELSEIF(MSTP(43).EQ.2) THEN    
14412 C...Only Z0 production included 
14413             GG=0.   
14414             GZ=0.   
14415           ENDIF 
14416           ASYM=2.*(EI*AI*GZ*EF*AF+4.*VI*AI*ZZ*VF*AF)/(EI**2*GG*EF**2+   
14417      &    EI*VI*GZ*EF*VF+(VI**2+AI**2)*ZZ*(VF**2+AF**2))    
14418           WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2   
14419           WTMAX=2.+ABS(ASYM)    
14420         ELSE    
14421 C...Angular weight for gamma*/Z0 -> H+ + H- 
14422           WT=1.-CTHE(JT)**2 
14423           WTMAX=1.  
14424         ENDIF   
14425     
14426       ELSEIF(ISUB.EQ.2) THEN    
14427 C...Angular weight for W+/- -> 2 quarks/leptons 
14428         WT=(1.+CTHE(JT))**2 
14429         WTMAX=4.    
14430     
14431       ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN 
14432 C...Angular weight for f + fb -> gluon/gamma + Z0 ->    
14433 C...-> gluon/gamma + 2 quarks/leptons   
14434         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)* 
14435      &  (PKK(1,3)**2+PKK(2,4)**2)+((COUP(1,3)*COUP(3,4))**2+    
14436      &  (COUP(1,4)*COUP(3,3))**2)*(PKK(1,4)**2+PKK(2,3)**2) 
14437         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*  
14438      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2) 
14439     
14440       ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN 
14441 C...Angular weight for f + fb' -> gluon/gamma + W+/- -> 
14442 C...-> gluon/gamma + 2 quarks/leptons   
14443         WT=PKK(1,3)**2+PKK(2,4)**2  
14444         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2 
14445     
14446       ELSEIF(ISUB.EQ.22) THEN   
14447 C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons    
14448         S34=P(IREF(IP,IORD),5)**2   
14449         S56=P(IREF(IP,3-IORD),5)**2 
14450         TI=PKK(1,3)+PKK(1,4)+S34    
14451         UI=PKK(1,5)+PKK(1,6)+S56    
14452         WT=COUP(1,3)**4*((COUP(3,3)*COUP(5,3)*ABS(FGK(1,2,3,4,5,6)/ 
14453      &  TI+FGK(1,2,5,6,3,4)/UI))**2+(COUP(3,4)*COUP(5,3)*ABS(   
14454      &  FGK(1,2,4,3,5,6)/TI+FGK(1,2,5,6,4,3)/UI))**2+(COUP(3,3)*    
14455      &  COUP(5,4)*ABS(FGK(1,2,3,4,6,5)/TI+FGK(1,2,6,5,3,4)/UI))**2+ 
14456      &  (COUP(3,4)*COUP(5,4)*ABS(FGK(1,2,4,3,6,5)/TI+FGK(1,2,6,5,4,3)/  
14457      &  UI))**2)+COUP(1,4)**4*((COUP(3,3)*COUP(5,3)*ABS(    
14458      &  FGK(2,1,5,6,3,4)/TI+FGK(2,1,3,4,5,6)/UI))**2+(COUP(3,4)*    
14459      &  COUP(5,3)*ABS(FGK(2,1,6,5,3,4)/TI+FGK(2,1,3,4,6,5)/UI))**2+ 
14460      &  (COUP(3,3)*COUP(5,4)*ABS(FGK(2,1,5,6,4,3)/TI+FGK(2,1,4,3,5,6)/  
14461      &  UI))**2+(COUP(3,4)*COUP(5,4)*ABS(FGK(2,1,6,5,4,3)/TI+   
14462      &  FGK(2,1,4,3,6,5)/UI))**2)   
14463         WTMAX=4.*S34*S56*(COUP(1,3)**4+COUP(1,4)**4)*(COUP(3,3)**2+ 
14464      &  COUP(3,4)**2)*(COUP(5,3)**2+COUP(5,4)**2)*4.*(TI/UI+UI/TI+  
14465      &  2.*SH*(S34+S56)/(TI*UI)-S34*S56*(1./TI**2+1./UI**2))    
14466     
14467       ELSEIF(ISUB.EQ.23) THEN   
14468 C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons    
14469         D34=P(IREF(IP,IORD),5)**2   
14470         D56=P(IREF(IP,3-IORD),5)**2 
14471         DT=PKK(1,3)+PKK(1,4)+D34    
14472         DU=PKK(1,5)+PKK(1,6)+D56    
14473         CAWZ=COUP(2,3)/SNGL(DT)-2.*(1.-XW)*COUP(1,2)/(SH-SQMW)  
14474         CBWZ=COUP(1,3)/SNGL(DU)+2.*(1.-XW)*COUP(1,2)/(SH-SQMW)  
14475         WT=COUP(5,3)**2*ABS(CAWZ*FGK(1,2,3,4,5,6)+CBWZ* 
14476      &  FGK(1,2,5,6,3,4))**2+COUP(5,4)**2*ABS(CAWZ* 
14477      &  FGK(1,2,3,4,6,5)+CBWZ*FGK(1,2,6,5,3,4))**2  
14478         WTMAX=4.*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*  
14479      &  DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))  
14480     
14481       ELSEIF(ISUB.EQ.24) THEN   
14482 C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0   
14483         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)* 
14484      &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)* 
14485      &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)    
14486         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*  
14487      &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) 
14488     
14489       ELSEIF(ISUB.EQ.25) THEN   
14490 C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons    
14491         D34=P(IREF(IP,IORD),5)**2   
14492         D56=P(IREF(IP,3-IORD),5)**2 
14493         DT=PKK(1,3)+PKK(1,4)+D34    
14494         DU=PKK(1,5)+PKK(1,6)+D56    
14495         CDWW=(COUP(1,3)*SQMZ/(SH-SQMZ)+COUP(1,2))/SH    
14496         CAWW=CDWW+0.5*(COUP(1,2)+1.)/SNGL(DT)   
14497         CBWW=CDWW+0.5*(COUP(1,2)-1.)/SNGL(DU)   
14498         CCWW=COUP(1,4)*SQMZ/(SH-SQMZ)/SH    
14499         WT=ABS(CAWW*FGK(1,2,3,4,5,6)-CBWW*FGK(1,2,5,6,3,4))**2+ 
14500      &  CCWW**2*ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))**2   
14501         WTMAX=4.*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW* 
14502      &  CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))) 
14503     
14504       ELSEIF(ISUB.EQ.26) THEN   
14505 C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0    
14506         WT=PKK(1,3)*PKK(2,4)    
14507         WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))   
14508     
14509       ELSEIF(ISUB.EQ.30) THEN   
14510 C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons  
14511         IF(K(ILIN(1),2).GT.0) WT=((COUP(1,3)*COUP(3,3))**2+ 
14512      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,4)**2+PKK(3,5)**2)+    
14513      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*    
14514      &  (PKK(1,3)**2+PKK(4,5)**2)   
14515         IF(K(ILIN(1),2).LT.0) WT=((COUP(1,3)*COUP(3,3))**2+ 
14516      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,3)**2+PKK(4,5)**2)+    
14517      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*    
14518      &  (PKK(1,4)**2+PKK(3,5)**2)   
14519         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*  
14520      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2) 
14521     
14522       ELSEIF(ISUB.EQ.31) THEN   
14523 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons  
14524         IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2    
14525         IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2    
14526         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2 
14527     
14528       ELSEIF(ISUB.EQ.141) THEN  
14529 C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons    
14530         EI=KCHG(IABS(MINT(15)),1)/3.    
14531         AI=SIGN(1.,EI+0.1)  
14532         VI=AI-4.*EI*XW  
14533         API=SIGN(1.,EI+0.1) 
14534         VPI=API-4.*EI*XW    
14535         EF=KCHG(KFA,1)/3.   
14536         AF=SIGN(1.,EF+0.1)  
14537         VF=AF-4.*EF*XW  
14538         APF=SIGN(1.,EF+0.1) 
14539         VPF=APF-4.*EF*XW    
14540         GG=1.   
14541         GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)   
14542         GZP=1./(8.*XW*(1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GZMZP**2)   
14543         ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)  
14544         ZZP=2./(16.*XW*(1.-XW))**2* 
14545      &  SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/    
14546      &  (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))   
14547         ZPZP=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZP)**2+GZMZP**2)  
14548         IF(MSTP(44).EQ.1) THEN  
14549 C...Only gamma* production included 
14550           GZ=0. 
14551           GZP=0.    
14552           ZZ=0. 
14553           ZZP=0.    
14554           ZPZP=0.   
14555         ELSEIF(MSTP(44).EQ.2) THEN  
14556 C...Only Z0 production included 
14557           GG=0. 
14558           GZ=0. 
14559           GZP=0.    
14560           ZZP=0.    
14561           ZPZP=0.   
14562         ELSEIF(MSTP(44).EQ.3) THEN  
14563 C...Only Z'0 production included    
14564           GG=0. 
14565           GZ=0. 
14566           GZP=0.    
14567           ZZ=0. 
14568           ZZP=0.    
14569         ELSEIF(MSTP(44).EQ.4) THEN  
14570 C...Only gamma*/Z0 production included  
14571           GZP=0.    
14572           ZZP=0.    
14573           ZPZP=0.   
14574         ELSEIF(MSTP(44).EQ.5) THEN  
14575 C...Only gamma*/Z'0 production included 
14576           GZ=0. 
14577           ZZ=0. 
14578           ZZP=0.    
14579         ELSEIF(MSTP(44).EQ.6) THEN  
14580 C...Only Z0/Z'0 production included 
14581           GG=0. 
14582           GZ=0. 
14583           GZP=0.    
14584         ENDIF   
14585         ASYM=2.*(EI*AI*GZ*EF*AF+EI*API*GZP*EF*APF+4.*VI*AI*ZZ*VF*AF+    
14586      &  (VI*API+VPI*AI)*ZZP*(VF*APF+VPF*AF)+4.*VPI*API*ZPZP*VPF*APF)/   
14587      &  (EI**2*GG*EF**2+EI*VI*GZ*EF*VF+EI*VPI*GZP*EF*VPF+   
14588      &  (VI**2+AI**2)*ZZ*(VF**2+AF**2)+(VI*VPI+AI*API)*ZZP* 
14589      &  (VF*VPF+AF*APF)+(VPI**2+API**2)*ZPZP*(VPF**2+APF**2))   
14590         WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2 
14591         WTMAX=2.+ABS(ASYM)  
14592     
14593       ELSE  
14594         WT=1.   
14595         WTMAX=1.    
14596       ENDIF 
14597 C...Obtain correct angular distribution by rejection techniques.    
14598       IF(WT.LT.RLU(0)*WTMAX) GOTO 420   
14599     
14600 C...Construct massive four-vectors using angles chosen. Mark decayed    
14601 C...resonances, add documentation lines. Shower evolution.  
14602   500 DO 520 JT=1,JTMAX 
14603       IF(KDCY(JT).EQ.0) GOTO 520    
14604       ID=IREF(IP,JT)    
14605       CALL LUDBRB(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),   
14606      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))    
14607       K(ID,1)=K(ID,1)+10    
14608       K(ID,4)=NSD(JT)+1 
14609       K(ID,5)=NSD(JT)+2 
14610       IDOC=MINT(83)+MINT(4) 
14611       DO 510 I=NSD(JT)+1,NSD(JT)+2  
14612       MINT(4)=MINT(4)+1 
14613       I1=MINT(83)+MINT(4)   
14614       K(I,3)=I1 
14615       K(I1,1)=21    
14616       K(I1,2)=K(I,2)    
14617       K(I1,3)=IREF(IP,JT+2) 
14618       DO 510 J=1,5  
14619   510 P(I1,J)=P(I,J)    
14620       IF(JTMAX.EQ.1) THEN   
14621         MINT(7)=MINT(83)+6+2*ISET(ISUB) 
14622         MINT(8)=MINT(83)+7+2*ISET(ISUB) 
14623       ENDIF 
14624       IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,    
14625      &NSD(JT)+2,P(ID,5))    
14626     
14627 C...Check if new resonances were produced, loop back if needed. 
14628       IF(KDCY(JT).NE.3) GOTO 520    
14629       NP=NP+1   
14630       IREF(NP,1)=NSD(JT)+1  
14631       IREF(NP,2)=NSD(JT)+2  
14632       IREF(NP,3)=IDOC+1 
14633       IREF(NP,4)=IDOC+2 
14634       IREF(NP,5)=K(IREF(IP,JT),2)   
14635       IREF(NP,6)=IREF(IP,JT)    
14636   520 CONTINUE  
14637   530 IF(IP.LT.NP) GOTO 100 
14638     
14639       RETURN    
14640       END   
14641     
14642 C*********************************************************************  
14643     
14644       SUBROUTINE PYDIFF 
14645     
14646 C...Handles diffractive and elastic scattering. 
14647       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
14648       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14649       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
14650       COMMON/PYINT1/MINT(400),VINT(400) 
14651       SAVE
14652     
14653 C...Reset K, P and V vectors. Store incoming particles. 
14654       DO 100 JT=1,MSTP(126)+10  
14655       I=MINT(83)+JT 
14656       DO 100 J=1,5  
14657       K(I,J)=0  
14658       P(I,J)=0. 
14659   100 V(I,J)=0. 
14660       N=MINT(84)    
14661       MINT(3)=0 
14662       MINT(21)=0    
14663       MINT(22)=0    
14664       MINT(23)=0    
14665       MINT(24)=0    
14666       MINT(4)=4 
14667       DO 110 JT=1,2 
14668       I=MINT(83)+JT 
14669       K(I,1)=21 
14670       K(I,2)=MINT(10+JT)    
14671       P(I,5)=VINT(2+JT) 
14672       P(I,3)=VINT(5)*(-1)**(JT+1)   
14673   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)  
14674       MINT(6)=2 
14675     
14676 C...Subprocess; kinematics. 
14677       ISUB=MINT(1)  
14678       SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4.*VINT(63)*VINT(64) 
14679       PZ=SQRT(SQLAM)/(2.*VINT(1))   
14680       DO 150 JT=1,2 
14681       I=MINT(83)+JT 
14682       PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2.*VINT(1)) 
14683     
14684 C...Elastically scattered particle. 
14685       IF(MINT(16+JT).LE.0) THEN 
14686         N=N+1   
14687         K(N,1)=1    
14688         K(N,2)=K(I,2)   
14689         K(N,3)=I+2  
14690         P(N,3)=PZ*(-1)**(JT+1)  
14691         P(N,4)=PE   
14692         P(N,5)=P(I,5)   
14693     
14694 C...Diffracted particle: valence quark kicked out.  
14695       ELSEIF(MSTP(101).EQ.1) THEN   
14696         N=N+2   
14697         K(N-1,1)=2  
14698         K(N,1)=1    
14699         K(N-1,3)=I+2    
14700         K(N,3)=I+2  
14701         CALL PYSPLI(K(I,2),21,K(N,2),K(N-1,2))  
14702         P(N-1,5)=ULMASS(K(N-1,2))   
14703         P(N,5)=ULMASS(K(N,2))   
14704         SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-   
14705      &  4.*P(N-1,5)**2*P(N,5)**2    
14706         P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-   
14707      &  P(N,5)**2))/(2.*VINT(62+JT))*(-1)**(JT+1)   
14708         P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)  
14709         P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3) 
14710         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)    
14711     
14712 C...Diffracted particle: gluon kicked out.  
14713       ELSE  
14714         N=N+3   
14715         K(N-2,1)=2  
14716         K(N-1,1)=2  
14717         K(N,1)=1    
14718         K(N-2,3)=I+2    
14719         K(N-1,3)=I+2    
14720         K(N,3)=I+2  
14721         CALL PYSPLI(K(I,2),21,K(N,2),K(N-2,2))  
14722         K(N-1,2)=21 
14723         P(N-2,5)=ULMASS(K(N-2,2))   
14724         P(N-1,5)=0. 
14725         P(N,5)=ULMASS(K(N,2))   
14726 C...Energy distribution for particle into two jets. 
14727   120   IMB=1   
14728         IF(MOD(K(I,2)/1000,10).NE.0) IMB=2  
14729         CHIK=PARP(92+2*IMB) 
14730         IF(MSTP(92).LE.1) THEN  
14731           IF(IMB.EQ.1) CHI=RLU(0)   
14732           IF(IMB.EQ.2) CHI=1.-SQRT(RLU(0))  
14733         ELSEIF(MSTP(92).EQ.2) THEN  
14734           CHI=1.-RLU(0)**(1./(1.+CHIK)) 
14735         ELSEIF(MSTP(92).EQ.3) THEN  
14736           CUT=2.*0.3/VINT(1)    
14737   130     CHI=RLU(0)**2 
14738           IF((CHI**2/(CHI**2+CUT**2))**0.25*(1.-CHI)**CHIK.LT.  
14739      &    RLU(0)) GOTO 130  
14740         ELSE    
14741           CUT=2.*0.3/VINT(1)    
14742           CUTR=(1.+SQRT(1.+CUT**2))/CUT 
14743   140     CHIR=CUT*CUTR**RLU(0) 
14744           CHI=(CHIR**2-CUT**2)/(2.*CHIR)    
14745           IF((1.-CHI)**CHIK.LT.RLU(0)) GOTO 140 
14746         ENDIF   
14747         IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1.-P(N-2,5)**2/   
14748      &  VINT(62+JT)) GOTO 120   
14749         SQM=P(N-2,5)**2/(1.-CHI)+P(N,5)**2/CHI  
14750         IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 120 
14751         PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/    
14752      &  (2.*VINT(62+JT))    
14753         PEI=SQRT(PZI**2+SQM)    
14754         PQQP=(1.-CHI)*(PEI+PZI) 
14755         P(N-2,3)=0.5*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)   
14756         P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)  
14757         P(N-1,3)=(PZ-PZI)*(-1)**(JT+1)  
14758         P(N-1,4)=ABS(P(N-1,3))  
14759         P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)    
14760         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)    
14761       ENDIF 
14762     
14763 C...Documentation lines.    
14764       K(I+2,1)=21   
14765       IF(MINT(16+JT).EQ.0) K(I+2,2)=MINT(10+JT) 
14766       IF(MINT(16+JT).NE.0) K(I+2,2)=10*(MINT(10+JT)/10) 
14767       K(I+2,3)=I    
14768       P(I+2,3)=PZ*(-1)**(JT+1)  
14769       P(I+2,4)=PE   
14770       P(I+2,5)=SQRT(VINT(62+JT))    
14771   150 CONTINUE  
14772     
14773 C...Rotate outgoing partons/particles using cos(theta). 
14774       CALL LUDBRB(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) 
14775     
14776       RETURN    
14777       END   
14778     
14779 C*********************************************************************  
14780     
14781       SUBROUTINE PYFRAM(IFRAME) 
14782     
14783 C...Performs transformations between different coordinate frames.   
14784       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14785       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
14786       COMMON/PYINT1/MINT(400),VINT(400) 
14787       SAVE 
14788     
14789       IF(IFRAME.LT.1.OR.IFRAME.GT.2) THEN   
14790         WRITE(MSTU(11),1000) IFRAME,MINT(6) 
14791         RETURN  
14792       ENDIF 
14793       IF(IFRAME.EQ.MINT(6)) RETURN  
14794     
14795       IF(MINT(6).EQ.1) THEN 
14796 C...Transform from fixed target or user specified frame to  
14797 C...CM-frame of incoming particles. 
14798         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))  
14799         CALL LUROBO(0.,-VINT(7),0.,0.,0.)   
14800         CALL LUROBO(-VINT(6),0.,0.,0.,0.)   
14801         MINT(6)=2   
14802     
14803       ELSE  
14804 C...Transform from particle CM-frame to fixed target or user specified  
14805 C...frame.  
14806         CALL LUROBO(VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))   
14807         MINT(6)=1   
14808       ENDIF 
14809       MSTI(6)=MINT(6)   
14810     
14811  1000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,   
14812      &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =', 
14813      &1X,I5)    
14814     
14815       RETURN    
14816       END   
14817     
14818 C*********************************************************************  
14819     
14820       SUBROUTINE PYWIDT(KFLR,RMAS,WDTP,WDTE)    
14821     
14822 C...Calculates full and partial widths of resonances.   
14823       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14824       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
14825       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
14826       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
14827       COMMON/PYINT1/MINT(400),VINT(400) 
14828       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
14829       DIMENSION WDTP(0:40),WDTE(0:40,0:5)   
14830       SAVE
14831     
14832 C...Some common constants.  
14833       KFLA=IABS(KFLR)   
14834       SQM=RMAS**2   
14835       AS=ULALPS(SQM)    
14836       AEM=PARU(101) 
14837       XW=PARU(102)  
14838       RADC=1.+AS/PARU(1)    
14839     
14840 C...Reset width information.    
14841       DO 100 I=0,40 
14842       WDTP(I)=0.    
14843       DO 100 J=0,5  
14844   100 WDTE(I,J)=0.  
14845     
14846       IF(KFLA.EQ.21) THEN   
14847 C...QCD:    
14848         DO 110 I=1,MDCY(21,3)   
14849         IDC=I+MDCY(21,2)-1  
14850         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
14851         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
14852         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 110  
14853         IF(I.LE.8) THEN 
14854 C...QCD -> q + qb   
14855           WDTP(I)=(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
14856           WID2=1.   
14857         ENDIF   
14858         WDTP(0)=WDTP(0)+WDTP(I) 
14859         IF(MDME(IDC,1).GT.0) THEN   
14860           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
14861           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
14862           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
14863           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
14864         ENDIF   
14865   110   CONTINUE    
14866     
14867       ELSEIF(KFLA.EQ.23) THEN   
14868 C...Z0: 
14869         IF(MINT(61).EQ.1) THEN  
14870           EI=KCHG(IABS(MINT(15)),1)/3.  
14871           AI=SIGN(1.,EI)    
14872           VI=AI-4.*EI*XW    
14873           SQMZ=PMAS(23,1)**2    
14874           GZMZ=PMAS(23,2)*PMAS(23,1)    
14875           GGI=EI**2 
14876           GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/ 
14877      &    ((SQM-SQMZ)**2+GZMZ**2)   
14878           ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/ 
14879      &    ((SQM-SQMZ)**2+GZMZ**2)   
14880           IF(MSTP(43).EQ.1) THEN    
14881 C...Only gamma* production included 
14882             GZI=0.  
14883             ZZI=0.  
14884           ELSEIF(MSTP(43).EQ.2) THEN    
14885 C...Only Z0 production included 
14886             GGI=0.  
14887             GZI=0.  
14888           ENDIF 
14889         ELSEIF(MINT(61).EQ.2) THEN  
14890           VINT(111)=0.  
14891           VINT(112)=0.  
14892           VINT(114)=0.  
14893         ENDIF   
14894         DO 120 I=1,MDCY(23,3)   
14895         IDC=I+MDCY(23,2)-1  
14896         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
14897         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
14898         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 120  
14899         IF(I.LE.8) THEN 
14900 C...Z0 -> q + qb    
14901           EF=KCHG(I,1)/3.   
14902           AF=SIGN(1.,EF+0.1)    
14903           VF=AF-4.*EF*XW    
14904           IF(MINT(61).EQ.0) THEN    
14905             WDTP(I)=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*   
14906      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
14907           ELSEIF(MINT(61).EQ.1) THEN    
14908             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*    
14909      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))* 
14910      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
14911           ELSEIF(MINT(61).EQ.2) THEN    
14912             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
14913             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
14914             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*   
14915      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
14916           ENDIF 
14917           WID2=1.   
14918         ELSEIF(I.LE.16) THEN    
14919 C...Z0 -> l+ + l-, nu + nub 
14920           EF=KCHG(I+2,1)/3. 
14921           AF=SIGN(1.,EF+0.1)    
14922           VF=AF-4.*EF*XW    
14923           WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*    
14924      &    SQRT(MAX(0.,1.-4.*RM1))   
14925           IF(MINT(61).EQ.0) THEN    
14926             WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*  
14927      &      SQRT(MAX(0.,1.-4.*RM1)) 
14928           ELSEIF(MINT(61).EQ.1) THEN    
14929             WDTP(I)=((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*   
14930      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))* 
14931      &      SQRT(MAX(0.,1.-4.*RM1)) 
14932           ELSEIF(MINT(61).EQ.2) THEN    
14933             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
14934             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
14935             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*  
14936      &      SQRT(MAX(0.,1.-4.*RM1)) 
14937           ENDIF 
14938           WID2=1.   
14939         ELSE    
14940 C...Z0 -> H+ + H-   
14941           CF=2.*(1.-2.*XW)  
14942           IF(MINT(61).EQ.0) THEN    
14943             WDTP(I)=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))  
14944           ELSEIF(MINT(61).EQ.1) THEN    
14945             WDTP(I)=0.25*(GGI+GZI*CF+ZZI*CF**2)*(1.-4.*RM1)*    
14946      &      SQRT(MAX(0.,1.-4.*RM1)) 
14947           ELSEIF(MINT(61).EQ.2) THEN    
14948             GGF=0.25*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))    
14949             GZF=0.25*CF*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1)) 
14950             ZZF=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))  
14951           ENDIF 
14952           WID2=WIDS(37,1)   
14953         ENDIF   
14954         WDTP(0)=WDTP(0)+WDTP(I) 
14955         IF(MDME(IDC,1).GT.0) THEN   
14956           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
14957           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
14958           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
14959           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
14960           VINT(111)=VINT(111)+GGF*WID2  
14961           VINT(112)=VINT(112)+GZF*WID2  
14962           VINT(114)=VINT(114)+ZZF*WID2  
14963         ENDIF   
14964   120   CONTINUE    
14965         IF(MSTP(43).EQ.1) THEN  
14966 C...Only gamma* production included 
14967           VINT(112)=0.  
14968           VINT(114)=0.  
14969         ELSEIF(MSTP(43).EQ.2) THEN  
14970 C...Only Z0 production included 
14971           VINT(111)=0.  
14972           VINT(112)=0.  
14973         ENDIF   
14974     
14975       ELSEIF(KFLA.EQ.24) THEN   
14976 C...W+/-:   
14977         DO 130 I=1,MDCY(24,3)   
14978         IDC=I+MDCY(24,2)-1  
14979         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
14980         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
14981         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 130  
14982         IF(I.LE.16) THEN    
14983 C...W+/- -> q + qb' 
14984           WDTP(I)=3.*(2.-RM1-RM2-(RM1-RM2)**2)* 
14985      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))* 
14986      &    VCKM((I-1)/4+1,MOD(I-1,4)+1)*RADC 
14987           WID2=1.   
14988         ELSE    
14989 C...W+/- -> l+/- + nu   
14990           WDTP(I)=(2.-RM1-RM2-(RM1-RM2)**2)*    
14991      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))  
14992           WID2=1.   
14993         ENDIF   
14994         WDTP(0)=WDTP(0)+WDTP(I) 
14995         IF(MDME(IDC,1).GT.0) THEN   
14996           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
14997           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
14998           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
14999           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
15000         ENDIF   
15001   130   CONTINUE    
15002     
15003       ELSEIF(KFLA.EQ.25) THEN   
15004 C...H0: 
15005         DO 170 I=1,MDCY(25,3)   
15006         IDC=I+MDCY(25,2)-1  
15007         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
15008         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
15009         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 170  
15010         IF(I.LE.8) THEN 
15011 C...H0 -> q + qb    
15012           WDTP(I)=3.*RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
15013           WID2=1.   
15014         ELSEIF(I.LE.12) THEN    
15015 C...H0 -> l+ + l-   
15016           WDTP(I)=RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
15017           WID2=1.   
15018         ELSEIF(I.EQ.13) THEN    
15019 C...H0 -> g + g; quark loop contribution only   
15020           ETARE=0.  
15021           ETAIM=0.  
15022           DO 140 J=1,2*MSTP(1)  
15023           EPS=(2.*PMAS(J,1)/RMAS)**2    
15024           IF(EPS.LE.1.) THEN    
15025             IF(EPS.GT.1.E-4) THEN   
15026               ROOT=SQRT(1.-EPS) 
15027               RLN=LOG((1.+ROOT)/(1.-ROOT))  
15028             ELSE    
15029               RLN=LOG(4./EPS-2.)    
15030             ENDIF   
15031             PHIRE=0.25*(RLN**2-PARU(1)**2)  
15032             PHIIM=0.5*PARU(1)*RLN   
15033           ELSE  
15034             PHIRE=-(ASIN(1./SQRT(EPS)))**2  
15035             PHIIM=0.    
15036           ENDIF 
15037           ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)   
15038           ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM    
15039   140     CONTINUE  
15040           ETA2=ETARE**2+ETAIM**2    
15041           WDTP(I)=(AS/PARU(1))**2*ETA2  
15042           WID2=1.   
15043         ELSEIF(I.EQ.14) THEN    
15044 C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions 
15045           ETARE=0.  
15046           ETAIM=0.  
15047           DO 150 J=1,3*MSTP(1)+1    
15048           IF(J.LE.2*MSTP(1)) THEN   
15049             EJ=KCHG(J,1)/3. 
15050             EPS=(2.*PMAS(J,1)/RMAS)**2  
15051           ELSEIF(J.LE.3*MSTP(1)) THEN   
15052             JL=2*(J-2*MSTP(1))-1    
15053             EJ=KCHG(10+JL,1)/3. 
15054             EPS=(2.*PMAS(10+JL,1)/RMAS)**2  
15055           ELSE  
15056             EPS=(2.*PMAS(24,1)/RMAS)**2 
15057           ENDIF 
15058           IF(EPS.LE.1.) THEN    
15059             IF(EPS.GT.1.E-4) THEN   
15060               ROOT=SQRT(1.-EPS) 
15061               RLN=LOG((1.+ROOT)/(1.-ROOT))  
15062             ELSE    
15063               RLN=LOG(4./EPS-2.)    
15064             ENDIF   
15065             PHIRE=0.25*(RLN**2-PARU(1)**2)  
15066             PHIIM=0.5*PARU(1)*RLN   
15067           ELSE  
15068             PHIRE=-(ASIN(1./SQRT(EPS)))**2  
15069             PHIIM=0.    
15070           ENDIF 
15071           IF(J.LE.2*MSTP(1)) THEN   
15072             ETARE=ETARE+0.5*3.*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)    
15073             ETAIM=ETAIM+0.5*3.*EJ**2*EPS*(EPS-1.)*PHIIM 
15074           ELSEIF(J.LE.3*MSTP(1)) THEN   
15075             ETARE=ETARE+0.5*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)   
15076             ETAIM=ETAIM+0.5*EJ**2*EPS*(EPS-1.)*PHIIM    
15077           ELSE  
15078             ETARE=ETARE-0.5-0.75*EPS*(1.+(EPS-2.)*PHIRE)    
15079             ETAIM=ETAIM+0.75*EPS*(EPS-2.)*PHIIM 
15080           ENDIF 
15081   150     CONTINUE  
15082           ETA2=ETARE**2+ETAIM**2    
15083           WDTP(I)=(AEM/PARU(1))**2*0.5*ETA2 
15084           WID2=1.   
15085         ELSEIF(I.EQ.15) THEN    
15086 C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions    
15087           ETARE=0.  
15088           ETAIM=0.  
15089           DO 160 J=1,3*MSTP(1)+1    
15090           IF(J.LE.2*MSTP(1)) THEN   
15091             EJ=KCHG(J,1)/3. 
15092             AJ=SIGN(1.,EJ+0.1)  
15093             VJ=AJ-4.*EJ*XW  
15094             EPS=(2.*PMAS(J,1)/RMAS)**2  
15095             EPSP=(2.*PMAS(J,1)/PMAS(23,1))**2   
15096           ELSEIF(J.LE.3*MSTP(1)) THEN   
15097             JL=2*(J-2*MSTP(1))-1    
15098             EJ=KCHG(10+JL,1)/3. 
15099             AJ=SIGN(1.,EJ+0.1)  
15100             VJ=AI-4.*EJ*XW  
15101             EPS=(2.*PMAS(10+JL,1)/RMAS)**2  
15102             EPSP=(2.*PMAS(10+JL,1)/PMAS(23,1))**2   
15103           ELSE  
15104             EPS=(2.*PMAS(24,1)/RMAS)**2 
15105             EPSP=(2.*PMAS(24,1)/PMAS(23,1))**2  
15106           ENDIF 
15107           IF(EPS.LE.1.) THEN    
15108             ROOT=SQRT(1.-EPS)   
15109             IF(EPS.GT.1.E-4) THEN   
15110               RLN=LOG((1.+ROOT)/(1.-ROOT))  
15111             ELSE    
15112               RLN=LOG(4./EPS-2.)    
15113             ENDIF   
15114             PHIRE=0.25*(RLN**2-PARU(1)**2)  
15115             PHIIM=0.5*PARU(1)*RLN   
15116             PSIRE=-(1.+0.5*ROOT*RLN)    
15117             PSIIM=0.5*PARU(1)*ROOT  
15118           ELSE  
15119             PHIRE=-(ASIN(1./SQRT(EPS)))**2  
15120             PHIIM=0.    
15121             PSIRE=-(1.+SQRT(EPS-1.)*ASIN(1./SQRT(EPS))) 
15122             PSIIM=0.    
15123           ENDIF 
15124           IF(EPSP.LE.1.) THEN   
15125             ROOT=SQRT(1.-EPSP)  
15126             IF(EPSP.GT.1.E-4) THEN  
15127               RLN=LOG((1.+ROOT)/(1.-ROOT))  
15128             ELSE    
15129               RLN=LOG(4./EPSP-2.)   
15130             ENDIF   
15131             PHIREP=0.25*(RLN**2-PARU(1)**2) 
15132             PHIIMP=0.5*PARU(1)*RLN  
15133             PSIREP=-(1.+0.5*ROOT*RLN)   
15134             PSIIMP=0.5*PARU(1)*ROOT 
15135           ELSE  
15136             PHIREP=-(ASIN(1./SQRT(EPSP)))**2    
15137             PHIIMP=0.   
15138             PSIREP=-(1.+SQRT(EPSP-1.)*ASIN(1./SQRT(EPSP)))  
15139             PSIIMP=0.   
15140           ENDIF 
15141           FXYRE=EPS*EPSP/(8.*(EPS-EPSP))*(1.-EPS*EPSP/(EPS-EPSP)*(PHIRE-    
15142      &    PHIREP)+2.*EPS/(EPS-EPSP)*(PSIRE-PSIREP)) 
15143           FXYIM=EPS*EPSP/(8.*(EPS-EPSP))*(-EPS*EPSP/(EPS-EPSP)*(PHIIM-  
15144      &    PHIIMP)+2.*EPS/(EPS-EPSP)*(PSIIM-PSIIMP)) 
15145           F1RE=EPS*EPSP/(2.*(EPS-EPSP))*(PHIRE-PHIREP)  
15146           F1IM=EPS*EPSP/(2.*(EPS-EPSP))*(PHIIM-PHIIMP)  
15147           IF(J.LE.2*MSTP(1)) THEN   
15148             ETARE=ETARE-3.*EJ*VJ*(FXYRE-0.25*F1RE)  
15149             ETAIM=ETAIM-3.*EJ*VJ*(FXYIM-0.25*F1IM)  
15150           ELSEIF(J.LE.3*MSTP(1)) THEN   
15151             ETARE=ETARE-EJ*VJ*(FXYRE-0.25*F1RE) 
15152             ETAIM=ETAIM-EJ*VJ*(FXYIM-0.25*F1IM) 
15153           ELSE  
15154             ETARE=ETARE-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-   
15155      &      (5.+2./EPS))*FXYRE+(3.-XW/SQRT(1.-XW))*F1RE)    
15156             ETAIM=ETAIM-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-   
15157      &      (5.+2./EPS))*FXYIM+(3.-XW/SQRT(1.-XW))*F1IM)    
15158           ENDIF 
15159   160     CONTINUE  
15160           ETA2=ETARE**2+ETAIM**2    
15161           WDTP(I)=(AEM/PARU(1))**2*(1.-(PMAS(23,1)/RMAS)**2)**3/XW*ETA2 
15162           WID2=WIDS(23,2)   
15163         ELSE    
15164 C...H0 -> Z0 + Z0, W+ + W-  
15165           WDTP(I)=(1.-4.*RM1+12.*RM1**2)*SQRT(MAX(0.,1.-4.*RM1))/   
15166      &    (2.*(18-I))   
15167           WID2=WIDS(7+I,1)  
15168         ENDIF   
15169         WDTP(0)=WDTP(0)+WDTP(I) 
15170         IF(MDME(IDC,1).GT.0) THEN   
15171           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
15172           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
15173           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
15174           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
15175         ENDIF   
15176   170   CONTINUE    
15177     
15178       ELSEIF(KFLA.EQ.32) THEN   
15179 C...Z'0:    
15180         IF(MINT(61).EQ.1) THEN  
15181           EI=KCHG(IABS(MINT(15)),1)/3.  
15182           AI=SIGN(1.,EI)    
15183           VI=AI-4.*EI*XW    
15184           SQMZ=PMAS(23,1)**2    
15185           GZMZ=PMAS(23,2)*PMAS(23,1)    
15186           API=SIGN(1.,EI)   
15187           VPI=API-4.*EI*XW  
15188           SQMZP=PMAS(32,1)**2   
15189           GZPMZP=PMAS(32,2)*PMAS(32,1)  
15190           GGI=EI**2 
15191           GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/ 
15192      &    ((SQM-SQMZ)**2+GZMZ**2)   
15193           GZPI=EI*VPI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZP)/  
15194      &    ((SQM-SQMZP)**2+GZPMZP**2)    
15195           ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/ 
15196      &    ((SQM-SQMZ)**2+GZMZ**2)   
15197           ZZPI=2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*  
15198      &    SQM**2*((SQM-SQMZ)*(SQM-SQMZP)+GZMZ*GZPMZP)/  
15199      &    (((SQM-SQMZ)**2+GZMZ**2)*((SQM-SQMZP)**2+GZPMZP**2))  
15200           ZPZPI=(VPI**2+API**2)/(16.*XW*(1.-XW))**2*SQM**2/ 
15201      &    ((SQM-SQMZP)**2+GZPMZP**2)    
15202           IF(MSTP(44).EQ.1) THEN    
15203 C...Only gamma* production included 
15204             GZI=0.  
15205             GZPI=0. 
15206             ZZI=0.  
15207             ZZPI=0. 
15208             ZPZPI=0.    
15209           ELSEIF(MSTP(44).EQ.2) THEN    
15210 C...Only Z0 production included 
15211             GGI=0.  
15212             GZI=0.  
15213             GZPI=0. 
15214             ZZPI=0. 
15215             ZPZPI=0.    
15216           ELSEIF(MSTP(44).EQ.3) THEN    
15217 C...Only Z'0 production included    
15218             GGI=0.  
15219             GZI=0.  
15220             GZPI=0. 
15221             ZZI=0.  
15222             ZZPI=0. 
15223           ELSEIF(MSTP(44).EQ.4) THEN    
15224 C...Only gamma*/Z0 production included  
15225             GZPI=0. 
15226             ZZPI=0. 
15227             ZPZPI=0.    
15228           ELSEIF(MSTP(44).EQ.5) THEN    
15229 C...Only gamma*/Z'0 production included 
15230             GZI=0.  
15231             ZZI=0.  
15232             ZZPI=0. 
15233           ELSEIF(MSTP(44).EQ.6) THEN    
15234 C...Only Z0/Z'0 production included 
15235             GGI=0.  
15236             GZI=0.  
15237             GZPI=0. 
15238           ENDIF 
15239         ELSEIF(MINT(61).EQ.2) THEN  
15240           VINT(111)=0.  
15241           VINT(112)=0.  
15242           VINT(113)=0.  
15243           VINT(114)=0.  
15244           VINT(115)=0.  
15245           VINT(116)=0.  
15246         ENDIF   
15247         DO 180 I=1,MDCY(32,3)   
15248         IDC=I+MDCY(32,2)-1  
15249         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
15250         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
15251         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 180  
15252         IF(I.LE.8) THEN 
15253 C...Z'0 -> q + qb   
15254           EF=KCHG(I,1)/3.   
15255           AF=SIGN(1.,EF+0.1)    
15256           VF=AF-4.*EF*XW    
15257           APF=SIGN(1.,EF+0.1)   
15258           VPF=APF-4.*EF*XW  
15259           IF(MINT(61).EQ.0) THEN    
15260             WDTP(I)=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))* 
15261      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
15262           ELSEIF(MINT(61).EQ.1) THEN    
15263             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+ 
15264      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+   
15265      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))* 
15266      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
15267           ELSEIF(MINT(61).EQ.2) THEN    
15268             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
15269             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
15270             GZPF=3.*EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC 
15271             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*   
15272      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
15273             ZZPF=3.*(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*    
15274      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
15275             ZPZPF=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*   
15276      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
15277           ENDIF 
15278           WID2=1.   
15279         ELSE    
15280 C...Z'0 -> l+ + l-, nu + nub    
15281           EF=KCHG(I+2,1)/3. 
15282           AF=SIGN(1.,EF+0.1)    
15283           VF=AF-4.*EF*XW    
15284           APF=SIGN(1.,EF+0.1)   
15285           VPF=APF-4.*EF*XW  
15286           IF(MINT(61).EQ.0) THEN    
15287             WDTP(I)=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*    
15288      &      SQRT(MAX(0.,1.-4.*RM1)) 
15289           ELSEIF(MINT(61).EQ.1) THEN    
15290             WDTP(I)=((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+    
15291      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+   
15292      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))* 
15293      &      SQRT(MAX(0.,1.-4.*RM1)) 
15294           ELSEIF(MINT(61).EQ.2) THEN    
15295             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
15296             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
15297             GZPF=EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1)) 
15298             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*  
15299      &      SQRT(MAX(0.,1.-4.*RM1)) 
15300             ZZPF=(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*   
15301      &      SQRT(MAX(0.,1.-4.*RM1)) 
15302             ZPZPF=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*  
15303      &      SQRT(MAX(0.,1.-4.*RM1)) 
15304           ENDIF 
15305           WID2=1.   
15306         ENDIF   
15307         WDTP(0)=WDTP(0)+WDTP(I) 
15308         IF(MDME(IDC,1).GT.0) THEN   
15309           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
15310           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
15311           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
15312           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
15313           VINT(111)=VINT(111)+GGF   
15314           VINT(112)=VINT(112)+GZF   
15315           VINT(113)=VINT(113)+GZPF  
15316           VINT(114)=VINT(114)+ZZF   
15317           VINT(115)=VINT(115)+ZZPF  
15318           VINT(116)=VINT(116)+ZPZPF 
15319         ENDIF   
15320   180   CONTINUE    
15321         IF(MSTP(44).EQ.1) THEN  
15322 C...Only gamma* production included 
15323           VINT(112)=0.  
15324           VINT(113)=0.  
15325           VINT(114)=0.  
15326           VINT(115)=0.  
15327           VINT(116)=0.  
15328         ELSEIF(MSTP(44).EQ.2) THEN  
15329 C...Only Z0 production included 
15330           VINT(111)=0.  
15331           VINT(112)=0.  
15332           VINT(113)=0.  
15333           VINT(115)=0.  
15334           VINT(116)=0.  
15335         ELSEIF(MSTP(44).EQ.3) THEN  
15336 C...Only Z'0 production included    
15337           VINT(111)=0.  
15338           VINT(112)=0.  
15339           VINT(113)=0.  
15340           VINT(114)=0.  
15341           VINT(115)=0.  
15342         ELSEIF(MSTP(44).EQ.4) THEN  
15343 C...Only gamma*/Z0 production included  
15344           VINT(113)=0.  
15345           VINT(115)=0.  
15346           VINT(116)=0.  
15347         ELSEIF(MSTP(44).EQ.5) THEN  
15348 C...Only gamma*/Z'0 production included 
15349           VINT(112)=0.  
15350           VINT(114)=0.  
15351           VINT(115)=0.  
15352         ELSEIF(MSTP(44).EQ.6) THEN  
15353 C...Only Z0/Z'0 production included 
15354           VINT(111)=0.  
15355           VINT(112)=0.  
15356           VINT(113)=0.  
15357         ENDIF   
15358     
15359       ELSEIF(KFLA.EQ.37) THEN   
15360 C...H+/-:   
15361         DO 190 I=1,MDCY(37,3)   
15362         IDC=I+MDCY(37,2)-1  
15363         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
15364         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
15365         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 190  
15366         IF(I.LE.4) THEN 
15367 C...H+/- -> q + qb' 
15368           WDTP(I)=3.*((RM1*PARU(121)+RM2/PARU(121))*    
15369      &    (1.-RM1-RM2)-4.*RM1*RM2)* 
15370      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*RADC 
15371           WID2=1.   
15372         ELSE    
15373 C...H+/- -> l+/- + nu   
15374           WDTP(I)=((RM1*PARU(121)+RM2/PARU(121))*   
15375      &    (1.-RM1-RM2)-4.*RM1*RM2)* 
15376      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))  
15377           WID2=1.   
15378         ENDIF   
15379         WDTP(0)=WDTP(0)+WDTP(I) 
15380         IF(MDME(IDC,1).GT.0) THEN   
15381           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
15382           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
15383           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
15384           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
15385         ENDIF   
15386   190   CONTINUE    
15387     
15388       ELSEIF(KFLA.EQ.40) THEN   
15389 C...R:  
15390         DO 200 I=1,MDCY(40,3)   
15391         IDC=I+MDCY(40,2)-1  
15392         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
15393         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
15394         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 200  
15395         IF(I.LE.4) THEN 
15396 C...R -> q + qb'    
15397           WDTP(I)=3.*RADC   
15398           WID2=1.   
15399         ELSE    
15400 C...R -> l+ + l'-   
15401           WDTP(I)=1.    
15402           WID2=1.   
15403         ENDIF   
15404         WDTP(0)=WDTP(0)+WDTP(I) 
15405         IF(MDME(IDC,1).GT.0) THEN   
15406           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
15407           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
15408           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
15409           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
15410         ENDIF   
15411   200   CONTINUE    
15412     
15413       ENDIF 
15414       MINT(61)=0    
15415     
15416       RETURN    
15417       END   
15418     
15419 C***********************************************************************    
15420     
15421       SUBROUTINE PYKLIM(ILIM)   
15422     
15423 C...Checks generated variables against pre-set kinematical limits;  
15424 C...also calculates limits on variables used in generation. 
15425       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
15426       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
15427       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
15428       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
15429       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
15430       COMMON/PYINT1/MINT(400),VINT(400) 
15431       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
15432       SAVE
15433     
15434 C...Common kinematical expressions. 
15435       ISUB=MINT(1)  
15436       IF(ISUB.EQ.96) GOTO 110   
15437       SQM3=VINT(63) 
15438       SQM4=VINT(64) 
15439       IF(ILIM.NE.1) THEN    
15440         TAU=VINT(21)    
15441         RM3=SQM3/(TAU*VINT(2))  
15442         RM4=SQM4/(TAU*VINT(2))  
15443         BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)   
15444       ENDIF 
15445       PTHMIN=CKIN(3)    
15446       IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) PTHMIN=MAX(CKIN(3),CKIN(5))  
15447     
15448       IF(ILIM.EQ.0) THEN    
15449 C...Check generated values of tau, y*, cos(theta-hat), and tau' against 
15450 C...pre-set kinematical limits. 
15451         YST=VINT(22)    
15452         CTH=VINT(23)    
15453         TAUP=VINT(26)   
15454         IF(ISET(ISUB).LE.2) THEN    
15455           X1=SQRT(TAU)*EXP(YST) 
15456           X2=SQRT(TAU)*EXP(-YST)    
15457         ELSE    
15458           X1=SQRT(TAUP)*EXP(YST)    
15459           X2=SQRT(TAUP)*EXP(-YST)   
15460         ENDIF   
15461         XF=X1-X2    
15462         IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1    
15463         IF(CKIN(2).GE.0..AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1  
15464         IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1 
15465         IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1 
15466         IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1 
15467         IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1 
15468         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN 
15469           PTH=0.5*BE34*SQRT(TAU*VINT(2)*(1.-CTH**2))    
15470           Y3=YST+0.5*LOG((1.+RM3-RM4+BE34*CTH)/(1.+RM3-RM4-BE34*CTH))   
15471           Y4=YST+0.5*LOG((1.+RM4-RM3-BE34*CTH)/(1.+RM4-RM3+BE34*CTH))   
15472           YLARGE=MAX(Y3,Y4) 
15473           YSMALL=MIN(Y3,Y4) 
15474           ETALAR=10.    
15475           ETASMA=-10.   
15476           STH=SQRT(1.-CTH**2)   
15477           IF(STH.LT.1.E-6) GOTO 100 
15478           EXPET3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+    
15479      &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3))/ 
15480      &    (BE34*STH)    
15481           EXPET4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+    
15482      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4))/ 
15483      &    (BE34*STH)    
15484           ETA3=LOG(MIN(1.E10,MAX(1.E-10,EXPET3)))   
15485           ETA4=LOG(MIN(1.E10,MAX(1.E-10,EXPET4)))   
15486           ETALAR=MAX(ETA3,ETA4) 
15487           ETASMA=MIN(ETA3,ETA4) 
15488 C...temporary variables to avoid compiler warning
15489           CTSTM1=(1.+RM3-RM4)*COSH(YST)
15490           CTSTM2=BE34*SINH(YST)*CTH
15491   100     CTS3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/ 
15492 C     &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3)   
15493      &    SQRT((CTSTM1+CTSTM2)**2-4.*RM3)
15494           CTS4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/ 
15495      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4)   
15496           CTSLAR=MAX(CTS3,CTS4) 
15497           CTSSMA=MIN(CTS3,CTS4) 
15498           IF(PTH.LT.PTHMIN) MINT(51)=1  
15499           IF(CKIN(4).GE.0..AND.PTH.GT.CKIN(4)) MINT(51)=1   
15500           IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1    
15501           IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1   
15502           IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1   
15503           IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1   
15504           IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1   
15505           IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1   
15506           IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1 
15507         ENDIF   
15508         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN 
15509           IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1    
15510           IF(CKIN(32).GE.0..AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1 
15511         ENDIF   
15512     
15513       ELSEIF(ILIM.EQ.1) THEN    
15514 C...Calculate limits on tau 
15515 C...0) due to definition    
15516         TAUMN0=0.   
15517         TAUMX0=1.   
15518 C...1) due to limits on subsystem mass  
15519         TAUMN1=CKIN(1)**2/VINT(2)   
15520         TAUMX1=1.   
15521         IF(CKIN(2).GE.0.) TAUMX1=CKIN(2)**2/VINT(2) 
15522 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) 
15523         TM3=SQRT(SQM3+PTHMIN**2)    
15524         TM4=SQRT(SQM4+PTHMIN**2)    
15525         YDCOSH=1.   
15526         IF(CKIN(9).GT.CKIN(12)) YDCOSH=COSH(CKIN(9)-CKIN(12))   
15527         TAUMN2=(TM3**2+2.*TM3*TM4*YDCOSH+TM4**2)/VINT(2)    
15528         TAUMX2=1.   
15529 C...3) due to limits on pT-hat and cos(theta-hat)   
15530         CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2) 
15531         CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2) 
15532         TAUMN3=0.   
15533         IF(CKIN(27)*CKIN(28).GT.0.) TAUMN3= 
15534      &  (SQRT(SQM3+PTHMIN**2/(1.-CTH2MN))+  
15535      &  SQRT(SQM4+PTHMIN**2/(1.-CTH2MN)))**2/VINT(2)    
15536         TAUMX3=1.   
15537         IF(CKIN(4).GE.0..AND.CTH2MX.LT.1.) TAUMX3=  
15538      &  (SQRT(SQM3+CKIN(4)**2/(1.-CTH2MX))+ 
15539      &  SQRT(SQM4+CKIN(4)**2/(1.-CTH2MX)))**2/VINT(2)   
15540 C...4) due to limits on x1 and x2   
15541         TAUMN4=CKIN(21)*CKIN(23)    
15542         TAUMX4=CKIN(22)*CKIN(24)    
15543 C...5) due to limits on xF  
15544         TAUMN5=0.   
15545         TAUMX5=MAX(1.-CKIN(25),1.+CKIN(26)) 
15546         VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5) 
15547         VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5) 
15548         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN 
15549           VINT(11)=0.99999  
15550           VINT(31)=1.00001  
15551         ENDIF   
15552         IF(VINT(31).LE.VINT(11)) MINT(51)=1 
15553     
15554       ELSEIF(ILIM.EQ.2) THEN    
15555 C...Calculate limits on y*  
15556         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) TAU=VINT(26) 
15557         TAURT=SQRT(TAU) 
15558 C...0) due to kinematics    
15559         YSTMN0=LOG(TAURT)   
15560         YSTMX0=-YSTMN0  
15561 C...1) due to explicit limits   
15562         YSTMN1=CKIN(7)  
15563         YSTMX1=CKIN(8)  
15564 C...2) due to limits on x1  
15565         YSTMN2=LOG(MAX(TAU,CKIN(21))/TAURT) 
15566         YSTMX2=LOG(MAX(TAU,CKIN(22))/TAURT) 
15567 C...3) due to limits on x2  
15568         YSTMN3=-LOG(MAX(TAU,CKIN(24))/TAURT)    
15569         YSTMX3=-LOG(MAX(TAU,CKIN(23))/TAURT)    
15570 C...4) due to limits on xF  
15571         YEPMN4=0.5*ABS(CKIN(25))/TAURT  
15572         YSTMN4=SIGN(LOG(SQRT(1.+YEPMN4**2)+YEPMN4),CKIN(25))    
15573         YEPMX4=0.5*ABS(CKIN(26))/TAURT  
15574         YSTMX4=SIGN(LOG(SQRT(1.+YEPMX4**2)+YEPMX4),CKIN(26))    
15575 C...5) due to simultaneous limits on y-large and y-small    
15576         YEPSMN=(RM3-RM4)*SINH(CKIN(9)-CKIN(11)) 
15577         YEPSMX=(RM3-RM4)*SINH(CKIN(10)-CKIN(12))    
15578         YDIFMN=ABS(LOG(SQRT(1.+YEPSMN**2)-YEPSMN))  
15579         YDIFMX=ABS(LOG(SQRT(1.+YEPSMX**2)-YEPSMX))  
15580         YSTMN5=0.5*(CKIN(9)+CKIN(11)-YDIFMN)    
15581         YSTMX5=0.5*(CKIN(10)+CKIN(12)+YDIFMX)   
15582 C...6) due to simultaneous limits on cos(theta-hat) and y-large or  
15583 C...   y-small  
15584         CTHLIM=SQRT(1.-4.*PTHMIN**2/(BE34*TAU*VINT(2))) 
15585         RZMN=BE34*MAX(CKIN(27),-CTHLIM) 
15586         RZMX=BE34*MIN(CKIN(28),CTHLIM)  
15587         YEX3MX=(1.+RM3-RM4+RZMX)/MAX(1E-10,1.+RM3-RM4-RZMX) 
15588         YEX4MX=(1.+RM4-RM3-RZMN)/MAX(1E-10,1.+RM4-RM3+RZMN) 
15589         YEX3MN=MAX(1E-10,1.+RM3-RM4+RZMN)/(1.+RM3-RM4-RZMN) 
15590         YEX4MN=MAX(1E-10,1.+RM4-RM3-RZMX)/(1.+RM4-RM3+RZMX) 
15591         YSTMN6=CKIN(9)-0.5*LOG(MAX(YEX3MX,YEX4MX))  
15592         YSTMX6=CKIN(12)-0.5*LOG(MIN(YEX3MN,YEX4MN)) 
15593         VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)  
15594         VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)  
15595         IF(MINT(43).EQ.1) THEN  
15596           VINT(12)=-0.00001 
15597           VINT(32)=0.00001  
15598         ELSEIF(MINT(43).EQ.2) THEN  
15599           VINT(12)=0.99999*YSTMX0   
15600           VINT(32)=1.00001*YSTMX0   
15601         ELSEIF(MINT(43).EQ.3) THEN  
15602           VINT(12)=-1.00001*YSTMX0  
15603           VINT(32)=-0.99999*YSTMX0  
15604         ENDIF   
15605         IF(VINT(32).LE.VINT(12)) MINT(51)=1 
15606     
15607       ELSEIF(ILIM.EQ.3) THEN    
15608 C...Calculate limits on cos(theta-hat)  
15609         YST=VINT(22)    
15610 C...0) due to definition    
15611         CTNMN0=-1.  
15612         CTNMX0=0.   
15613         CTPMN0=0.   
15614         CTPMX0=1.   
15615 C...1) due to explicit limits   
15616         CTNMN1=MIN(0.,CKIN(27)) 
15617         CTNMX1=MIN(0.,CKIN(28)) 
15618         CTPMN1=MAX(0.,CKIN(27)) 
15619         CTPMX1=MAX(0.,CKIN(28)) 
15620 C...2) due to limits on pT-hat  
15621         CTNMN2=-SQRT(1.-4.*PTHMIN**2/(BE34**2*TAU*VINT(2))) 
15622         CTPMX2=-CTNMN2  
15623         CTNMX2=0.   
15624         CTPMN2=0.   
15625         IF(CKIN(4).GE.0.) THEN  
15626           CTNMX2=-SQRT(MAX(0.,1.-4.*CKIN(4)**2/(BE34**2*TAU*VINT(2))))  
15627           CTPMN2=-CTNMX2    
15628         ENDIF   
15629 C...3) due to limits on y-large and y-small 
15630         CTNMN3=MIN(0.,MAX((1.+RM3-RM4)/BE34*TANH(CKIN(11)-YST), 
15631      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(10)-YST))) 
15632         CTNMX3=MIN(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(12)-YST), 
15633      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(9)-YST))   
15634         CTPMN3=MAX(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(9)-YST),  
15635      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(12)-YST))  
15636         CTPMX3=MAX(0.,MIN((1.+RM3-RM4)/BE34*TANH(CKIN(10)-YST), 
15637      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(11)-YST))) 
15638         VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3)   
15639         VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3)   
15640         VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3)   
15641         VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3)   
15642         IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1    
15643     
15644       ELSEIF(ILIM.EQ.4) THEN    
15645 C...Calculate limits on tau'    
15646 C...0) due to kinematics    
15647         TAPMN0=TAU  
15648         TAPMX0=1.   
15649 C...1) due to explicit limits   
15650         TAPMN1=CKIN(31)**2/VINT(2)  
15651         TAPMX1=1.   
15652         IF(CKIN(32).GE.0.) TAPMX1=CKIN(32)**2/VINT(2)   
15653         VINT(16)=MAX(TAPMN0,TAPMN1) 
15654         VINT(36)=MIN(TAPMX0,TAPMX1) 
15655         IF(MINT(43).EQ.1) THEN  
15656           VINT(16)=0.99999  
15657           VINT(36)=1.00001  
15658         ENDIF   
15659         IF(VINT(36).LE.VINT(16)) MINT(51)=1 
15660     
15661       ENDIF 
15662       RETURN    
15663     
15664 C...Special case for low-pT and multiple interactions:  
15665 C...effective kinematical limits for tau, y*, cos(theta-hat).   
15666   110 IF(ILIM.EQ.0) THEN    
15667       ELSEIF(ILIM.EQ.1) THEN    
15668         IF(MSTP(82).LE.1) VINT(11)=4.*PARP(81)**2/VINT(2)   
15669         IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)  
15670         VINT(31)=1. 
15671       ELSEIF(ILIM.EQ.2) THEN    
15672         VINT(12)=0.5*LOG(VINT(21))  
15673         VINT(32)=-VINT(12)  
15674       ELSEIF(ILIM.EQ.3) THEN    
15675         IF(MSTP(82).LE.1) ST2EFF=4.*PARP(81)**2/(VINT(21)*VINT(2))  
15676         IF(MSTP(82).GE.2) ST2EFF=0.01*PARP(82)**2/(VINT(21)*VINT(2))    
15677         VINT(13)=-SQRT(MAX(0.,1.-ST2EFF))   
15678         VINT(33)=0. 
15679         VINT(14)=0. 
15680         VINT(34)=-VINT(13)  
15681       ENDIF 
15682     
15683       RETURN    
15684       END   
15685     
15686 C*********************************************************************  
15687     
15688       SUBROUTINE PYKMAP(IVAR,MVAR,VVAR) 
15689     
15690 C...Maps a uniform distribution into a distribution of a kinematical    
15691 C...variable according to one of the possibilities allowed. It is   
15692 C...assumed that kinematical limits have been set by a PYKLIM call. 
15693       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
15694       COMMON/PYINT1/MINT(400),VINT(400) 
15695       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
15696       SAVE 
15697     
15698 C...Convert VVAR to tau variable.   
15699       ISUB=MINT(1)  
15700       IF(IVAR.EQ.1) THEN    
15701         TAUMIN=VINT(11) 
15702         TAUMAX=VINT(31) 
15703         IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN 
15704           TAURE=VINT(73)    
15705           GAMRE=VINT(74)    
15706         ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN 
15707           TAURE=VINT(75)    
15708           GAMRE=VINT(76)    
15709         ENDIF   
15710         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN 
15711           TAU=1.    
15712         ELSEIF(MVAR.EQ.1) THEN  
15713           TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR  
15714         ELSEIF(MVAR.EQ.2) THEN  
15715           TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)   
15716         ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN 
15717           RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX    
15718           TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN) 
15719         ELSE    
15720           AUPP=ATAN((TAUMAX-TAURE)/GAMRE)   
15721           ALOW=ATAN((TAUMIN-TAURE)/GAMRE)   
15722           TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)    
15723         ENDIF   
15724         VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))    
15725     
15726 C...Convert VVAR to y* variable.    
15727       ELSEIF(IVAR.EQ.2) THEN    
15728         YSTMIN=VINT(12) 
15729         YSTMAX=VINT(32) 
15730         IF(MINT(43).EQ.1) THEN  
15731           YST=0.    
15732         ELSEIF(MINT(43).EQ.2) THEN  
15733           IF(ISET(ISUB).LE.2) YST=-0.5*LOG(VINT(21))    
15734           IF(ISET(ISUB).GE.3) YST=-0.5*LOG(VINT(26))    
15735         ELSEIF(MINT(43).EQ.3) THEN  
15736           IF(ISET(ISUB).LE.2) YST=0.5*LOG(VINT(21)) 
15737           IF(ISET(ISUB).GE.3) YST=0.5*LOG(VINT(26)) 
15738         ELSEIF(MVAR.EQ.1) THEN  
15739           YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR) 
15740         ELSEIF(MVAR.EQ.2) THEN  
15741           YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1.-VVAR)  
15742         ELSE    
15743           AUPP=ATAN(EXP(YSTMAX))    
15744           ALOW=ATAN(EXP(YSTMIN))    
15745           YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))   
15746         ENDIF   
15747         VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))    
15748     
15749 C...Convert VVAR to cos(theta-hat) variable.    
15750       ELSEIF(IVAR.EQ.3) THEN    
15751         RM34=2.*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2 
15752         RSQM=1.+RM34    
15753         IF(2.*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001) RM34=MAX(RM34,  
15754      &  2.*VINT(71)**2/(VINT(21)*VINT(2)))  
15755         CTNMIN=VINT(13) 
15756         CTNMAX=VINT(33) 
15757         CTPMIN=VINT(14) 
15758         CTPMAX=VINT(34) 
15759         IF(MVAR.EQ.1) THEN  
15760           ANEG=CTNMAX-CTNMIN    
15761           APOS=CTPMAX-CTPMIN    
15762           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
15763             VCTN=VVAR*(ANEG+APOS)/ANEG  
15764             CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN 
15765           ELSE  
15766             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
15767             CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP 
15768           ENDIF 
15769         ELSEIF(MVAR.EQ.2) THEN  
15770           RMNMIN=MAX(RM34,RSQM-CTNMIN)  
15771           RMNMAX=MAX(RM34,RSQM-CTNMAX)  
15772           RMPMIN=MAX(RM34,RSQM-CTPMIN)  
15773           RMPMAX=MAX(RM34,RSQM-CTPMAX)  
15774           ANEG=LOG(RMNMIN/RMNMAX)   
15775           APOS=LOG(RMPMIN/RMPMAX)   
15776           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
15777             VCTN=VVAR*(ANEG+APOS)/ANEG  
15778             CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN   
15779           ELSE  
15780             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
15781             CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP   
15782           ENDIF 
15783         ELSEIF(MVAR.EQ.3) THEN  
15784           RMNMIN=MAX(RM34,RSQM+CTNMIN)  
15785           RMNMAX=MAX(RM34,RSQM+CTNMAX)  
15786           RMPMIN=MAX(RM34,RSQM+CTPMIN)  
15787           RMPMAX=MAX(RM34,RSQM+CTPMAX)  
15788           ANEG=LOG(RMNMAX/RMNMIN)   
15789           APOS=LOG(RMPMAX/RMPMIN)   
15790           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
15791             VCTN=VVAR*(ANEG+APOS)/ANEG  
15792             CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM   
15793           ELSE  
15794             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
15795             CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM   
15796           ENDIF 
15797         ELSEIF(MVAR.EQ.4) THEN  
15798           RMNMIN=MAX(RM34,RSQM-CTNMIN)  
15799           RMNMAX=MAX(RM34,RSQM-CTNMAX)  
15800           RMPMIN=MAX(RM34,RSQM-CTPMIN)  
15801           RMPMAX=MAX(RM34,RSQM-CTPMAX)  
15802           ANEG=1./RMNMAX-1./RMNMIN  
15803           APOS=1./RMPMAX-1./RMPMIN  
15804           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
15805             VCTN=VVAR*(ANEG+APOS)/ANEG  
15806             CTH=RSQM-1./(1./RMNMIN+ANEG*VCTN)   
15807           ELSE  
15808             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
15809             CTH=RSQM-1./(1./RMPMIN+APOS*VCTP)   
15810           ENDIF 
15811         ELSEIF(MVAR.EQ.5) THEN  
15812           RMNMIN=MAX(RM34,RSQM+CTNMIN)  
15813           RMNMAX=MAX(RM34,RSQM+CTNMAX)  
15814           RMPMIN=MAX(RM34,RSQM+CTPMIN)  
15815           RMPMAX=MAX(RM34,RSQM+CTPMAX)  
15816           ANEG=1./RMNMIN-1./RMNMAX  
15817           APOS=1./RMPMIN-1./RMPMAX  
15818           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
15819             VCTN=VVAR*(ANEG+APOS)/ANEG  
15820             CTH=1./(1./RMNMIN-ANEG*VCTN)-RSQM   
15821           ELSE  
15822             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
15823             CTH=1./(1./RMPMIN-APOS*VCTP)-RSQM   
15824           ENDIF 
15825         ENDIF   
15826         IF(CTH.LT.0.) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))   
15827         IF(CTH.GT.0.) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))   
15828         VINT(23)=CTH    
15829     
15830 C...Convert VVAR to tau' variable.  
15831       ELSEIF(IVAR.EQ.4) THEN    
15832         TAU=VINT(11)    
15833         TAUPMN=VINT(16) 
15834         TAUPMX=VINT(36) 
15835         IF(MINT(43).EQ.1) THEN  
15836           TAUP=1.   
15837         ELSEIF(MVAR.EQ.1) THEN  
15838           TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR 
15839         ELSE    
15840           AUPP=(1.-TAU/TAUPMX)**4   
15841           ALOW=(1.-TAU/TAUPMN)**4   
15842           TAUP=TAU/(1.-(ALOW+(AUPP-ALOW)*VVAR)**0.25)   
15843         ENDIF   
15844         VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))   
15845       ENDIF 
15846     
15847       RETURN    
15848       END   
15849     
15850 C***********************************************************************    
15851     
15852       SUBROUTINE PYSIGH(NCHN,SIGS)  
15853     
15854 C...Differential matrix elements for all included subprocesses. 
15855 C...Note that what is coded is (disregarding the COMFAC factor) 
15856 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,  
15857 C...when d(sigma-hat) is given in the zero-width limit, the delta   
15858 C...function in tau is replaced by a Breit-Wigner:  
15859 C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);   
15860 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);   
15861 C...i.e., dimensionless quantities. COMFAC contains the factor  
15862 C...pi/s and the conversion factor from GeV^-2 to mb.   
15863       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
15864       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
15865       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
15866       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
15867       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
15868       COMMON/PYINT1/MINT(400),VINT(400) 
15869       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
15870       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
15871       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
15872       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
15873       DIMENSION X(2),XPQ(-6:6),KFAC(2,-40:40),WDTP(0:40),WDTE(0:40,0:5) 
15874       SAVE
15875 
15876 C...Reset number of channels and cross-section. 
15877       NCHN=0    
15878       SIGS=0.   
15879     
15880 C...Read kinematical variables and limits.  
15881       ISUB=MINT(1)  
15882       TAUMIN=VINT(11)   
15883       YSTMIN=VINT(12)   
15884       CTNMIN=VINT(13)   
15885       CTPMIN=VINT(14)   
15886       XT2MIN=VINT(15)   
15887       TAUPMN=VINT(16)   
15888       TAU=VINT(21)  
15889       YST=VINT(22)  
15890       CTH=VINT(23)  
15891       XT2=VINT(25)  
15892       TAUP=VINT(26) 
15893       TAUMAX=VINT(31)   
15894       YSTMAX=VINT(32)   
15895       CTNMAX=VINT(33)   
15896       CTPMAX=VINT(34)   
15897       XT2MAX=VINT(35)   
15898       TAUPMX=VINT(36)   
15899     
15900 C...Derive kinematical quantities.  
15901       IF(ISET(ISUB).LE.2.OR.ISET(ISUB).EQ.5) THEN   
15902         X(1)=SQRT(TAU)*EXP(YST) 
15903         X(2)=SQRT(TAU)*EXP(-YST)    
15904       ELSE  
15905         X(1)=SQRT(TAUP)*EXP(YST)    
15906         X(2)=SQRT(TAUP)*EXP(-YST)   
15907       ENDIF 
15908       IF(MINT(43).EQ.4.AND.ISET(ISUB).GE.1.AND. 
15909      &(X(1).GT.0.999.OR.X(2).GT.0.999)) RETURN  
15910       SH=TAU*VINT(2)    
15911       SQM3=VINT(63) 
15912       SQM4=VINT(64) 
15913       RM3=SQM3/SH   
15914       RM4=SQM4/SH   
15915       BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4) 
15916       RPTS=4.*VINT(71)**2/SH    
15917       BE34L=SQRT(MAX(0.,(1.-RM3-RM4)**2-4.*RM3*RM4-RPTS))   
15918       RM34=2.*RM3*RM4   
15919       RSQM=1.+RM34  
15920       RTHM=(4.*RM3*RM4+RPTS)/(1.-RM3-RM4+BE34L) 
15921       TH=-0.5*SH*MAX(RTHM,1.-RM3-RM4-BE34*CTH)  
15922       UH=-0.5*SH*MAX(RTHM,1.-RM3-RM4+BE34*CTH)  
15923       SQPTH=0.25*SH*BE34**2*(1.-CTH**2) 
15924       SH2=SH**2 
15925       TH2=TH**2 
15926       UH2=UH**2 
15927     
15928 C...Choice of Q2 scale. 
15929       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN   
15930         Q2=SH   
15931       ELSEIF(MOD(ISET(ISUB),2).EQ.0.OR.ISET(ISUB).EQ.5) THEN    
15932         IF(MSTP(32).EQ.1) THEN  
15933           Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)    
15934         ELSEIF(MSTP(32).EQ.2) THEN  
15935           Q2=SQPTH+0.5*(SQM3+SQM4)  
15936         ELSEIF(MSTP(32).EQ.3) THEN  
15937           Q2=MIN(-TH,-UH)   
15938         ELSEIF(MSTP(32).EQ.4) THEN  
15939           Q2=SH 
15940         ENDIF   
15941         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2=Q2+PARP(82)**2 
15942       ENDIF 
15943     
15944 C...Store derived kinematical quantities.   
15945       VINT(41)=X(1) 
15946       VINT(42)=X(2) 
15947       VINT(44)=SH   
15948       VINT(43)=SQRT(SH) 
15949       VINT(45)=TH   
15950       VINT(46)=UH   
15951       VINT(48)=SQPTH    
15952       VINT(47)=SQRT(SQPTH)  
15953       VINT(50)=TAUP*VINT(2) 
15954       VINT(49)=SQRT(MAX(0.,VINT(50)))   
15955       VINT(52)=Q2   
15956       VINT(51)=SQRT(Q2) 
15957     
15958 C...Calculate parton structure functions.   
15959       IF(ISET(ISUB).LE.0) GOTO 145  
15960       IF(MINT(43).GE.2) THEN    
15961         Q2SF=Q2 
15962         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN 
15963           Q2SF=PMAS(23,1)**2    
15964           IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2SF=PMAS(24,1)**2  
15965         ENDIF   
15966         DO 100 I=3-MINT(41),MINT(42)    
15967         XSF=X(I)    
15968         IF(ISET(ISUB).EQ.5) XSF=X(I)/VINT(142+I)    
15969         CALL PYSTFU(MINT(10+I),XSF,Q2SF,XPQ,I)    
15970         DO 100 KFL=-6,6 
15971   100   XSFX(I,KFL)=XPQ(KFL)
15972       ENDIF 
15973     
15974 C...Calculate alpha_strong and K-factor.    
15975       IF(MSTP(33).NE.3) AS=ULALPS(Q2)   
15976       FACK=1.   
15977       FACA=1.   
15978       IF(MSTP(33).EQ.1) THEN    
15979         FACK=PARP(31)   
15980       ELSEIF(MSTP(33).EQ.2) THEN    
15981         FACK=PARP(31)   
15982         FACA=PARP(32)/PARP(31)  
15983       ELSEIF(MSTP(33).EQ.3) THEN    
15984         Q2AS=PARP(33)*Q2    
15985         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2AS=Q2AS+    
15986      &  PARU(112)*PARP(82)  
15987         AS=ULALPS(Q2AS) 
15988       ENDIF 
15989       RADC=1.+AS/PARU(1)    
15990     
15991 C...Set flags for allowed reacting partons/leptons. 
15992       DO 130 I=1,2  
15993       DO 110 J=-40,40   
15994   110 KFAC(I,J)=0   
15995       IF(MINT(40+I).EQ.1) THEN  
15996         KFAC(I,MINT(10+I))=1    
15997       ELSE  
15998         DO 120 J=-40,40 
15999         KFAC(I,J)=KFIN(I,J) 
16000         IF(ABS(J).GT.MSTP(54).AND.J.NE.21) KFAC(I,J)=0  
16001         IF(ABS(J).LE.6) THEN    
16002           IF(XSFX(I,J).LT.1.E-10) KFAC(I,J)=0   
16003         ELSEIF(J.EQ.21) THEN    
16004           IF(XSFX(I,0).LT.1.E-10) KFAC(I,21)=0  
16005         ENDIF   
16006   120   CONTINUE    
16007       ENDIF 
16008   130 CONTINUE  
16009     
16010 C...Lower and upper limit for flavour loops.    
16011       MIN1=0    
16012       MAX1=0    
16013       MIN2=0    
16014       MAX2=0    
16015       DO 140 J=-20,20   
16016       IF(KFAC(1,-J).EQ.1) MIN1=-J   
16017       IF(KFAC(1,J).EQ.1) MAX1=J 
16018       IF(KFAC(2,-J).EQ.1) MIN2=-J   
16019       IF(KFAC(2,J).EQ.1) MAX2=J 
16020   140 CONTINUE  
16021       MINA=MIN(MIN1,MIN2)   
16022       MAXA=MAX(MAX1,MAX2)   
16023     
16024 C...Common conversion factors (including Jacobian) for subprocesses.    
16025       SQMZ=PMAS(23,1)**2    
16026       GMMZ=PMAS(23,1)*PMAS(23,2)    
16027       SQMW=PMAS(24,1)**2    
16028       GMMW=PMAS(24,1)*PMAS(24,2)    
16029       SQMH=PMAS(25,1)**2    
16030       GMMH=PMAS(25,1)*PMAS(25,2)    
16031       SQMZP=PMAS(32,1)**2   
16032       GMMZP=PMAS(32,1)*PMAS(32,2)   
16033       SQMHC=PMAS(37,1)**2   
16034       GMMHC=PMAS(37,1)*PMAS(37,2)   
16035       SQMR=PMAS(40,1)**2    
16036       GMMR=PMAS(40,1)*PMAS(40,2)    
16037       AEM=PARU(101) 
16038       XW=PARU(102)  
16039     
16040 C...Phase space integral in tau and y*. 
16041       COMFAC=PARU(1)*PARU(5)/VINT(2)    
16042       IF(MINT(43).EQ.4) COMFAC=COMFAC*FACK  
16043       IF((MINT(43).GE.2.OR.ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4).AND. 
16044      &ISET(ISUB).NE.5) THEN 
16045         ATAU0=LOG(TAUMAX/TAUMIN)    
16046         ATAU1=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)   
16047         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/TAU  
16048         IF(MINT(72).GE.1) THEN  
16049           TAUR1=VINT(73)    
16050           GAMR1=VINT(74)    
16051           ATAU2=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1  
16052           ATAU3=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/    
16053      &    GAMR1 
16054           H1=H1+(ATAU0/ATAU2)*COEF(ISUB,3)/(TAU+TAUR1)+ 
16055      &    (ATAU0/ATAU3)*COEF(ISUB,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)  
16056         ENDIF   
16057         IF(MINT(72).EQ.2) THEN  
16058           TAUR2=VINT(75)    
16059           GAMR2=VINT(76)    
16060           ATAU4=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2  
16061           ATAU5=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/    
16062      &    GAMR2 
16063           H1=H1+(ATAU0/ATAU4)*COEF(ISUB,5)/(TAU+TAUR2)+ 
16064      &    (ATAU0/ATAU5)*COEF(ISUB,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)  
16065         ENDIF   
16066         COMFAC=COMFAC*ATAU0/(TAU*H1)    
16067       ENDIF 
16068       IF(MINT(43).EQ.4.AND.ISET(ISUB).NE.5) THEN    
16069         AYST0=YSTMAX-YSTMIN 
16070         AYST1=0.5*(YSTMAX-YSTMIN)**2    
16071         AYST2=AYST1 
16072         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))  
16073         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST2)*   
16074      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)  
16075         COMFAC=COMFAC*AYST0/H2  
16076       ENDIF 
16077     
16078 C...2 -> 1 processes: reduction in angular part of phase space integral 
16079 C...for case of decaying resonance. 
16080       ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN 
16081       IF((ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3).AND.  
16082      &MDCY(KFPR(ISUB,1),1).EQ.1) THEN   
16083         IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN   
16084           COMFAC=COMFAC*0.5*ACTH0   
16085         ELSE    
16086           COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+    
16087      &    CTPMAX**3-CTPMIN**3)  
16088         ENDIF   
16089     
16090 C...2 -> 2 processes: angular part of phase space integral. 
16091       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN   
16092         ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/    
16093      &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))  
16094         ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/    
16095      &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))  
16096         ACTH3=1./MAX(RM34,RSQM-CTNMAX)-1./MAX(RM34,RSQM-CTNMIN)+    
16097      &  1./MAX(RM34,RSQM-CTPMAX)-1./MAX(RM34,RSQM-CTPMIN)   
16098         ACTH4=1./MAX(RM34,RSQM+CTNMIN)-1./MAX(RM34,RSQM+CTNMAX)+    
16099      &  1./MAX(RM34,RSQM+CTPMIN)-1./MAX(RM34,RSQM+CTPMAX)   
16100         H3=COEF(ISUB,10)+   
16101      &  (ACTH0/ACTH1)*COEF(ISUB,11)/MAX(RM34,RSQM-CTH)+ 
16102      &  (ACTH0/ACTH2)*COEF(ISUB,12)/MAX(RM34,RSQM+CTH)+ 
16103      &  (ACTH0/ACTH3)*COEF(ISUB,13)/MAX(RM34,RSQM-CTH)**2+  
16104      &  (ACTH0/ACTH4)*COEF(ISUB,14)/MAX(RM34,RSQM+CTH)**2   
16105         COMFAC=COMFAC*ACTH0*0.5*BE34/H3 
16106       ENDIF 
16107     
16108 C...2 -> 3, 4 processes: phace space integral in tau'.  
16109       IF(MINT(43).GE.2.AND.(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4)) THEN   
16110         ATAUP0=LOG(TAUPMX/TAUPMN)   
16111         ATAUP1=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU) 
16112         H4=COEF(ISUB,15)+   
16113      &  ATAUP0/ATAUP1*COEF(ISUB,16)/TAUP*(1.-TAU/TAUP)**3   
16114         IF(1.-TAU/TAUP.GT.1.E-4) THEN   
16115           FZW=(1.+TAU/TAUP)*LOG(TAUP/TAU)-2.*(1.-TAU/TAUP)  
16116         ELSE    
16117           FZW=1./6.*(1.-TAU/TAUP)**3*TAU/TAUP   
16118         ENDIF   
16119         COMFAC=COMFAC*ATAUP0*FZW/H4 
16120       ENDIF 
16121     
16122 C...Phase space integral for low-pT and multiple interactions.  
16123       IF(ISET(ISUB).EQ.5) THEN  
16124         COMFAC=PARU(1)*PARU(5)*FACK*0.5*VINT(2)/SH2 
16125         ATAU0=LOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)  
16126         ATAU1=2.*ATAN(1./XT2-1.)/SQRT(XT2)  
16127         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/SQRT(TAU)    
16128         COMFAC=COMFAC*ATAU0/H1  
16129         AYST0=YSTMAX-YSTMIN 
16130         AYST1=0.5*(YSTMAX-YSTMIN)**2    
16131         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))  
16132         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST1)*   
16133      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)  
16134         COMFAC=COMFAC*AYST0/H2  
16135         IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1./VINT(149)-1.)    
16136 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is 
16137 C...introduced to make cross-section finite for xT2 -> 0.   
16138         IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*  
16139      &  (1.+VINT(149))) 
16140       ENDIF 
16141     
16142 C...A: 2 -> 1, tree diagrams.   
16143     
16144   145 IF(ISUB.LE.10) THEN   
16145       IF(ISUB.EQ.1) THEN    
16146 C...f + fb -> gamma*/Z0.    
16147         MINT(61)=2  
16148         CALL PYWIDT(23,SQRT(SH),WDTP,WDTE)  
16149         FACZ=COMFAC*AEM**2*4./3.    
16150         DO 150 I=MINA,MAXA  
16151         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150    
16152         EI=KCHG(IABS(I),1)/3.   
16153         AI=SIGN(1.,EI)  
16154         VI=AI-4.*EI*XW  
16155         FACF=1. 
16156         IF(IABS(I).LE.10) FACF=FACA/3.  
16157         NCHN=NCHN+1 
16158         ISIG(NCHN,1)=I  
16159         ISIG(NCHN,2)=-I 
16160         ISIG(NCHN,3)=1  
16161         SIGH(NCHN)=FACF*FACZ*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*    
16162      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+(VI**2+AI**2)/    
16163      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*VINT(114))   
16164   150   CONTINUE    
16165     
16166       ELSEIF(ISUB.EQ.2) THEN    
16167 C...f + fb' -> W+/-.    
16168         CALL PYWIDT(24,SQRT(SH),WDTP,WDTE)  
16169         FACW=COMFAC*(AEM/XW)**2*1./24*SH2/((SH-SQMW)**2+GMMW**2)    
16170         DO 170 I=MIN1,MAX1  
16171         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 170   
16172         IA=IABS(I)  
16173         DO 160 J=MIN2,MAX2  
16174         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 160   
16175         JA=IABS(J)  
16176         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160  
16177         IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) GOTO 160 
16178         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
16179         FACF=1. 
16180         IF(IA.LE.10) FACF=VCKM((IA+1)/2,(JA+1)/2)*FACA/3.   
16181         NCHN=NCHN+1 
16182         ISIG(NCHN,1)=I  
16183         ISIG(NCHN,2)=J  
16184         ISIG(NCHN,3)=1  
16185         SIGH(NCHN)=FACF*FACW*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))   
16186   160   CONTINUE    
16187   170   CONTINUE    
16188     
16189       ELSEIF(ISUB.EQ.3) THEN    
16190 C...f + fb -> H0.   
16191         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
16192         FACH=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*    
16193      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))  
16194         DO 180 I=MINA,MAXA  
16195         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180    
16196         RMQ=PMAS(IABS(I),1)**2/SH   
16197         NCHN=NCHN+1 
16198         ISIG(NCHN,1)=I  
16199         ISIG(NCHN,2)=-I 
16200         ISIG(NCHN,3)=1  
16201         SIGH(NCHN)=FACH*RMQ*SQRT(MAX(0.,1.-4.*RMQ)) 
16202   180   CONTINUE    
16203     
16204       ELSEIF(ISUB.EQ.4) THEN    
16205 C...gamma + W+/- -> W+/-.   
16206     
16207       ELSEIF(ISUB.EQ.5) THEN    
16208 C...Z0 + Z0 -> H0.  
16209         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
16210         FACH=COMFAC*1./(128.*PARU(1)**2*16.*(1.-XW)**3)*(AEM/XW)**4*    
16211      &  (SH/SQMW)**2*SH2/((SH-SQMH)**2+GMMH**2)*    
16212      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) 
16213         DO 200 I=MIN1,MAX1  
16214         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200   
16215         DO 190 J=MIN2,MAX2  
16216         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190   
16217         EI=KCHG(IABS(I),1)/3.   
16218         AI=SIGN(1.,EI)  
16219         VI=AI-4.*EI*XW  
16220         EJ=KCHG(IABS(J),1)/3.   
16221         AJ=SIGN(1.,EJ)  
16222         VJ=AJ-4.*EJ*XW  
16223         NCHN=NCHN+1 
16224         ISIG(NCHN,1)=I  
16225         ISIG(NCHN,2)=J  
16226         ISIG(NCHN,3)=1  
16227         SIGH(NCHN)=FACH*(VI**2+AI**2)*(VJ**2+AJ**2) 
16228   190   CONTINUE    
16229   200   CONTINUE    
16230     
16231       ELSEIF(ISUB.EQ.6) THEN    
16232 C...Z0 + W+/- -> W+/-.  
16233     
16234       ELSEIF(ISUB.EQ.7) THEN    
16235 C...W+ + W- -> Z0.  
16236     
16237       ELSEIF(ISUB.EQ.8) THEN    
16238 C...W+ + W- -> H0.  
16239         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
16240         FACH=COMFAC*1./(128*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*   
16241      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))  
16242         DO 220 I=MIN1,MAX1  
16243         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 220   
16244         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)    
16245         DO 210 J=MIN2,MAX2  
16246         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 210   
16247         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)    
16248         IF(EI*EJ.GT.0.) GOTO 210    
16249         NCHN=NCHN+1 
16250         ISIG(NCHN,1)=I  
16251         ISIG(NCHN,2)=J  
16252         ISIG(NCHN,3)=1  
16253         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J) 
16254   210   CONTINUE    
16255   220   CONTINUE    
16256       ENDIF 
16257     
16258 C...B: 2 -> 2, tree diagrams.   
16259     
16260       ELSEIF(ISUB.LE.20) THEN   
16261       IF(ISUB.EQ.11) THEN   
16262 C...f + f' -> f + f'.   
16263         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2 
16264         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-  
16265      &  MSTP(34)*2./3.*UH2/(SH*TH)) 
16266         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-   
16267      &  MSTP(34)*2./3.*SH2/(TH*UH)) 
16268         DO 240 I=MIN1,MAX1  
16269         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240   
16270         DO 230 J=MIN2,MAX2  
16271         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230   
16272         NCHN=NCHN+1 
16273         ISIG(NCHN,1)=I  
16274         ISIG(NCHN,2)=J  
16275         ISIG(NCHN,3)=1  
16276         SIGH(NCHN)=FACQQ1   
16277         IF(I.EQ.-J) SIGH(NCHN)=FACQQB   
16278         IF(I.EQ.J) THEN 
16279           SIGH(NCHN)=0.5*SIGH(NCHN) 
16280           NCHN=NCHN+1   
16281           ISIG(NCHN,1)=I    
16282           ISIG(NCHN,2)=J    
16283           ISIG(NCHN,3)=2    
16284           SIGH(NCHN)=0.5*FACQQ2 
16285         ENDIF   
16286   230   CONTINUE    
16287   240   CONTINUE    
16288     
16289       ELSEIF(ISUB.EQ.12) THEN   
16290 C...f + fb -> f' + fb' (q + qb -> q' + qb' only).   
16291         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)  
16292         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+   
16293      &  WDTE(0,3)+WDTE(0,4))    
16294         DO 250 I=MINA,MAXA  
16295         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 250    
16296         NCHN=NCHN+1 
16297         ISIG(NCHN,1)=I  
16298         ISIG(NCHN,2)=-I 
16299         ISIG(NCHN,3)=1  
16300         SIGH(NCHN)=FACQQB   
16301   250   CONTINUE    
16302     
16303       ELSEIF(ISUB.EQ.13) THEN   
16304 C...f + fb -> g + g (q + qb -> g + g only). 
16305         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2) 
16306         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2) 
16307         DO 260 I=MINA,MAXA  
16308         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260    
16309         NCHN=NCHN+1 
16310         ISIG(NCHN,1)=I  
16311         ISIG(NCHN,2)=-I 
16312         ISIG(NCHN,3)=1  
16313         SIGH(NCHN)=0.5*FACGG1   
16314         NCHN=NCHN+1 
16315         ISIG(NCHN,1)=I  
16316         ISIG(NCHN,2)=-I 
16317         ISIG(NCHN,3)=2  
16318         SIGH(NCHN)=0.5*FACGG2   
16319   260   CONTINUE    
16320     
16321       ELSEIF(ISUB.EQ.14) THEN   
16322 C...f + fb -> g + gamma (q + qb -> g + gamma only). 
16323         FACGG=COMFAC*AS*AEM*8./9.*(TH2+UH2)/(TH*UH) 
16324         DO 270 I=MINA,MAXA  
16325         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270    
16326         EI=KCHG(IABS(I),1)/3.   
16327         NCHN=NCHN+1 
16328         ISIG(NCHN,1)=I  
16329         ISIG(NCHN,2)=-I 
16330         ISIG(NCHN,3)=1  
16331         SIGH(NCHN)=FACGG*EI**2  
16332   270   CONTINUE    
16333     
16334       ELSEIF(ISUB.EQ.15) THEN   
16335 C...f + fb -> g + Z0 (q + qb -> g + Z0 only).   
16336         FACZG=COMFAC*AS*AEM/(XW*(1.-XW))*1./18.*    
16337      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)    
16338         FACZG=FACZG*WIDS(23,2)  
16339         DO 280 I=MINA,MAXA  
16340         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280    
16341         EI=KCHG(IABS(I),1)/3.   
16342         AI=SIGN(1.,EI)  
16343         VI=AI-4.*EI*XW  
16344         NCHN=NCHN+1 
16345         ISIG(NCHN,1)=I  
16346         ISIG(NCHN,2)=-I 
16347         ISIG(NCHN,3)=1  
16348         SIGH(NCHN)=FACZG*(VI**2+AI**2)  
16349   280   CONTINUE    
16350     
16351       ELSEIF(ISUB.EQ.16) THEN   
16352 C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only). 
16353         FACWG=COMFAC*AS*AEM/XW*2./9.*(TH2+UH2+2.*SQM4*SH)/(TH*UH)   
16354         DO 300 I=MIN1,MAX1  
16355         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300   
16356         IA=IABS(I)  
16357         DO 290 J=MIN2,MAX2  
16358         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290   
16359         JA=IABS(J)  
16360         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290  
16361         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
16362         FCKM=1. 
16363         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
16364         NCHN=NCHN+1 
16365         ISIG(NCHN,1)=I  
16366         ISIG(NCHN,2)=J  
16367         ISIG(NCHN,3)=1  
16368         SIGH(NCHN)=FACWG*FCKM*WIDS(24,(5-KCHW)/2)   
16369   290   CONTINUE    
16370   300   CONTINUE    
16371     
16372       ELSEIF(ISUB.EQ.17) THEN   
16373 C...f + fb -> g + H0 (q + qb -> g + H0 only).   
16374     
16375       ELSEIF(ISUB.EQ.18) THEN   
16376 C...f + fb -> gamma + gamma.    
16377         FACGG=COMFAC*FACA*AEM**2*1./3.*(TH2+UH2)/(TH*UH)    
16378         DO 310 I=MINA,MAXA  
16379         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310    
16380         EI=KCHG(IABS(I),1)/3.   
16381         NCHN=NCHN+1 
16382         ISIG(NCHN,1)=I  
16383         ISIG(NCHN,2)=-I 
16384         ISIG(NCHN,3)=1  
16385         SIGH(NCHN)=FACGG*EI**4  
16386   310   CONTINUE    
16387     
16388       ELSEIF(ISUB.EQ.19) THEN   
16389 C...f + fb -> gamma + Z0.   
16390         FACGZ=COMFAC*FACA*AEM**2/(XW*(1.-XW))*1./24.*   
16391      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)    
16392         FACGZ=FACGZ*WIDS(23,2)  
16393         DO 320 I=MINA,MAXA  
16394         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320    
16395         EI=KCHG(IABS(I),1)/3.   
16396         AI=SIGN(1.,EI)  
16397         VI=AI-4.*EI*XW  
16398         NCHN=NCHN+1 
16399         ISIG(NCHN,1)=I  
16400         ISIG(NCHN,2)=-I 
16401         ISIG(NCHN,3)=1  
16402         SIGH(NCHN)=FACGZ*EI**2*(VI**2+AI**2)    
16403   320   CONTINUE    
16404     
16405       ELSEIF(ISUB.EQ.20) THEN   
16406 C...f + fb' -> gamma + W+/-.    
16407         FACGW=COMFAC*FACA*AEM**2/XW*1./6.*  
16408      &  ((2.*UH-TH)/(3.*(SH-SQM4)))**2*(TH2+UH2+2.*SQM4*SH)/(TH*UH) 
16409         DO 340 I=MIN1,MAX1  
16410         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340   
16411         IA=IABS(I)  
16412         DO 330 J=MIN2,MAX2  
16413         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330   
16414         JA=IABS(J)  
16415         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 330  
16416         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
16417         FCKM=1. 
16418         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
16419         NCHN=NCHN+1 
16420         ISIG(NCHN,1)=I  
16421         ISIG(NCHN,2)=J  
16422         ISIG(NCHN,3)=1  
16423         SIGH(NCHN)=FACGW*FCKM*WIDS(24,(5-KCHW)/2)   
16424   330   CONTINUE    
16425   340   CONTINUE    
16426       ENDIF 
16427     
16428       ELSEIF(ISUB.LE.30) THEN   
16429       IF(ISUB.EQ.21) THEN   
16430 C...f + fb -> gamma + H0.   
16431     
16432       ELSEIF(ISUB.EQ.22) THEN   
16433 C...f + fb -> Z0 + Z0.  
16434         FACZZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./768.*    
16435      &  (UH/TH+TH/UH+2.*(SQM3+SQM4)*SH/(TH*UH)- 
16436      &  SQM3*SQM4*(1./TH2+1./UH2))  
16437         FACZZ=FACZZ*WIDS(23,1)  
16438         DO 350 I=MINA,MAXA  
16439         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350    
16440         EI=KCHG(IABS(I),1)/3.   
16441         AI=SIGN(1.,EI)  
16442         VI=AI-4.*EI*XW  
16443         NCHN=NCHN+1 
16444         ISIG(NCHN,1)=I  
16445         ISIG(NCHN,2)=-I 
16446         ISIG(NCHN,3)=1  
16447         SIGH(NCHN)=FACZZ*(VI**4+6.*VI**2*AI**2+AI**4)   
16448   350   CONTINUE    
16449     
16450       ELSEIF(ISUB.EQ.23) THEN   
16451 C...f + fb' -> Z0 + W+/-.   
16452         FACZW=COMFAC*FACA*(AEM/XW)**2*1./6. 
16453         FACZW=FACZW*WIDS(23,2)  
16454         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
16455         DO 370 I=MIN1,MAX1  
16456         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370   
16457         IA=IABS(I)  
16458         DO 360 J=MIN2,MAX2  
16459         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360   
16460         JA=IABS(J)  
16461         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360  
16462         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
16463         EI=KCHG(IA,1)/3.    
16464         AI=SIGN(1.,EI)  
16465         VI=AI-4.*EI*XW  
16466         EJ=KCHG(JA,1)/3.    
16467         AJ=SIGN(1.,EJ)  
16468         VJ=AJ-4.*EJ*XW  
16469         IF(VI+AI.GT.0) THEN 
16470           VISAV=VI  
16471           AISAV=AI  
16472           VI=VJ 
16473           AI=AJ 
16474           VJ=VISAV  
16475           AJ=AISAV  
16476         ENDIF   
16477         FCKM=1. 
16478         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
16479         NCHN=NCHN+1 
16480         ISIG(NCHN,1)=I  
16481         ISIG(NCHN,2)=J  
16482         ISIG(NCHN,3)=1  
16483         SIGH(NCHN)=FACZW*FCKM*(1./(SH-SQMW)**2* 
16484      &  ((9.-8.*XW)/4.*THUH+(8.*XW-6.)/4.*SH*(SQM3+SQM4))+  
16485      &  (THUH-SH*(SQM3+SQM4))/(2.*(SH-SQMW))*((VJ+AJ)/TH-(VI+AI)/UH)+   
16486      &  THUH/(16.*(1.-XW))*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+ 
16487      &  SH*(SQM3+SQM4)/(8.*(1.-XW))*(VI+AI)*(VJ+AJ)/(TH*UH))*   
16488      &  WIDS(24,(5-KCHW)/2) 
16489   360   CONTINUE    
16490   370   CONTINUE    
16491     
16492       ELSEIF(ISUB.EQ.24) THEN   
16493 C...f + fb -> Z0 + H0.  
16494         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
16495         FACHZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./96.* 
16496      &  (THUH+2.*SH*SQMZ)/(SH-SQMZ)**2  
16497         FACHZ=FACHZ*WIDS(23,2)*WIDS(25,2)   
16498         DO 380 I=MINA,MAXA  
16499         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380    
16500         EI=KCHG(IABS(I),1)/3.   
16501         AI=SIGN(1.,EI)  
16502         VI=AI-4.*EI*XW  
16503         NCHN=NCHN+1 
16504         ISIG(NCHN,1)=I  
16505         ISIG(NCHN,2)=-I 
16506         ISIG(NCHN,3)=1  
16507         SIGH(NCHN)=FACHZ*(VI**2+AI**2)  
16508   380   CONTINUE    
16509     
16510       ELSEIF(ISUB.EQ.25) THEN   
16511 C...f + fb -> W+ + W-.  
16512         FACWW=COMFAC*FACA*(AEM/XW)**2*1./12.    
16513         FACWW=FACWW*WIDS(24,1)  
16514         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
16515         DO 390 I=MINA,MAXA  
16516         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390    
16517         EI=KCHG(IABS(I),1)/3.   
16518         AI=SIGN(1.,EI)  
16519         VI=AI-4.*EI*XW  
16520         DSIGWW=THUH/SH2*(3.-(SH-3.*(SQM3+SQM4))/(SH-SQMZ)*  
16521      &  (VI+AI)/(2.*AI*(1.-XW))+(SH/(SH-SQMZ))**2*  
16522      &  (1.-2.*(SQM3+SQM4)/SH+12.*SQM3*SQM4/SH2)*(VI**2+AI**2)/ 
16523      &  (8.*(1.-XW)**2))-2.*SQMZ/(SH-SQMZ)*(VI+AI)/AI+  
16524      &  SQMZ*SH/(SH-SQMZ)**2*(1.-2.*(SQM3+SQM4)/SH)*(VI**2+AI**2)/  
16525      &  (2.*(1.-XW))    
16526         IF(KCHG(IABS(I),1).LT.0) THEN   
16527           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))* 
16528      &    (THUH/(SH*TH)-(SQM3+SQM4)/TH)+THUH/TH2    
16529         ELSE    
16530           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))* 
16531      &    (THUH/(SH*UH)-(SQM3+SQM4)/UH)+THUH/UH2    
16532         ENDIF   
16533         NCHN=NCHN+1 
16534         ISIG(NCHN,1)=I  
16535         ISIG(NCHN,2)=-I 
16536         ISIG(NCHN,3)=1  
16537         SIGH(NCHN)=FACWW*DSIGWW 
16538   390   CONTINUE    
16539     
16540       ELSEIF(ISUB.EQ.26) THEN   
16541 C...f + fb' -> W+/- + H0.   
16542         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
16543         FACHW=COMFAC*FACA*(AEM/XW)**2*1./24.*(THUH+2.*SH*SQMW)/ 
16544      &  (SH-SQMW)**2    
16545         FACHW=FACHW*WIDS(25,2)  
16546         DO 410 I=MIN1,MAX1  
16547         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410   
16548         IA=IABS(I)  
16549         DO 400 J=MIN2,MAX2  
16550         IF(J.EQ.0.OR.KFAC(1,J).EQ.0) GOTO 400   
16551         JA=IABS(J)  
16552         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400  
16553         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
16554         FCKM=1. 
16555         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
16556         NCHN=NCHN+1 
16557         ISIG(NCHN,1)=I  
16558         ISIG(NCHN,2)=J  
16559         ISIG(NCHN,3)=1  
16560         SIGH(NCHN)=FACHW*FCKM*WIDS(24,(5-KCHW)/2)   
16561   400   CONTINUE    
16562   410   CONTINUE    
16563     
16564       ELSEIF(ISUB.EQ.27) THEN   
16565 C...f + fb -> H0 + H0.  
16566     
16567       ELSEIF(ISUB.EQ.28) THEN   
16568 C...f + g -> f + g (q + g -> q + g only).   
16569         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*  
16570      &  FACA    
16571         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)   
16572         DO 430 I=MINA,MAXA  
16573         IF(I.EQ.0) GOTO 430 
16574         DO 420 ISDE=1,2 
16575         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420    
16576         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420    
16577         NCHN=NCHN+1 
16578         ISIG(NCHN,ISDE)=I   
16579         ISIG(NCHN,3-ISDE)=21    
16580         ISIG(NCHN,3)=1  
16581         SIGH(NCHN)=FACQG1   
16582         NCHN=NCHN+1 
16583         ISIG(NCHN,ISDE)=I   
16584         ISIG(NCHN,3-ISDE)=21    
16585         ISIG(NCHN,3)=2  
16586         SIGH(NCHN)=FACQG2   
16587   420   CONTINUE    
16588   430   CONTINUE    
16589     
16590       ELSEIF(ISUB.EQ.29) THEN   
16591 C...f + g -> f + gamma (q + g -> q + gamma only).   
16592         FGQ=COMFAC*FACA*AS*AEM*1./3.*(SH2+UH2)/(-SH*UH) 
16593         DO 450 I=MINA,MAXA  
16594         IF(I.EQ.0) GOTO 450 
16595         EI=KCHG(IABS(I),1)/3.   
16596         FACGQ=FGQ*EI**2 
16597         DO 440 ISDE=1,2 
16598         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 440    
16599         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 440    
16600         NCHN=NCHN+1 
16601         ISIG(NCHN,ISDE)=I   
16602         ISIG(NCHN,3-ISDE)=21    
16603         ISIG(NCHN,3)=1  
16604         SIGH(NCHN)=FACGQ    
16605   440   CONTINUE    
16606   450   CONTINUE    
16607     
16608       ELSEIF(ISUB.EQ.30) THEN   
16609 C...f + g -> f + Z0 (q + g -> q + Z0 only). 
16610         FZQ=COMFAC*FACA*AS*AEM/(XW*(1.-XW))*1./48.* 
16611      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)   
16612         FZQ=FZQ*WIDS(23,2)  
16613         DO 470 I=MINA,MAXA  
16614         IF(I.EQ.0) GOTO 470 
16615         EI=KCHG(IABS(I),1)/3.   
16616         AI=SIGN(1.,EI)  
16617         VI=AI-4.*EI*XW  
16618         FACZQ=FZQ*(VI**2+AI**2) 
16619         DO 460 ISDE=1,2 
16620         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 460    
16621         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 460    
16622         NCHN=NCHN+1 
16623         ISIG(NCHN,ISDE)=I   
16624         ISIG(NCHN,3-ISDE)=21    
16625         ISIG(NCHN,3)=1  
16626         SIGH(NCHN)=FACZQ    
16627   460   CONTINUE    
16628   470   CONTINUE    
16629       ENDIF 
16630     
16631       ELSEIF(ISUB.LE.40) THEN   
16632       IF(ISUB.EQ.31) THEN   
16633 C...f + g -> f' + W+/- (q + g -> q' + W+/- only).   
16634         FACWQ=COMFAC*FACA*AS*AEM/XW*1./12.* 
16635      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)   
16636         DO 490 I=MINA,MAXA  
16637         IF(I.EQ.0) GOTO 490 
16638         IA=IABS(I)  
16639         KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) 
16640         DO 480 ISDE=1,2 
16641         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 480    
16642         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 480    
16643         NCHN=NCHN+1 
16644         ISIG(NCHN,ISDE)=I   
16645         ISIG(NCHN,3-ISDE)=21    
16646         ISIG(NCHN,3)=1  
16647         SIGH(NCHN)=FACWQ*VINT(180+I)*WIDS(24,(5-KCHW)/2)    
16648   480   CONTINUE    
16649   490   CONTINUE    
16650     
16651       ELSEIF(ISUB.EQ.32) THEN   
16652 C...f + g -> f + H0 (q + g -> q + H0 only). 
16653     
16654       ELSEIF(ISUB.EQ.33) THEN   
16655 C...f + gamma -> f + g (q + gamma -> q + g only).   
16656     
16657       ELSEIF(ISUB.EQ.34) THEN   
16658 C...f + gamma -> f + gamma. 
16659     
16660       ELSEIF(ISUB.EQ.35) THEN   
16661 C...f + gamma -> f + Z0.    
16662     
16663       ELSEIF(ISUB.EQ.36) THEN   
16664 C...f + gamma -> f' + W+/-. 
16665     
16666       ELSEIF(ISUB.EQ.37) THEN   
16667 C...f + gamma -> f + H0.    
16668     
16669       ELSEIF(ISUB.EQ.38) THEN   
16670 C...f + Z0 -> f + g (q + Z0 -> q + g only). 
16671     
16672       ELSEIF(ISUB.EQ.39) THEN   
16673 C...f + Z0 -> f + gamma.    
16674     
16675       ELSEIF(ISUB.EQ.40) THEN   
16676 C...f + Z0 -> f + Z0.   
16677       ENDIF 
16678     
16679       ELSEIF(ISUB.LE.50) THEN   
16680       IF(ISUB.EQ.41) THEN   
16681 C...f + Z0 -> f' + W+/-.    
16682     
16683       ELSEIF(ISUB.EQ.42) THEN   
16684 C...f + Z0 -> f + H0.   
16685     
16686       ELSEIF(ISUB.EQ.43) THEN   
16687 C...f + W+/- -> f' + g (q + W+/- -> q' + g only).   
16688     
16689       ELSEIF(ISUB.EQ.44) THEN   
16690 C...f + W+/- -> f' + gamma. 
16691     
16692       ELSEIF(ISUB.EQ.45) THEN   
16693 C...f + W+/- -> f' + Z0.    
16694     
16695       ELSEIF(ISUB.EQ.46) THEN   
16696 C...f + W+/- -> f' + W+/-.  
16697     
16698       ELSEIF(ISUB.EQ.47) THEN   
16699 C...f + W+/- -> f' + H0.    
16700     
16701       ELSEIF(ISUB.EQ.48) THEN   
16702 C...f + H0 -> f + g (q + H0 -> q + g only). 
16703     
16704       ELSEIF(ISUB.EQ.49) THEN   
16705 C...f + H0 -> f + gamma.    
16706     
16707       ELSEIF(ISUB.EQ.50) THEN   
16708 C...f + H0 -> f + Z0.   
16709       ENDIF 
16710     
16711       ELSEIF(ISUB.LE.60) THEN   
16712       IF(ISUB.EQ.51) THEN   
16713 C...f + H0 -> f' + W+/-.    
16714     
16715       ELSEIF(ISUB.EQ.52) THEN   
16716 C...f + H0 -> f + H0.   
16717     
16718       ELSEIF(ISUB.EQ.53) THEN   
16719 C...g + g -> f + fb (g + g -> q + qb only). 
16720         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)  
16721         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*  
16722      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
16723         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*  
16724      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
16725         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500 
16726         NCHN=NCHN+1 
16727         ISIG(NCHN,1)=21 
16728         ISIG(NCHN,2)=21 
16729         ISIG(NCHN,3)=1  
16730         SIGH(NCHN)=FACQQ1   
16731         NCHN=NCHN+1 
16732         ISIG(NCHN,1)=21 
16733         ISIG(NCHN,2)=21 
16734         ISIG(NCHN,3)=2  
16735         SIGH(NCHN)=FACQQ2   
16736   500   CONTINUE    
16737     
16738       ELSEIF(ISUB.EQ.54) THEN   
16739 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
16740     
16741       ELSEIF(ISUB.EQ.55) THEN   
16742 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
16743     
16744       ELSEIF(ISUB.EQ.56) THEN   
16745 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
16746     
16747       ELSEIF(ISUB.EQ.57) THEN   
16748 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
16749     
16750       ELSEIF(ISUB.EQ.58) THEN   
16751 C...gamma + gamma -> f + fb.    
16752     
16753       ELSEIF(ISUB.EQ.59) THEN   
16754 C...gamma + Z0 -> f + fb.   
16755     
16756       ELSEIF(ISUB.EQ.60) THEN   
16757 C...gamma + W+/- -> f + fb'.    
16758       ENDIF 
16759     
16760       ELSEIF(ISUB.LE.70) THEN   
16761       IF(ISUB.EQ.61) THEN   
16762 C...gamma + H0 -> f + fb.   
16763     
16764       ELSEIF(ISUB.EQ.62) THEN   
16765 C...Z0 + Z0 -> f + fb.  
16766     
16767       ELSEIF(ISUB.EQ.63) THEN   
16768 C...Z0 + W+/- -> f + fb'.   
16769     
16770       ELSEIF(ISUB.EQ.64) THEN   
16771 C...Z0 + H0 -> f + fb.  
16772     
16773       ELSEIF(ISUB.EQ.65) THEN   
16774 C...W+ + W- -> f + fb.  
16775     
16776       ELSEIF(ISUB.EQ.66) THEN   
16777 C...W+/- + H0 -> f + fb'.   
16778     
16779       ELSEIF(ISUB.EQ.67) THEN   
16780 C...H0 + H0 -> f + fb.  
16781     
16782       ELSEIF(ISUB.EQ.68) THEN   
16783 C...g + g -> g + g. 
16784         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+    
16785      &  TH2/SH2)*FACA   
16786         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+    
16787      &  SH2/UH2)*FACA   
16788         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2) 
16789         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510 
16790         NCHN=NCHN+1 
16791         ISIG(NCHN,1)=21 
16792         ISIG(NCHN,2)=21 
16793         ISIG(NCHN,3)=1  
16794         SIGH(NCHN)=0.5*FACGG1   
16795         NCHN=NCHN+1 
16796         ISIG(NCHN,1)=21 
16797         ISIG(NCHN,2)=21 
16798         ISIG(NCHN,3)=2  
16799         SIGH(NCHN)=0.5*FACGG2   
16800         NCHN=NCHN+1 
16801         ISIG(NCHN,1)=21 
16802         ISIG(NCHN,2)=21 
16803         ISIG(NCHN,3)=3  
16804         SIGH(NCHN)=0.5*FACGG3   
16805   510   CONTINUE    
16806     
16807       ELSEIF(ISUB.EQ.69) THEN   
16808 C...gamma + gamma -> W+ + W-.   
16809     
16810       ELSEIF(ISUB.EQ.70) THEN   
16811 C...gamma + W+/- -> gamma + W+/-.   
16812       ENDIF 
16813     
16814       ELSEIF(ISUB.LE.80) THEN   
16815       IF(ISUB.EQ.71) THEN   
16816 C...Z0 + Z0 -> Z0 + Z0. 
16817         BE2=1.-4.*SQMZ/SH   
16818         TH=-0.5*SH*BE2*(1.-CTH) 
16819         UH=-0.5*SH*BE2*(1.+CTH) 
16820         SHANG=1./(1.-XW)*SQMW/SQMZ*(1.+BE2)**2  
16821         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
16822         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
16823         THANG=1./(1.-XW)*SQMW/SQMZ*(BE2-CTH)**2 
16824         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG    
16825         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG    
16826         UHANG=1./(1.-XW)*SQMW/SQMZ*(BE2+CTH)**2 
16827         AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG    
16828         AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG    
16829         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*   
16830      &  (AEM/XW)**4*(SH/SQMW)**2*((ASHRE+ATHRE+AUHRE)**2+   
16831      &  (ASHIM+ATHIM+AUHIM)**2)*SQMZ/SQMW   
16832         DO 530 I=MIN1,MAX1  
16833         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530   
16834         EI=KCHG(IABS(I),1)/3.   
16835         AI=SIGN(1.,EI)  
16836         VI=AI-4.*EI*XW  
16837         AVI=AI**2+VI**2 
16838         DO 520 J=MIN2,MAX2  
16839         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520   
16840         EJ=KCHG(IABS(J),1)/3.   
16841         AJ=SIGN(1.,EJ)  
16842         VJ=AJ-4.*EJ*XW  
16843         AVJ=AJ**2+VJ**2 
16844         NCHN=NCHN+1 
16845         ISIG(NCHN,1)=I  
16846         ISIG(NCHN,2)=J  
16847         ISIG(NCHN,3)=1  
16848         SIGH(NCHN)=FACH*AVI*AVJ 
16849   520   CONTINUE    
16850   530   CONTINUE    
16851     
16852       ELSEIF(ISUB.EQ.72) THEN   
16853 C...Z0 + Z0 -> W+ + W-. 
16854         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))   
16855         CTH2=CTH**2 
16856         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)   
16857         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)   
16858         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)* 
16859      &  (1.-2.*SQMZ/SH) 
16860         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
16861         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
16862         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-    
16863      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
16864      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
16865      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))   
16866         ATWIM=0.    
16867         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-    
16868      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
16869      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
16870      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))   
16871         AUWIM=0.    
16872         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)    
16873         A4IM=0. 
16874         FACH=COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*(AEM/XW)**4*   
16875      &  (SH/SQMW)**2*((ASHRE+ATWRE+AUWRE+A4RE)**2+  
16876      &  (ASHIM+ATWIM+AUWIM+A4IM)**2)*SQMZ/SQMW  
16877         DO 550 I=MIN1,MAX1  
16878         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 550   
16879         EI=KCHG(IABS(I),1)/3.   
16880         AI=SIGN(1.,EI)  
16881         VI=AI-4.*EI*XW  
16882         AVI=AI**2+VI**2 
16883         DO 540 J=MIN2,MAX2  
16884         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 540   
16885         EJ=KCHG(IABS(J),1)/3.   
16886         AJ=SIGN(1.,EJ)  
16887         VJ=AJ-4.*EJ*XW  
16888         AVJ=AJ**2+VJ**2 
16889         NCHN=NCHN+1 
16890         ISIG(NCHN,1)=I  
16891         ISIG(NCHN,2)=J  
16892         ISIG(NCHN,3)=1  
16893         SIGH(NCHN)=FACH*AVI*AVJ 
16894   540   CONTINUE    
16895   550   CONTINUE    
16896     
16897       ELSEIF(ISUB.EQ.73) THEN   
16898 C...Z0 + W+/- -> Z0 + W+/-. 
16899         BE2=1.-2.*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2    
16900         EP1=1.+(SQMZ-SQMW)/SH   
16901         EP2=1.-(SQMZ-SQMW)/SH   
16902         TH=-0.5*SH*BE2*(1.-CTH) 
16903         UH=(SQMZ-SQMW)**2/SH-0.5*SH*BE2*(1.+CTH)    
16904         THANG=SQRT(SQMW/(SQMZ*(1.-XW)))*(BE2-EP1*CTH)*(BE2-EP2*CTH) 
16905         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG    
16906         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG    
16907         ASWRE=(1.-XW)/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+ 
16908      &  1./4.*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4.*BE2*CTH)+   
16909      &  2.*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-  
16910      &  1./16.*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2) 
16911         ASWIM=0.    
16912         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*    
16913      &  (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*  
16914      &  (BE2+EP1*EP2*CTH)*(2.*EP2-EP2*CTH+EP1)-BE2*(EP2+EP1*CTH)**2*    
16915      &  (BE2-EP2**2*CTH)-1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+  
16916      &  2.*BE2*(1.-CTH))+1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*   
16917      &  (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)* 
16918      &  (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*  
16919      &  (2.*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*(BE2-EP1**2*CTH)- 
16920      &  1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2.*BE2*(1.-CTH))+  
16921      &  1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2) 
16922         AUWIM=0.    
16923         A4RE=(1.-XW)/SQMZ*(EP1**2*EP2**2*(CTH**2-1.)-   
16924      &  2.*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2.*BE2*EP1*EP2)  
16925         A4IM=0. 
16926         FACH=COMFAC*1./(4096.*PARU(1)**2*4.*(1.-XW))*(AEM/XW)**4*   
16927      &  (SH/SQMW)**2*((ATHRE+ASWRE+AUWRE+A4RE)**2+  
16928      &  (ATHIM+ASWIM+AUWIM+A4IM)**2)*SQRT(SQMZ/SQMW)    
16929         DO 570 I=MIN1,MAX1  
16930         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 570   
16931         EI=KCHG(IABS(I),1)/3.   
16932         AI=SIGN(1.,EI)  
16933         VI=AI-4.*EI*XW  
16934         AVI=AI**2+VI**2 
16935         DO 560 J=MIN2,MAX2  
16936         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 560   
16937         EJ=KCHG(IABS(J),1)/3.   
16938         AJ=SIGN(1.,EJ)  
16939         VJ=AI-4.*EJ*XW  
16940         AVJ=AJ**2+VJ**2 
16941         NCHN=NCHN+1 
16942         ISIG(NCHN,1)=I  
16943         ISIG(NCHN,2)=J  
16944         ISIG(NCHN,3)=1  
16945         SIGH(NCHN)=FACH*(AVI*VINT(180+J)+VINT(180+I)*AVJ)   
16946   560   CONTINUE    
16947   570   CONTINUE    
16948     
16949       ELSEIF(ISUB.EQ.75) THEN   
16950 C...W+ + W- -> gamma + gamma.   
16951     
16952       ELSEIF(ISUB.EQ.76) THEN   
16953 C...W+ + W- -> Z0 + Z0. 
16954         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))   
16955         CTH2=CTH**2 
16956         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)   
16957         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)   
16958         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)* 
16959      &  (1.-2.*SQMZ/SH) 
16960         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
16961         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
16962         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-    
16963      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
16964      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
16965      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))   
16966         ATWIM=0.    
16967         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-    
16968      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
16969      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
16970      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))   
16971         AUWIM=0.    
16972         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)    
16973         A4IM=0. 
16974         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2* 
16975      &  ((ASHRE+ATWRE+AUWRE+A4RE)**2+(ASHIM+ATWIM+AUWIM+A4IM)**2)   
16976         DO 590 I=MIN1,MAX1  
16977         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 590   
16978         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)    
16979         DO 580 J=MIN2,MAX2  
16980         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 580   
16981         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)    
16982         IF(EI*EJ.GT.0.) GOTO 580    
16983         NCHN=NCHN+1 
16984         ISIG(NCHN,1)=I  
16985         ISIG(NCHN,2)=J  
16986         ISIG(NCHN,3)=1  
16987         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J) 
16988   580   CONTINUE    
16989   590   CONTINUE    
16990     
16991       ELSEIF(ISUB.EQ.77) THEN   
16992 C...W+/- + W+/- -> W+/- + W+/-. 
16993         BE2=1.-4.*SQMW/SH   
16994         BE4=BE2**2  
16995         CTH2=CTH**2 
16996         CTH3=CTH**3 
16997         TH=-0.5*SH*BE2*(1.-CTH) 
16998         UH=-0.5*SH*BE2*(1.+CTH) 
16999         SHANG=(1.+BE2)**2   
17000         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
17001         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
17002         THANG=(BE2-CTH)**2  
17003         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG    
17004         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG    
17005         SGZANG=1./SQMW*BE2*(3.-BE2)**2*CTH  
17006         ASGRE=XW*SGZANG 
17007         ASGIM=0.    
17008         ASZRE=(1.-XW)*SH/(SH-SQMZ)*SGZANG   
17009         ASZIM=0.    
17010         TGZANG=1./SQMW*(BE2*(4.-2.*BE2+BE4)+BE2*(4.-10.*BE2+BE4)*CTH+   
17011      &  (2.-11.*BE2+10.*BE4)*CTH2+BE2*CTH3) 
17012         ATGRE=0.5*XW*SH/TH*TGZANG   
17013         ATGIM=0.    
17014         ATZRE=0.5*(1.-XW)*SH/(TH-SQMZ)*TGZANG   
17015         ATZIM=0.    
17016         A4RE=1./SQMW*(1.+2.*BE2-6.*BE2*CTH-CTH2)    
17017         A4IM=0. 
17018         FACH=COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2* 
17019      &  ((ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4RE)**2+ 
17020      &  (ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4IM)**2)  
17021         DO 610 I=MIN1,MAX1  
17022         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 610   
17023         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)    
17024         DO 600 J=MIN2,MAX2  
17025         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 600   
17026         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)    
17027         IF(EI*EJ.GT.0.) GOTO 600    
17028         NCHN=NCHN+1 
17029         ISIG(NCHN,1)=I  
17030         ISIG(NCHN,2)=J  
17031         ISIG(NCHN,3)=1  
17032         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J) 
17033   600   CONTINUE    
17034   610   CONTINUE    
17035     
17036       ELSEIF(ISUB.EQ.78) THEN   
17037 C...W+/- + H0 -> W+/- + H0. 
17038     
17039       ELSEIF(ISUB.EQ.79) THEN   
17040 C...H0 + H0 -> H0 + H0. 
17041     
17042       ENDIF 
17043     
17044 C...C: 2 -> 2, tree diagrams with masses.   
17045     
17046       ELSEIF(ISUB.LE.90) THEN   
17047       IF(ISUB.EQ.81) THEN   
17048 C...q + qb -> Q + QB.   
17049         FACQQB=COMFAC*AS**2*4./9.*(((TH-SQM3)**2+   
17050      &  (UH-SQM3)**2)/SH2+2.*SQM3/SH)   
17051         IF(MSTP(35).GE.1) THEN  
17052           IF(MSTP(35).EQ.1) THEN    
17053             ALSSG=PARP(35)  
17054           ELSE  
17055             MST115=MSTU(115)    
17056             MSTU(115)=MSTP(36)  
17057             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))   
17058             ALSSG=ULALPS(Q2BN)  
17059             MSTU(115)=MST115    
17060           ENDIF 
17061           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))   
17062           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.) 
17063           PARI(81)=FREPU    
17064           FACQQB=FACQQB*FREPU   
17065         ENDIF   
17066         DO 620 I=MINA,MAXA  
17067         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 620    
17068         NCHN=NCHN+1 
17069         ISIG(NCHN,1)=I  
17070         ISIG(NCHN,2)=-I 
17071         ISIG(NCHN,3)=1  
17072         SIGH(NCHN)=FACQQB   
17073   620   CONTINUE    
17074     
17075       ELSEIF(ISUB.EQ.82) THEN   
17076 C...g + g -> Q + QB.    
17077         FACQQ1=COMFAC*FACA*AS**2*1./6.*((UH-SQM3)/(TH-SQM3)-    
17078      &  2.*(UH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(TH-SQM3)**2)    
17079         FACQQ2=COMFAC*FACA*AS**2*1./6.*((TH-SQM3)/(UH-SQM3)-    
17080      &  2.*(TH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(UH-SQM3)**2)    
17081         IF(MSTP(35).GE.1) THEN  
17082           IF(MSTP(35).EQ.1) THEN    
17083             ALSSG=PARP(35)  
17084           ELSE  
17085             MST115=MSTU(115)    
17086             MSTU(115)=MSTP(36)  
17087             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))   
17088             ALSSG=ULALPS(Q2BN)  
17089             MSTU(115)=MST115    
17090           ENDIF 
17091           XATTR=4.*PARU(1)*ALSSG/(3.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))    
17092           FATTR=XATTR/(1.-EXP(-MIN(100.,XATTR)))    
17093           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))   
17094           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.) 
17095           FATRE=(2.*FATTR+5.*FREPU)/7.  
17096           PARI(81)=FATRE    
17097           FACQQ1=FACQQ1*FATRE   
17098           FACQQ2=FACQQ2*FATRE   
17099         ENDIF   
17100         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 630 
17101         NCHN=NCHN+1 
17102         ISIG(NCHN,1)=21 
17103         ISIG(NCHN,2)=21 
17104         ISIG(NCHN,3)=1  
17105         SIGH(NCHN)=FACQQ1   
17106         NCHN=NCHN+1 
17107         ISIG(NCHN,1)=21 
17108         ISIG(NCHN,2)=21 
17109         ISIG(NCHN,3)=2  
17110         SIGH(NCHN)=FACQQ2   
17111   630   CONTINUE    
17112     
17113       ENDIF 
17114     
17115 C...D: Mimimum bias processes.  
17116     
17117       ELSEIF(ISUB.LE.100) THEN  
17118       IF(ISUB.EQ.91) THEN   
17119 C...Elastic scattering. 
17120         SIGS=XSEC(ISUB,1)   
17121     
17122       ELSEIF(ISUB.EQ.92) THEN   
17123 C...Single diffractive scattering.  
17124         SIGS=XSEC(ISUB,1)   
17125     
17126       ELSEIF(ISUB.EQ.93) THEN   
17127 C...Double diffractive scattering.  
17128         SIGS=XSEC(ISUB,1)   
17129     
17130       ELSEIF(ISUB.EQ.94) THEN   
17131 C...Central diffractive scattering. 
17132         SIGS=XSEC(ISUB,1)   
17133     
17134       ELSEIF(ISUB.EQ.95) THEN   
17135 C...Low-pT scattering.  
17136         SIGS=XSEC(ISUB,1)   
17137     
17138       ELSEIF(ISUB.EQ.96) THEN   
17139 C...Multiple interactions: sum of QCD processes.    
17140         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)  
17141     
17142 C...q + q' -> q + q'.   
17143         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2 
17144         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-  
17145      &  MSTP(34)*2./3.*UH2/(SH*TH)) 
17146         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-   
17147      &  MSTP(34)*2./3.*SH2/(TH*UH)) 
17148         DO 650 I=-3,3   
17149         IF(I.EQ.0) GOTO 650 
17150         DO 640 J=-3,3   
17151         IF(J.EQ.0) GOTO 640 
17152         NCHN=NCHN+1 
17153         ISIG(NCHN,1)=I  
17154         ISIG(NCHN,2)=J  
17155         ISIG(NCHN,3)=111    
17156         SIGH(NCHN)=FACQQ1   
17157         IF(I.EQ.-J) SIGH(NCHN)=FACQQB   
17158         IF(I.EQ.J) THEN 
17159           SIGH(NCHN)=0.5*SIGH(NCHN) 
17160           NCHN=NCHN+1   
17161           ISIG(NCHN,1)=I    
17162           ISIG(NCHN,2)=J    
17163           ISIG(NCHN,3)=112  
17164           SIGH(NCHN)=0.5*FACQQ2 
17165         ENDIF   
17166   640   CONTINUE    
17167   650   CONTINUE    
17168     
17169 C...q + qb -> q' + qb' or g + g.    
17170         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+   
17171      &  WDTE(0,3)+WDTE(0,4))    
17172         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2) 
17173         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2) 
17174         DO 660 I=-3,3   
17175         IF(I.EQ.0) GOTO 660 
17176         NCHN=NCHN+1 
17177         ISIG(NCHN,1)=I  
17178         ISIG(NCHN,2)=-I 
17179         ISIG(NCHN,3)=121    
17180         SIGH(NCHN)=FACQQB   
17181         NCHN=NCHN+1 
17182         ISIG(NCHN,1)=I  
17183         ISIG(NCHN,2)=-I 
17184         ISIG(NCHN,3)=131    
17185         SIGH(NCHN)=0.5*FACGG1   
17186         NCHN=NCHN+1 
17187         ISIG(NCHN,1)=I  
17188         ISIG(NCHN,2)=-I 
17189         ISIG(NCHN,3)=132    
17190         SIGH(NCHN)=0.5*FACGG2   
17191   660   CONTINUE    
17192     
17193 C...q + g -> q + g. 
17194         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*  
17195      &  FACA    
17196         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)   
17197         DO 680 I=-3,3   
17198         IF(I.EQ.0) GOTO 680 
17199         DO 670 ISDE=1,2 
17200         NCHN=NCHN+1 
17201         ISIG(NCHN,ISDE)=I   
17202         ISIG(NCHN,3-ISDE)=21    
17203         ISIG(NCHN,3)=281    
17204         SIGH(NCHN)=FACQG1   
17205         NCHN=NCHN+1 
17206         ISIG(NCHN,ISDE)=I   
17207         ISIG(NCHN,3-ISDE)=21    
17208         ISIG(NCHN,3)=282    
17209         SIGH(NCHN)=FACQG2   
17210   670   CONTINUE    
17211   680   CONTINUE    
17212     
17213 C...g + g -> q + qb or g + g.   
17214         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*  
17215      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
17216         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*  
17217      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
17218         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+    
17219      &  TH2/SH2)*FACA   
17220         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+    
17221      &  SH2/UH2)*FACA   
17222         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2) 
17223         NCHN=NCHN+1 
17224         ISIG(NCHN,1)=21 
17225         ISIG(NCHN,2)=21 
17226         ISIG(NCHN,3)=531    
17227         SIGH(NCHN)=FACQQ1   
17228         NCHN=NCHN+1 
17229         ISIG(NCHN,1)=21 
17230         ISIG(NCHN,2)=21 
17231         ISIG(NCHN,3)=532    
17232         SIGH(NCHN)=FACQQ2   
17233         NCHN=NCHN+1 
17234         ISIG(NCHN,1)=21 
17235         ISIG(NCHN,2)=21 
17236         ISIG(NCHN,3)=681    
17237         SIGH(NCHN)=0.5*FACGG1   
17238         NCHN=NCHN+1 
17239         ISIG(NCHN,1)=21 
17240         ISIG(NCHN,2)=21 
17241         ISIG(NCHN,3)=682    
17242         SIGH(NCHN)=0.5*FACGG2   
17243         NCHN=NCHN+1 
17244         ISIG(NCHN,1)=21 
17245         ISIG(NCHN,2)=21 
17246         ISIG(NCHN,3)=683    
17247         SIGH(NCHN)=0.5*FACGG3   
17248       ENDIF 
17249     
17250 C...E: 2 -> 1, loop diagrams.   
17251     
17252       ELSEIF(ISUB.LE.110) THEN  
17253       IF(ISUB.EQ.101) THEN  
17254 C...g + g -> gamma*/Z0. 
17255     
17256       ELSEIF(ISUB.EQ.102) THEN  
17257 C...g + g -> H0.    
17258         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
17259         ETARE=0.    
17260         ETAIM=0.    
17261         DO 690 I=1,2*MSTP(1)    
17262         EPS=4.*PMAS(I,1)**2/SH  
17263         IF(EPS.LE.1.) THEN  
17264           IF(EPS.GT.1.E-4) THEN 
17265             ROOT=SQRT(1.-EPS)   
17266             RLN=LOG((1.+ROOT)/(1.-ROOT))    
17267           ELSE  
17268             RLN=LOG(4./EPS-2.)  
17269           ENDIF 
17270           PHIRE=0.25*(RLN**2-PARU(1)**2)    
17271           PHIIM=0.5*PARU(1)*RLN 
17272         ELSE    
17273           PHIRE=-(ASIN(1./SQRT(EPS)))**2    
17274           PHIIM=0.  
17275         ENDIF   
17276         ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE) 
17277         ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM  
17278   690   CONTINUE    
17279         ETA2=ETARE**2+ETAIM**2  
17280         FACH=COMFAC*FACA*(AS/PARU(1)*AEM/XW)**2*1./512.*    
17281      &  (SH/SQMW)**2*ETA2*SH2/((SH-SQMH)**2+GMMH**2)*   
17282      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) 
17283         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 700 
17284         NCHN=NCHN+1 
17285         ISIG(NCHN,1)=21 
17286         ISIG(NCHN,2)=21 
17287         ISIG(NCHN,3)=1  
17288         SIGH(NCHN)=FACH 
17289   700   CONTINUE    
17290     
17291       ENDIF 
17292     
17293 C...F: 2 -> 2, box diagrams.    
17294     
17295       ELSEIF(ISUB.LE.120) THEN  
17296       IF(ISUB.EQ.111) THEN  
17297 C...f + fb -> g + H0 (q + qb -> g + H0 only).   
17298         A5STUR=0.   
17299         A5STUI=0.   
17300         DO 710 I=1,2*MSTP(1)    
17301         SQMQ=PMAS(I,1)**2   
17302         EPSS=4.*SQMQ/SH 
17303         EPSH=4.*SQMQ/SQMH   
17304         A5STUR=A5STUR+SQMQ/SQMH*(4.+4.*SH/(TH+UH)*(PYW1AU(EPSS,1)-  
17305      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,1)-   
17306      &  PYW2AU(EPSH,1)))    
17307         A5STUI=A5STUI+SQMQ/SQMH*(4.*SH/(TH+UH)*(PYW1AU(EPSS,2)- 
17308      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,2)-   
17309      &  PYW2AU(EPSH,2)))    
17310   710   CONTINUE    
17311         FACGH=COMFAC*FACA/(144.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* 
17312      &  SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)  
17313         FACGH=FACGH*WIDS(25,2)  
17314         DO 720 I=MINA,MAXA  
17315         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 720    
17316         NCHN=NCHN+1 
17317         ISIG(NCHN,1)=I  
17318         ISIG(NCHN,2)=-I 
17319         ISIG(NCHN,3)=1  
17320         SIGH(NCHN)=FACGH    
17321   720   CONTINUE    
17322     
17323       ELSEIF(ISUB.EQ.112) THEN  
17324 C...f + g -> f + H0 (q + g -> q + H0 only). 
17325         A5TSUR=0.   
17326         A5TSUI=0.   
17327         DO 730 I=1,2*MSTP(1)    
17328         SQMQ=PMAS(I,1)**2   
17329         EPST=4.*SQMQ/TH 
17330         EPSH=4.*SQMQ/SQMH   
17331         A5TSUR=A5TSUR+SQMQ/SQMH*(4.+4.*TH/(SH+UH)*(PYW1AU(EPST,1)-  
17332      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,1)-   
17333      &  PYW2AU(EPSH,1)))    
17334         A5TSUI=A5TSUI+SQMQ/SQMH*(4.*TH/(SH+UH)*(PYW1AU(EPST,2)- 
17335      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,2)-   
17336      &  PYW2AU(EPSH,2)))    
17337   730   CONTINUE    
17338         FACQH=COMFAC*FACA/(384.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* 
17339      &  SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)   
17340         FACQH=FACQH*WIDS(25,2)  
17341         DO 750 I=MINA,MAXA  
17342         IF(I.EQ.0) GOTO 750 
17343         DO 740 ISDE=1,2 
17344         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 740    
17345         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 740    
17346         NCHN=NCHN+1 
17347         ISIG(NCHN,ISDE)=I   
17348         ISIG(NCHN,3-ISDE)=21    
17349         ISIG(NCHN,3)=1  
17350         SIGH(NCHN)=FACQH    
17351   740   CONTINUE    
17352   750   CONTINUE    
17353     
17354       ELSEIF(ISUB.EQ.113) THEN  
17355 C...g + g -> g + H0.    
17356         A2STUR=0.   
17357         A2STUI=0.   
17358         A2USTR=0.   
17359         A2USTI=0.   
17360         A2TUSR=0.   
17361         A2TUSI=0.   
17362         A4STUR=0.   
17363         A4STUI=0.   
17364         DO 760 I=6,2*MSTP(1)    
17365 C'''Only t-quarks yet included  
17366         SQMQ=PMAS(I,1)**2   
17367         EPSS=4.*SQMQ/SH 
17368         EPST=4.*SQMQ/TH 
17369         EPSU=4.*SQMQ/UH 
17370         EPSH=4.*SQMQ/SQMH   
17371         IF(EPSH.LT.1.E-6) GOTO 760  
17372         BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))  
17373         BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))  
17374         BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))  
17375         BEUTS=BESTU 
17376         BETSU=BEUST 
17377         BESUT=BETUS 
17378         W3STUR=PYI3AU(BESTU,EPSH,1)-PYI3AU(BESTU,EPSS,1)-   
17379      &  PYI3AU(BESTU,EPSU,1)    
17380         W3STUI=PYI3AU(BESTU,EPSH,2)-PYI3AU(BESTU,EPSS,2)-   
17381      &  PYI3AU(BESTU,EPSU,2)    
17382         W3SUTR=PYI3AU(BESUT,EPSH,1)-PYI3AU(BESUT,EPSS,1)-   
17383      &  PYI3AU(BESUT,EPST,1)    
17384         W3SUTI=PYI3AU(BESUT,EPSH,2)-PYI3AU(BESUT,EPSS,2)-   
17385      &  PYI3AU(BESUT,EPST,2)    
17386         W3TSUR=PYI3AU(BETSU,EPSH,1)-PYI3AU(BETSU,EPST,1)-   
17387      &  PYI3AU(BETSU,EPSU,1)    
17388         W3TSUI=PYI3AU(BETSU,EPSH,2)-PYI3AU(BETSU,EPST,2)-   
17389      &  PYI3AU(BETSU,EPSU,2)    
17390         W3TUSR=PYI3AU(BETUS,EPSH,1)-PYI3AU(BETUS,EPST,1)-   
17391      &  PYI3AU(BETUS,EPSS,1)    
17392         W3TUSI=PYI3AU(BETUS,EPSH,2)-PYI3AU(BETUS,EPST,2)-   
17393      &  PYI3AU(BETUS,EPSS,2)    
17394         W3USTR=PYI3AU(BEUST,EPSH,1)-PYI3AU(BEUST,EPSU,1)-   
17395      &  PYI3AU(BEUST,EPST,1)    
17396         W3USTI=PYI3AU(BEUST,EPSH,2)-PYI3AU(BEUST,EPSU,2)-   
17397      &  PYI3AU(BEUST,EPST,2)    
17398         W3UTSR=PYI3AU(BEUTS,EPSH,1)-PYI3AU(BEUTS,EPSU,1)-   
17399      &  PYI3AU(BEUTS,EPSS,1)    
17400         W3UTSI=PYI3AU(BEUTS,EPSH,2)-PYI3AU(BEUTS,EPSU,2)-   
17401      &  PYI3AU(BEUTS,EPSS,2)    
17402         B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2.*TH*UH*(UH+2.*SH)/    
17403      &  (SH+UH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*    
17404      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3STUR)+  
17405      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,1)- 
17406      &  PYW2AU(EPSH,1))+0.5*TH*UH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+    
17407      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUR) 
17408         B2STUI=SQMQ/SQMH**2*(2.*TH*UH*(UH+2.*SH)/(SH+UH)**2*    
17409      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*   
17410      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3STUI)+  
17411      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,2)- 
17412      &  PYW2AU(EPSH,2))+0.5*TH*UH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+    
17413      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUI) 
17414         B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2.*UH*TH*(TH+2.*SH)/    
17415      &  (SH+TH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*    
17416      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3SUTR)+  
17417      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,1)- 
17418      &  PYW2AU(EPSH,1))+0.5*UH*TH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+    
17419      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTR) 
17420         B2SUTI=SQMQ/SQMH**2*(2.*UH*TH*(TH+2.*SH)/(SH+TH)**2*    
17421      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*   
17422      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3SUTI)+  
17423      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,2)- 
17424      &  PYW2AU(EPSH,2))+0.5*UH*TH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+    
17425      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTI) 
17426         B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2.*SH*UH*(UH+2.*TH)/    
17427      &  (TH+UH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*    
17428      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3TSUR)+  
17429      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,1)- 
17430      &  PYW2AU(EPSH,1))+0.5*SH*UH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+    
17431      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUR) 
17432         B2TSUI=SQMQ/SQMH**2*(2.*SH*UH*(UH+2.*TH)/(TH+UH)**2*    
17433      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*   
17434      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3TSUI)+  
17435      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,2)- 
17436      &  PYW2AU(EPSH,2))+0.5*SH*UH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+    
17437      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUI) 
17438         B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2.*UH*SH*(SH+2.*TH)/    
17439      &  (TH+SH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*    
17440      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3TUSR)+  
17441      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,1)- 
17442      &  PYW2AU(EPSH,1))+0.5*UH*SH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+    
17443      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSR) 
17444         B2TUSI=SQMQ/SQMH**2*(2.*UH*SH*(SH+2.*TH)/(TH+SH)**2*    
17445      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*   
17446      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3TUSI)+  
17447      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,2)- 
17448      &  PYW2AU(EPSH,2))+0.5*UH*SH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+    
17449      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSI) 
17450         B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2.*SH*TH*(TH+2.*UH)/    
17451      &  (UH+TH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*    
17452      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3USTR)+  
17453      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,1)- 
17454      &  PYW2AU(EPSH,1))+0.5*SH*TH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+    
17455      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTR) 
17456         B2USTI=SQMQ/SQMH**2*(2.*SH*TH*(TH+2.*UH)/(UH+TH)**2*    
17457      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*   
17458      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3USTI)+  
17459      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,2)- 
17460      &  PYW2AU(EPSH,2))+0.5*SH*TH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+    
17461      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTI) 
17462         B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2.*TH*SH*(SH+2.*UH)/    
17463      &  (UH+SH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*    
17464      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3UTSR)+  
17465      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,1)- 
17466      &  PYW2AU(EPSH,1))+0.5*TH*SH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+    
17467      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSR) 
17468         B2UTSI=SQMQ/SQMH**2*(2.*TH*SH*(SH+2.*UH)/(UH+SH)**2*    
17469      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*   
17470      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3UTSI)+  
17471      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,2)- 
17472      &  PYW2AU(EPSH,2))+0.5*TH*SH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+    
17473      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSI) 
17474         B4STUR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,1)- 
17475      &  PYW2AU(EPSH,1)+W3STUR)) 
17476         B4STUI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,2)- 
17477      &  PYW2AU(EPSH,2)+W3STUI)  
17478         B4TUSR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,1)- 
17479      &  PYW2AU(EPSH,1)+W3TUSR)) 
17480         B4TUSI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,2)- 
17481      &  PYW2AU(EPSH,2)+W3TUSI)  
17482         B4USTR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,1)- 
17483      &  PYW2AU(EPSH,1)+W3USTR)) 
17484         B4USTI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,2)- 
17485      &  PYW2AU(EPSH,2)+W3USTI)  
17486         A2STUR=A2STUR+B2STUR+B2SUTR 
17487         A2STUI=A2STUI+B2STUI+B2SUTI 
17488         A2USTR=A2USTR+B2USTR+B2UTSR 
17489         A2USTI=A2USTI+B2USTI+B2UTSI 
17490         A2TUSR=A2TUSR+B2TUSR+B2TSUR 
17491         A2TUSI=A2TUSI+B2TUSI+B2TSUI 
17492         A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR  
17493         A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI  
17494   760   CONTINUE    
17495         FACGH=COMFAC*FACA*3./(128.*PARU(1)**2)*AEM/XW*AS**3*    
17496      &  SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+    
17497      &  A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)  
17498         FACGH=FACGH*WIDS(25,2)  
17499         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 770 
17500         NCHN=NCHN+1 
17501         ISIG(NCHN,1)=21 
17502         ISIG(NCHN,2)=21 
17503         ISIG(NCHN,3)=1  
17504         SIGH(NCHN)=FACGH    
17505   770   CONTINUE    
17506     
17507       ELSEIF(ISUB.EQ.114) THEN  
17508 C...g + g -> gamma + gamma. 
17509         ASRE=0. 
17510         ASIM=0. 
17511         DO 780 I=1,2*MSTP(1)    
17512         EI=KCHG(IABS(I),1)/3.   
17513         SQMQ=PMAS(I,1)**2   
17514         EPSS=4.*SQMQ/SH 
17515         EPST=4.*SQMQ/TH 
17516         EPSU=4.*SQMQ/UH 
17517         IF(EPSS+ABS(EPST)+ABS(EPSU).LT.3.E-6) THEN  
17518           A0STUR=1.+(TH-UH)/SH*LOG(TH/UH)+0.5*(TH2+UH2)/SH2*    
17519      &    (LOG(TH/UH)**2+PARU(1)**2)    
17520           A0STUI=0. 
17521           A0TSUR=1.+(SH-UH)/TH*LOG(-SH/UH)+0.5*(SH2+UH2)/TH2*   
17522      &    LOG(-SH/UH)**2    
17523           A0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*LOG(-SH/UH))    
17524           A0UTSR=1.+(TH-SH)/UH*LOG(-TH/SH)+0.5*(TH2+SH2)/UH2*   
17525      &    LOG(-TH/SH)**2    
17526           A0UTSI=PARU(1)*((TH-SH)/UH+(TH2+SH2)/UH2*LOG(-TH/SH)) 
17527           A1STUR=-1.    
17528           A1STUI=0. 
17529           A2STUR=-1.    
17530           A2STUI=0. 
17531         ELSE    
17532           BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))    
17533           BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))    
17534           BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))    
17535           BEUTS=BESTU   
17536           BETSU=BEUST   
17537           BESUT=BETUS   
17538           A0STUR=1.+(1.+2.*TH/SH)*PYW1AU(EPST,1)+(1.+2.*UH/SH)* 
17539      &    PYW1AU(EPSU,1)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,1)+  
17540      &    PYW2AU(EPSU,1))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,1)+    
17541      &    PYI3AU(BESUT,EPST,1))-0.25*EPSU*(1.-0.5*EPSS)*    
17542      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))+  
17543      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)* 
17544      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))   
17545           A0STUI=(1.+2.*TH/SH)*PYW1AU(EPST,2)+(1.+2.*UH/SH)*    
17546      &    PYW1AU(EPSU,2)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,2)+  
17547      &    PYW2AU(EPSU,2))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,2)+    
17548      &    PYI3AU(BESUT,EPST,2))-0.25*EPSU*(1.-0.5*EPSS)*    
17549      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))+  
17550      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)* 
17551      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))   
17552           A0TSUR=1.+(1.+2.*SH/TH)*PYW1AU(EPSS,1)+(1.+2.*UH/TH)* 
17553      &    PYW1AU(EPSU,1)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,1)+  
17554      &    PYW2AU(EPSU,1))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,1)+    
17555      &    PYI3AU(BETUS,EPSS,1))-0.25*EPSU*(1.-0.5*EPST)*    
17556      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))+  
17557      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)* 
17558      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))   
17559           A0TSUI=(1.+2.*SH/TH)*PYW1AU(EPSS,2)+(1.+2.*UH/TH)*    
17560      &    PYW1AU(EPSU,2)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,2)+  
17561      &    PYW2AU(EPSU,2))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,2)+    
17562      &    PYI3AU(BETUS,EPSS,2))-0.25*EPSU*(1.-0.5*EPST)*    
17563      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))+  
17564      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)* 
17565      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))   
17566           A0UTSR=1.+(1.+2.*TH/UH)*PYW1AU(EPST,1)+(1.+2.*SH/UH)* 
17567      &    PYW1AU(EPSS,1)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,1)+  
17568      &    PYW2AU(EPSS,1))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,1)+    
17569      &    PYI3AU(BEUST,EPST,1))-0.25*EPSS*(1.-0.5*EPSU)*    
17570      &    (PYI3AU(BEUTS,EPSU,1)+PYI3AU(BEUTS,EPSS,1))+  
17571      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)* 
17572      &    (PYI3AU(BETUS,EPST,1)+PYI3AU(BETUS,EPSS,1))   
17573           A0UTSI=(1.+2.*TH/UH)*PYW1AU(EPST,2)+(1.+2.*SH/UH)*    
17574      &    PYW1AU(EPSS,2)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,2)+  
17575      &    PYW2AU(EPSS,2))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,2)+    
17576      &    PYI3AU(BEUST,EPST,2))-0.25*EPSS*(1.-0.5*EPSU)*    
17577      &    (PYI3AU(BEUTS,EPSU,2)+PYI3AU(BEUTS,EPSS,2))+  
17578      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)* 
17579      &    (PYI3AU(BETUS,EPST,2)+PYI3AU(BETUS,EPSS,2))   
17580           A1STUR=-1.-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,1)+ 
17581      &    PYW2AU(EPST,1)+PYW2AU(EPSU,1))+0.25*(EPSU+0.5*EPSS*EPST)* 
17582      &    (PYI3AU(BESUT,EPSS,1)+PYI3AU(BESUT,EPST,1))+  
17583      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,1)+  
17584      &    PYI3AU(BESTU,EPSU,1))+0.25*(EPSS+0.5*EPST*EPSU)*  
17585      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))   
17586           A1STUI=-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,2)+PYW2AU(EPST,2)+ 
17587      &    PYW2AU(EPSU,2))+0.25*(EPSU+0.5*EPSS*EPST)*    
17588      &    (PYI3AU(BESUT,EPSS,2)+PYI3AU(BESUT,EPST,2))+  
17589      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,2)+  
17590      &    PYI3AU(BESTU,EPSU,2))+0.25*(EPSS+0.5*EPST*EPSU)*  
17591      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))   
17592           A2STUR=-1.+0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,1)+ 
17593      &    PYI3AU(BESUT,EPST,1))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,1)+  
17594      &    PYI3AU(BESTU,EPSU,1))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,1)+  
17595      &    PYI3AU(BETSU,EPSU,1)) 
17596           A2STUI=0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,2)+ 
17597      &    PYI3AU(BESUT,EPST,2))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,2)+  
17598      &    PYI3AU(BESTU,EPSU,2))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,2)+  
17599      &    PYI3AU(BETSU,EPSU,2)) 
17600         ENDIF   
17601         ASRE=ASRE+EI**2*(A0STUR+A0TSUR+A0UTSR+4.*A1STUR+A2STUR) 
17602         ASIM=ASIM+EI**2*(A0STUI+A0TSUI+A0UTSI+4.*A1STUI+A2STUI) 
17603   780   CONTINUE    
17604         FACGG=COMFAC*FACA/(8.*PARU(1)**2)*AS**2*AEM**2*(ASRE**2+ASIM**2)    
17605         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 790 
17606         NCHN=NCHN+1 
17607         ISIG(NCHN,1)=21 
17608         ISIG(NCHN,2)=21 
17609         ISIG(NCHN,3)=1  
17610         SIGH(NCHN)=FACGG    
17611   790   CONTINUE    
17612     
17613       ELSEIF(ISUB.EQ.115) THEN  
17614 C...g + g -> gamma + Z0.    
17615     
17616       ELSEIF(ISUB.EQ.116) THEN  
17617 C...g + g -> Z0 + Z0.   
17618     
17619       ELSEIF(ISUB.EQ.117) THEN  
17620 C...g + g -> W+ + W-.   
17621     
17622       ENDIF 
17623     
17624 C...G: 2 -> 3, tree diagrams.   
17625     
17626       ELSEIF(ISUB.LE.140) THEN  
17627       IF(ISUB.EQ.121) THEN  
17628 C...g + g -> f + fb + H0.   
17629     
17630       ENDIF 
17631     
17632 C...H: 2 -> 1, tree diagrams, non-standard model processes. 
17633     
17634       ELSEIF(ISUB.LE.160) THEN  
17635       IF(ISUB.EQ.141) THEN  
17636 C...f + fb -> gamma*/Z0/Z'0.    
17637         MINT(61)=2  
17638         CALL PYWIDT(32,SQRT(SH),WDTP,WDTE)  
17639         FACZP=COMFAC*AEM**2*4./9.   
17640         DO 800 I=MINA,MAXA  
17641         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 800    
17642         EI=KCHG(IABS(I),1)/3.   
17643         AI=SIGN(1.,EI)  
17644         VI=AI-4.*EI*XW  
17645         API=SIGN(1.,EI) 
17646         VPI=API-4.*EI*XW    
17647         NCHN=NCHN+1 
17648         ISIG(NCHN,1)=I  
17649         ISIG(NCHN,2)=-I 
17650         ISIG(NCHN,3)=1  
17651         SIGH(NCHN)=FACZP*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*    
17652      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+EI*VPI/(8.*XW*    
17653      &  (1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GMMZP**2)*VINT(113)+  
17654      &  (VI**2+AI**2)/(16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*   
17655      &  VINT(114)+2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*SH2*   
17656      &  ((SH-SQMZ)*(SH-SQMZP)+GMMZ*GMMZP)/(((SH-SQMZ)**2+GMMZ**2)*  
17657      &  ((SH-SQMZP)**2+GMMZP**2))*VINT(115)+(VPI**2+API**2)/    
17658      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZP)**2+GMMZP**2)*VINT(116)) 
17659   800   CONTINUE    
17660     
17661       ELSEIF(ISUB.EQ.142) THEN  
17662 C...f + fb' -> H+/-.    
17663         CALL PYWIDT(37,SQRT(SH),WDTP,WDTE)  
17664         FHC=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/ 
17665      &  ((SH-SQMHC)**2+GMMHC**2)    
17666 C'''No construction yet for leptons 
17667         DO 840 I=1,MSTP(54)/2   
17668         IL=2*I-1    
17669         IU=2*I  
17670         RMQL=PMAS(IL,1)**2/SH   
17671         RMQU=PMAS(IU,1)**2/SH   
17672         FACHC=FHC*((RMQL*PARU(121)+RMQU/PARU(121))*(1.-RMQL-RMQU)-  
17673      &  4.*RMQL*RMQU)/SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))  
17674         IF(KFAC(1,IL)*KFAC(2,-IU).EQ.0) GOTO 810    
17675         KCHHC=(KCHG(IL,1)-KCHG(IU,1))/3 
17676         NCHN=NCHN+1 
17677         ISIG(NCHN,1)=IL 
17678         ISIG(NCHN,2)=-IU    
17679         ISIG(NCHN,3)=1  
17680         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
17681   810   IF(KFAC(1,-IL)*KFAC(2,IU).EQ.0) GOTO 820    
17682         KCHHC=(-KCHG(IL,1)+KCHG(IU,1))/3    
17683         NCHN=NCHN+1 
17684         ISIG(NCHN,1)=-IL    
17685         ISIG(NCHN,2)=IU 
17686         ISIG(NCHN,3)=1  
17687         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
17688   820   IF(KFAC(1,IU)*KFAC(2,-IL).EQ.0) GOTO 830    
17689         KCHHC=(KCHG(IU,1)-KCHG(IL,1))/3 
17690         NCHN=NCHN+1 
17691         ISIG(NCHN,1)=IU 
17692         ISIG(NCHN,2)=-IL    
17693         ISIG(NCHN,3)=1  
17694         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
17695   830   IF(KFAC(1,-IU)*KFAC(2,IL).EQ.0) GOTO 840    
17696         KCHHC=(-KCHG(IU,1)+KCHG(IL,1))/3    
17697         NCHN=NCHN+1 
17698         ISIG(NCHN,1)=-IU    
17699         ISIG(NCHN,2)=IL 
17700         ISIG(NCHN,3)=1  
17701         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
17702   840   CONTINUE    
17703     
17704       ELSEIF(ISUB.EQ.143) THEN  
17705 C...f + fb -> R.    
17706         CALL PYWIDT(40,SQRT(SH),WDTP,WDTE)  
17707         FACR=COMFAC*(AEM/XW)**2*1./9.*SH2/((SH-SQMR)**2+GMMR**2)    
17708         DO 860 I=MIN1,MAX1  
17709         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860   
17710         IA=IABS(I)  
17711         DO 850 J=MIN2,MAX2  
17712         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850   
17713         JA=IABS(J)  
17714         IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 850   
17715         NCHN=NCHN+1 
17716         ISIG(NCHN,1)=I  
17717         ISIG(NCHN,2)=J  
17718         ISIG(NCHN,3)=1  
17719         SIGH(NCHN)=FACR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))  
17720   850   CONTINUE    
17721   860   CONTINUE    
17722     
17723       ENDIF 
17724     
17725 C...I: 2 -> 2, tree diagrams, non-standard model processes. 
17726     
17727       ELSE  
17728       IF(ISUB.EQ.161) THEN  
17729 C...f + g -> f' + H+/- (q + g -> q' + H+/- only).   
17730         FHCQ=COMFAC*FACA*AS*AEM/XW*1./24    
17731         DO 900 I=1,MSTP(54) 
17732         IU=I+MOD(I,2)   
17733         SQMQ=PMAS(IU,1)**2  
17734         FACHCQ=FHCQ/PARU(121)*SQMQ/SQMW*(SH/(SQMQ-UH)+  
17735      &  2.*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+   
17736      &  2.*SQMQ/(SQMQ-UH)+2.*(SQMHC-UH)/(SQMQ-UH)*(SQMHC-SQMQ-SH)/SH)   
17737         IF(KFAC(1,-I)*KFAC(2,21).EQ.0) GOTO 870 
17738         KCHHC=ISIGN(1,-KCHG(I,1))   
17739         NCHN=NCHN+1 
17740         ISIG(NCHN,1)=-I 
17741         ISIG(NCHN,2)=21 
17742         ISIG(NCHN,3)=1  
17743         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
17744   870   IF(KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 880  
17745         KCHHC=ISIGN(1,KCHG(I,1))    
17746         NCHN=NCHN+1 
17747         ISIG(NCHN,1)=I  
17748         ISIG(NCHN,2)=21 
17749         ISIG(NCHN,3)=1  
17750         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
17751   880   IF(KFAC(1,21)*KFAC(2,-I).EQ.0) GOTO 890 
17752         KCHHC=ISIGN(1,-KCHG(I,1))   
17753         NCHN=NCHN+1 
17754         ISIG(NCHN,1)=21 
17755         ISIG(NCHN,2)=-I 
17756         ISIG(NCHN,3)=1  
17757         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
17758   890   IF(KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 900  
17759         KCHHC=ISIGN(1,KCHG(I,1))    
17760         NCHN=NCHN+1 
17761         ISIG(NCHN,1)=21 
17762         ISIG(NCHN,2)=I  
17763         ISIG(NCHN,3)=1  
17764         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
17765   900   CONTINUE    
17766     
17767       ENDIF 
17768       ENDIF 
17769     
17770 C...Multiply with structure functions.  
17771       IF(ISUB.LE.90.OR.ISUB.GE.96) THEN 
17772         DO 910 ICHN=1,NCHN  
17773         IF(MINT(41).EQ.2) THEN  
17774           KFL1=ISIG(ICHN,1) 
17775           IF(KFL1.EQ.21) KFL1=0 
17776           SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)    
17777         ENDIF   
17778         IF(MINT(42).EQ.2) THEN  
17779           KFL2=ISIG(ICHN,2) 
17780           IF(KFL2.EQ.21) KFL2=0 
17781           SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)    
17782         ENDIF   
17783   910   SIGS=SIGS+SIGH(ICHN)    
17784       ENDIF 
17785     
17786       RETURN    
17787       END   
17788     
17789 C*********************************************************************  
17790     
17791       SUBROUTINE PYSTFU(KF,X,Q2,XPQ,JBT)    
17792     
17793 C                       *******JBT specifies beam or target of the particle
17794 C...Gives proton and pi+ parton structure functions according to a few  
17795 C...different parametrizations. Note that what is coded is x times the  
17796 C...probability distribution, i.e. xq(x,Q2) etc.    
17797       COMMON/HIPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
17798       COMMON/HIJCRDN/YP(3,300),YT(3,300)
17799 C                       ********COMMON BLOCK FROM HIJING
17800       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
17801       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
17802       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
17803       COMMON/PYINT1/MINT(400),VINT(400) 
17804       DIMENSION XPQ(-6:6),XQ(6),TX(6),TT(6),TS(6),NEHLQ(8,2),   
17805      &CEHLQ(6,6,2,8,2),CDO(3,6,5,2),COW(3,5,4,2)    
17806       SAVE
17807 
17808 C...The following data lines are coefficients needed in the 
17809 C...Eichten, Hinchliffe, Lane, Quigg proton structure function  
17810 C...parametrizations, see below.    
17811 C...Powers of 1-x in different cases.   
17812       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/   
17813 C...Expansion coefficients for up valence quark distribution.   
17814       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/  
17815      1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,    
17816      2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,    
17817      3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,    
17818      4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,    
17819      5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,    
17820      6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,    
17821      1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,    
17822      2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,    
17823      3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,    
17824      4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,    
17825      5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,    
17826      6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/    
17827       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/  
17828      1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,    
17829      2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,    
17830      3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,    
17831      4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,    
17832      5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,    
17833      6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,    
17834      1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,    
17835      2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,    
17836      3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,    
17837      4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,    
17838      5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,    
17839      6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/    
17840 C...Expansion coefficients for down valence quark distribution. 
17841       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/  
17842      1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,    
17843      2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,    
17844      3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,    
17845      4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,    
17846      5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,    
17847      6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,    
17848      1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,    
17849      2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,    
17850      3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,    
17851      4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,    
17852      5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,    
17853      6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/    
17854       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/  
17855      1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,    
17856      2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,    
17857      3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,    
17858      4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,    
17859      5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,    
17860      6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,    
17861      1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,    
17862      2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,    
17863      3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,    
17864      4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,    
17865      5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,    
17866      6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/    
17867 C...Expansion coefficients for up and down sea quark distributions. 
17868       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/  
17869      1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,    
17870      2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,    
17871      3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,    
17872      4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,    
17873      5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,    
17874      6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,    
17875      1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,    
17876      2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,    
17877      3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,    
17878      4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,    
17879      5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,    
17880      6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/    
17881       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/  
17882      1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,    
17883      2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,    
17884      3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,    
17885      4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,    
17886      5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,    
17887      6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,    
17888      1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,    
17889      2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,    
17890      3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,    
17891      4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,    
17892      5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,    
17893      6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/    
17894 C...Expansion coefficients for gluon distribution.  
17895       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/  
17896      1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,    
17897      2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,    
17898      3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,    
17899      4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,    
17900      5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,    
17901      6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,    
17902      1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,    
17903      2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,    
17904      3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,    
17905      4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,    
17906      5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,    
17907      6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/    
17908       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/  
17909      1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,    
17910      2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,    
17911      3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,    
17912      4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,    
17913      5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,    
17914      6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,    
17915      1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,    
17916      2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,    
17917      3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,    
17918      4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,    
17919      5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,    
17920      6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/    
17921 C...Expansion coefficients for strange sea quark distribution.  
17922       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/  
17923      1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,    
17924      2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,    
17925      3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,    
17926      4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,    
17927      5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,    
17928      6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,    
17929      1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,    
17930      2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,    
17931      3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,    
17932      4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,    
17933      5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,    
17934      6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/    
17935       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/  
17936      1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,    
17937      2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,    
17938      3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,    
17939      4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,    
17940      5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,    
17941      6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,    
17942      1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,    
17943      2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,    
17944      3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,    
17945      4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,    
17946      5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,    
17947      6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/    
17948 C...Expansion coefficients for charm sea quark distribution.    
17949       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/  
17950      1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,    
17951      2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,    
17952      3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,    
17953      4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,    
17954      5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,    
17955      6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,    
17956      1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,    
17957      2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,    
17958      3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,    
17959      4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,    
17960      5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,    
17961      6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/    
17962       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/  
17963      1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,    
17964      2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,    
17965      3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,    
17966      4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,    
17967      5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,    
17968      6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,    
17969      1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,    
17970      2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,    
17971      3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,    
17972      4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,    
17973      5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,    
17974      6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/    
17975 C...Expansion coefficients for bottom sea quark distribution.   
17976       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/  
17977      1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,    
17978      2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,    
17979      3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,    
17980      4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,    
17981      5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,    
17982      6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,    
17983      1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,    
17984      2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,    
17985      3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,    
17986      4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,    
17987      5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,    
17988      6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/    
17989       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/  
17990      1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,    
17991      2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,    
17992      3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,    
17993      4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,    
17994      5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,    
17995      6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,    
17996      1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,    
17997      2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,    
17998      3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,    
17999      4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,    
18000      5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,    
18001      6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/    
18002 C...Expansion coefficients for top sea quark distribution.  
18003       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/  
18004      1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,    
18005      2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,    
18006      3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,    
18007      4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,    
18008      5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,    
18009      6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,    
18010      1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,    
18011      2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,    
18012      3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,    
18013      4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,    
18014      5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,    
18015      6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/    
18016       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/  
18017      1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,    
18018      2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,    
18019      3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,    
18020      4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,    
18021      5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,    
18022      6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,    
18023      1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,    
18024      2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,    
18025      3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,    
18026      4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,    
18027      5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,    
18028      6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/    
18029     
18030 C...The following data lines are coefficients needed in the 
18031 C...Duke, Owens proton structure function parametrizations, see below.  
18032 C...Expansion coefficients for (up+down) valence quark distribution.    
18033       DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/    
18034      1 4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18035      2 4.000E-03, 7.240E-01,-4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18036      3-7.000E-03,-6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/    
18037       DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/    
18038      1 3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18039      2 1.400E-02, 7.530E-01,-6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18040      3 0.000E+00,-7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/    
18041 C...Expansion coefficients for down valence quark distribution. 
18042       DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/    
18043      1 7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18044      2-2.370E-01, 6.270E-01,-4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00,    
18045      3 2.600E-02,-1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/    
18046       DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/    
18047      1 7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18048      2-2.320E-01, 6.270E-01,-4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00,    
18049      3 2.300E-02,-1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/    
18050 C...Expansion coefficients for (up+down+strange) sea quark distribution.    
18051       DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/    
18052      1 1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18053      2-1.132E+00,-3.720E-01, 1.590E+00, 6.310E+00,-1.050E+01, 1.470E+01,    
18054      3 2.930E-01,-2.900E-02,-1.530E-01,-2.730E-01,-3.170E+00, 9.800E+00/    
18055       DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/    
18056      1 1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18057      2-1.920E+00,-2.730E-01, 5.300E-01, 1.570E+01,-1.010E+02, 2.230E+02,    
18058      3 5.820E-01,-1.640E-01,-7.630E-01,-2.830E+00, 4.470E+01,-1.170E+02/    
18059 C...Expansion coefficients for charm sea quark distribution.    
18060       DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/    
18061      1 0.000E+00,-3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18062      2 1.350E-01,-2.220E-01, 3.260E+00,-3.030E+00, 1.740E+01,-1.790E+01,    
18063      3-7.500E-02,-5.800E-02,-9.090E-01, 1.500E+00,-1.130E+01, 1.560E+01/    
18064        DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/   
18065      1 0.000E+00,-1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
18066      2 6.700E-02,-2.330E-01, 3.660E+00,-4.740E-01, 9.500E+00,-1.660E+01,    
18067      3-3.100E-02,-2.300E-02,-4.530E-01, 3.580E-01,-5.430E+00, 1.550E+01/    
18068 C...Expansion coefficients for gluon distribution.  
18069       DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/    
18070      1 1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,    
18071      2-1.710E+00,-9.490E-01, 1.440E+00,-7.190E+00,-1.650E+01, 1.530E+01,    
18072      3 6.380E-01, 3.250E-01,-1.050E+00, 2.550E-01, 1.090E+01,-1.010E+01/    
18073       DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/    
18074      1 8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,    
18075      2-9.710E-01,-1.160E+00, 1.230E+00,-5.640E+00,-7.540E+00,-5.960E-01,    
18076      3 4.340E-01, 4.760E-01,-2.540E-01,-8.170E-01, 5.500E+00, 1.260E-01/    
18077     
18078 C...The following data lines are coefficients needed in the 
18079 C...Owens pion structure function parametrizations, see below.  
18080 C...Expansion coefficients for up and down valence quark distributions. 
18081       DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/    
18082      1  4.0000E-01,  7.0000E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
18083      2 -6.2120E-02,  6.4780E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
18084      3 -7.1090E-03,  1.3350E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/ 
18085       DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/    
18086      1  4.0000E-01,  6.2800E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
18087      2 -5.9090E-02,  6.4360E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
18088      3 -6.5240E-03,  1.4510E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/ 
18089 C...Expansion coefficients for gluon distribution.  
18090       DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/    
18091      1  8.8800E-01,  0.0000E+00,  3.1100E+00,  6.0000E+00,  0.0000E+00, 
18092      2 -1.8020E+00, -1.5760E+00, -1.3170E-01,  2.8010E+00, -1.7280E+01, 
18093      3  1.8120E+00,  1.2000E+00,  5.0680E-01, -1.2160E+01,  2.0490E+01/ 
18094       DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/    
18095      1  7.9400E-01,  0.0000E+00,  2.8900E+00,  6.0000E+00,  0.0000E+00, 
18096      2 -9.1440E-01, -1.2370E+00,  5.9660E-01, -3.6710E+00, -8.1910E+00, 
18097      3  5.9660E-01,  6.5820E-01, -2.5500E-01, -2.3040E+00,  7.7580E+00/ 
18098 C...Expansion coefficients for (up+down+strange) quark sea distribution.    
18099       DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/    
18100      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00, 
18101      2 -2.4280E-01, -2.1200E-01,  8.6730E-01,  1.2660E+00,  2.3820E+00, 
18102      3  1.3860E-01,  3.6710E-03,  4.7470E-02, -2.2150E+00,  3.4820E-01/ 
18103       DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/    
18104      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00, 
18105      2 -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00,  5.6210E-01, 
18106      3 -1.7400E-01, -9.6230E-02,  1.5750E+00,  1.3780E+00, -2.7010E-01/ 
18107 C...Expansion coefficients for charm quark sea distribution.    
18108       DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/    
18109      1  0.0000E+00, -2.2120E-02,  2.8940E+00,  0.0000E+00,  0.0000E+00, 
18110      2  7.9280E-02, -3.7850E-01,  9.4330E+00,  5.2480E+00,  8.3880E+00, 
18111      3 -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/ 
18112       DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/    
18113      1  0.0000E+00, -8.8200E-02,  1.9240E+00,  0.0000E+00,  0.0000E+00, 
18114      2  6.2290E-02, -2.8920E-01,  2.4240E-01, -4.4630E+00, -8.3670E-01, 
18115      3 -4.0990E-02, -1.0820E-01,  2.0360E+00,  5.2090E+00, -4.8400E-02/ 
18116     
18117 C...Euler's beta function, requires ordinary Gamma function 
18118       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)   
18119     
18120 C...Reset structure functions, check x and hadron flavour.  
18121       ALAM=0.   
18122       DO 100 KFL=-6,6   
18123   100 XPQ(KFL)=0.   
18124       IF(X.LT.0..OR.X.GT.1.) THEN   
18125         WRITE(MSTU(11),1000) X  
18126         RETURN  
18127       ENDIF 
18128       KFA=IABS(KF)  
18129       IF(KFA.NE.211.AND.KFA.NE.2212.AND.KFA.NE.2112) THEN   
18130         WRITE(MSTU(11),1100) KF 
18131         RETURN  
18132       ENDIF 
18133     
18134 C...Call user-supplied structure function. Select proton/neutron/pion.  
18135       IF(MSTP(51).EQ.0.OR.MSTP(52).GE.2) THEN   
18136         KFE=KFA 
18137         IF(KFA.EQ.2112) KFE=2212    
18138         CALL PYSTFE(KFE,X,Q2,XPQ)   
18139         GOTO 230    
18140       ENDIF 
18141       IF(KFA.EQ.211) GOTO 200   
18142     
18143       IF(MSTP(51).EQ.1.OR.MSTP(51).EQ.2) THEN   
18144 C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.   
18145 C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1    
18146     
18147 C...Determine set, Lamdba and x and t expansion variables.  
18148         NSET=MSTP(51)   
18149         IF(NSET.EQ.1) ALAM=0.2  
18150         IF(NSET.EQ.2) ALAM=0.29 
18151         TMIN=LOG(5./ALAM**2)    
18152         TMAX=LOG(1E8/ALAM**2)   
18153         IF(MSTP(52).EQ.0) THEN  
18154           T=TMIN    
18155         ELSE    
18156           T=LOG(Q2/ALAM**2) 
18157         ENDIF   
18158         VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))    
18159         NX=1    
18160         IF(X.LE.0.1) NX=2   
18161         IF(NX.EQ.1) VX=(2.*X-1.1)/0.9   
18162         IF(NX.EQ.2) VX=MAX(-1.,(2.*LOG(X)+11.51293)/6.90776)    
18163         CXS=1.  
18164         IF(X.LT.1E-4.AND.ABS(PARP(51)-1.).GT.0.01) CXS= 
18165      &  (1E-4/X)**(PARP(51)-1.) 
18166     
18167 C...Chebyshev polynomials for x and t expansion.    
18168         TX(1)=1.    
18169         TX(2)=VX    
18170         TX(3)=2.*VX**2-1.   
18171         TX(4)=4.*VX**3-3.*VX    
18172         TX(5)=8.*VX**4-8.*VX**2+1.  
18173         TX(6)=16.*VX**5-20.*VX**3+5.*VX 
18174         TT(1)=1.    
18175         TT(2)=VT    
18176         TT(3)=2.*VT**2-1.   
18177         TT(4)=4.*VT**3-3.*VT    
18178         TT(5)=8.*VT**4-8.*VT**2+1.  
18179         TT(6)=16.*VT**5-20.*VT**3+5.*VT 
18180     
18181 C...Calculate structure functions.  
18182         DO 120 KFL=1,6  
18183         XQSUM=0.    
18184         DO 110 IT=1,6   
18185         DO 110 IX=1,6   
18186   110   XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)  
18187   120   XQ(KFL)=XQSUM*(1.-X)**NEHLQ(KFL,NSET)*CXS   
18188     
18189 C...Put into output array.  
18190         XPQ(0)=XQ(4)    
18191         XPQ(1)=XQ(2)+XQ(3)  
18192         XPQ(2)=XQ(1)+XQ(3)  
18193         XPQ(3)=XQ(5)    
18194         XPQ(4)=XQ(6)    
18195         XPQ(-1)=XQ(3)   
18196         XPQ(-2)=XQ(3)   
18197         XPQ(-3)=XQ(5)   
18198         XPQ(-4)=XQ(6)   
18199     
18200 C...Special expansion for bottom (threshold effects).   
18201         IF(MSTP(54).GE.5) THEN  
18202           IF(NSET.EQ.1) TMIN=8.1905 
18203           IF(NSET.EQ.2) TMIN=7.4474 
18204           IF(T.LE.TMIN) GOTO 140    
18205           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))  
18206           TT(1)=1.  
18207           TT(2)=VT  
18208           TT(3)=2.*VT**2-1. 
18209           TT(4)=4.*VT**3-3.*VT  
18210           TT(5)=8.*VT**4-8.*VT**2+1.    
18211           TT(6)=16.*VT**5-20.*VT**3+5.*VT   
18212           XQSUM=0.  
18213           DO 130 IT=1,6 
18214           DO 130 IX=1,6 
18215   130     XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)  
18216           XPQ(5)=XQSUM*(1.-X)**NEHLQ(7,NSET)    
18217           XPQ(-5)=XPQ(5)    
18218   140     CONTINUE  
18219         ENDIF   
18220     
18221 C...Special expansion for top (threshold effects).  
18222         IF(MSTP(54).GE.6) THEN  
18223           IF(NSET.EQ.1) TMIN=11.5528    
18224           IF(NSET.EQ.2) TMIN=10.8097    
18225           TMIN=TMIN+2.*LOG(PMAS(6,1)/30.)   
18226           TMAX=TMAX+2.*LOG(PMAS(6,1)/30.)   
18227           IF(T.LE.TMIN) GOTO 160    
18228           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))  
18229           TT(1)=1.  
18230           TT(2)=VT  
18231           TT(3)=2.*VT**2-1. 
18232           TT(4)=4.*VT**3-3.*VT  
18233           TT(5)=8.*VT**4-8.*VT**2+1.    
18234           TT(6)=16.*VT**5-20.*VT**3+5.*VT   
18235           XQSUM=0.  
18236           DO 150 IT=1,6 
18237           DO 150 IX=1,6 
18238   150     XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)  
18239           XPQ(6)=XQSUM*(1.-X)**NEHLQ(8,NSET)    
18240           XPQ(-6)=XPQ(6)    
18241   160     CONTINUE  
18242         ENDIF   
18243     
18244       ELSEIF(MSTP(51).EQ.3.OR.MSTP(51).EQ.4) THEN   
18245 C...Proton structure functions from Duke, Owens.    
18246 C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.  
18247     
18248 C...Determine set, Lambda and s expansion parameter.    
18249         NSET=MSTP(51)-2 
18250         IF(NSET.EQ.1) ALAM=0.2  
18251         IF(NSET.EQ.2) ALAM=0.4  
18252         IF(MSTP(52).LE.0) THEN  
18253           SD=0. 
18254         ELSE    
18255           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))   
18256         ENDIF   
18257     
18258 C...Calculate structure functions.  
18259         DO 180 KFL=1,5  
18260         DO 170 IS=1,6   
18261   170   TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+    
18262      &  CDO(3,IS,KFL,NSET)*SD**2    
18263         IF(KFL.LE.2) THEN   
18264           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBET(TS(1),    
18265      &    TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))  
18266         ELSE    
18267           XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2+  
18268      &    TS(6)*X**3)   
18269         ENDIF   
18270   180   CONTINUE    
18271     
18272 C...Put into output arrays. 
18273         XPQ(0)=XQ(5)    
18274         XPQ(1)=XQ(2)+XQ(3)/6.   
18275         XPQ(2)=3.*XQ(1)-XQ(2)+XQ(3)/6.  
18276         XPQ(3)=XQ(3)/6. 
18277         XPQ(4)=XQ(4)    
18278         XPQ(-1)=XQ(3)/6.    
18279         XPQ(-2)=XQ(3)/6.    
18280         XPQ(-3)=XQ(3)/6.    
18281         XPQ(-4)=XQ(4)   
18282     
18283 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 
18284 C...These are accessed via PYSTFE since the files needed may not always 
18285 C...available.  
18286       ELSEIF(MSTP(51).GE.11.AND.MSTP(51).LE.13) THEN    
18287         CALL PYSTFE(2212,X,Q2,XPQ)  
18288     
18289 C...Unknown proton parametrization. 
18290       ELSE  
18291         WRITE(MSTU(11),1200) MSTP(51)   
18292       ENDIF 
18293       GOTO 230  
18294     
18295   200 IF((MSTP(51).GE.1.AND.MSTP(51).LE.4).OR.  
18296      &(MSTP(51).GE.11.AND.MSTP(51).LE.13)) THEN 
18297 C...Pion structure functions from Owens.    
18298 C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2. 
18299     
18300 C...Determine set, Lambda and s expansion variable. 
18301         NSET=1  
18302         IF(MSTP(51).EQ.2.OR.MSTP(51).EQ.4.OR.MSTP(51).EQ.13) NSET=2 
18303         IF(NSET.EQ.1) ALAM=0.2  
18304         IF(NSET.EQ.2) ALAM=0.4  
18305         IF(MSTP(52).LE.0) THEN  
18306           SD=0. 
18307         ELSE    
18308           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))   
18309         ENDIF   
18310     
18311 C...Calculate structure functions.  
18312         DO 220 KFL=1,4  
18313         DO 210 IS=1,5   
18314   210   TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+    
18315      &  COW(3,IS,KFL,NSET)*SD**2    
18316         IF(KFL.EQ.1) THEN   
18317           XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBET(TS(1),TS(2)+1.) 
18318         ELSE    
18319           XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2)  
18320         ENDIF   
18321   220   CONTINUE    
18322     
18323 C...Put into output arrays. 
18324         XPQ(0)=XQ(2)    
18325         XPQ(1)=XQ(3)/6. 
18326         XPQ(2)=XQ(1)+XQ(3)/6.   
18327         XPQ(3)=XQ(3)/6. 
18328         XPQ(4)=XQ(4)    
18329         XPQ(-1)=XQ(1)+XQ(3)/6.  
18330         XPQ(-2)=XQ(3)/6.    
18331         XPQ(-3)=XQ(3)/6.    
18332         XPQ(-4)=XQ(4)   
18333     
18334 C...Unknown pion parametrization.   
18335       ELSE  
18336         WRITE(MSTU(11),1200) MSTP(51)   
18337       ENDIF 
18338     
18339 C...Isospin conjugation for neutron, charge conjugation for antipart.   
18340   230 IF(KFA.EQ.2112) THEN  
18341         XPS=XPQ(1)  
18342         XPQ(1)=XPQ(2)   
18343         XPQ(2)=XPS  
18344         XPS=XPQ(-1) 
18345         XPQ(-1)=XPQ(-2) 
18346         XPQ(-2)=XPS 
18347       ENDIF 
18348       IF(KF.LT.0) THEN  
18349         DO 240 KFL=1,4  
18350         XPS=XPQ(KFL)    
18351         XPQ(KFL)=XPQ(-KFL)  
18352   240   XPQ(-KFL)=XPS   
18353       ENDIF 
18354     
18355 C...Check positivity and reset above maximum allowed flavour.   
18356       DO 250 KFL=-6,6   
18357       XPQ(KFL)=MAX(0.,XPQ(KFL)) 
18358   250 IF(IABS(KFL).GT.MSTP(54)) XPQ(KFL)=0. 
18359 
18360 C...consider nuclear effect on the structure function
18361         IF((JBT.NE.1.AND.JBT.NE.2).OR.IHPR2(6).EQ.0
18362      &                  .OR.IHNT2(16).EQ.1) GO TO 400
18363         ATNM=IHNT2(2*JBT-1)
18364         IF(ATNM.LE.1.0) GO TO 400
18365         IF(JBT.EQ.1) THEN
18366           BBR2=(YP(1,IHNT2(11))**2+YP(2,IHNT2(11))**2)/1.44/ATNM**0.66666
18367         ELSEIF(JBT.EQ.2) THEN
18368           BBR2=(YT(1,IHNT2(12))**2+YT(2,IHNT2(12))**2)/1.44/ATNM**0.66666
18369         ENDIF
18370         BBR2=MIN(1.0,BBR2)
18371         ABX=(ATNM**0.33333333-1.0)
18372         APX=HIPR1(6)*4.0/3.0*ABX*SQRT(1.0-BBR2)
18373         AAX=1.192*ALOG(ATNM)**0.1666666
18374         RRX=AAX*(X**3-1.2*X**2+0.21*X)+1.0
18375      &          -(APX-1.079*ABX*SQRT(X)/ALOG(ATNM+1.0))*EXP(-X**2.0/0.01)
18376         DO 300 KFL=-6,6
18377                 XPQ(KFL)=XPQ(KFL)*RRX
18378 300     CONTINUE
18379 C                       ********consider the nuclear effect on the structure
18380 C                               fucntion which also depends on the impact
18381 C                               parameter of the nuclear reaction
18382 
18383 400     CONTINUE    
18384 C...Formats for error printouts.    
18385  1000 FORMAT(' Error: x value outside physical range, x =',1P,E12.3)    
18386  1100 FORMAT(' Error: illegal particle code for structure function,',   
18387      &' KF =',I5)   
18388  1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',  
18389      &' MSTP(51) =',I5) 
18390     
18391       RETURN    
18392       END   
18393     
18394 C*********************************************************************  
18395     
18396       SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)   
18397     
18398 C...In case of a hadron remnant which is more complicated than just a   
18399 C...quark or a diquark, split it into two (partons or hadron + parton). 
18400       DIMENSION KFL(3)  
18401     
18402 C...Preliminaries. Parton composition.  
18403       KFA=IABS(KF)  
18404       KFS=ISIGN(1,KF)   
18405       KFL(1)=MOD(KFA/1000,10)   
18406       KFL(2)=MOD(KFA/100,10)    
18407       KFL(3)=MOD(KFA/10,10) 
18408       KFLR=KFLIN*KFS    
18409       KFLCH=0   
18410     
18411 C...Subdivide meson.    
18412       IF(KFL(1).EQ.0) THEN  
18413         KFL(2)=KFL(2)*(-1)**KFL(2)  
18414         KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))   
18415         IF(KFLR.EQ.KFL(2)) THEN 
18416           KFLSP=KFL(3)  
18417         ELSEIF(KFLR.EQ.KFL(3)) THEN 
18418           KFLSP=KFL(2)  
18419         ELSEIF(IABS(KFLR).EQ.21.AND.RLU(0).GT.0.5) THEN 
18420           KFLSP=KFL(2)  
18421           KFLCH=KFL(3)  
18422         ELSEIF(IABS(KFLR).EQ.21) THEN   
18423           KFLSP=KFL(3)  
18424           KFLCH=KFL(2)  
18425         ELSEIF(KFLR*KFL(2).GT.0) THEN   
18426           CALL LUKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)    
18427           KFLSP=KFL(3)  
18428         ELSE    
18429           CALL LUKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)    
18430           KFLSP=KFL(2)  
18431         ENDIF   
18432     
18433 C...Subdivide baryon.   
18434       ELSE  
18435         NAGR=0  
18436         DO 100 J=1,3    
18437   100   IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1  
18438         IF(NAGR.GE.1) THEN  
18439           RAGR=0.00001+(NAGR-0.00002)*RLU(0)    
18440           IAGR=0    
18441           DO 110 J=1,3  
18442           IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1.   
18443   110     IF(IAGR.EQ.0.AND.RAGR.LE.0.) IAGR=J   
18444         ELSE    
18445           IAGR=1.00001+2.99998*RLU(0)   
18446         ENDIF   
18447         ID1=1   
18448         IF(IAGR.EQ.1) ID1=2 
18449         IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3    
18450         ID2=6-IAGR-ID1  
18451         KSP=3   
18452         IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN  
18453           IF(IAGR.NE.3.AND.RLU(0).GT.0.25) KSP=1    
18454         ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN  
18455           IF(IAGR.NE.1.AND.RLU(0).GT.0.25) KSP=1    
18456         ELSEIF(MOD(KFA,10).EQ.2) THEN   
18457           IF(IAGR.EQ.1) KSP=1   
18458           IF(IAGR.NE.1.AND.RLU(0).GT.0.75) KSP=1    
18459         ENDIF   
18460         KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP    
18461         IF(KFLIN.EQ.21) THEN    
18462           KFLCH=KFL(IAGR)   
18463         ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN    
18464           CALL LUKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH) 
18465         ELSEIF(NAGR.EQ.0) THEN  
18466           CALL LUKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)   
18467           KFLSP=KFL(IAGR)   
18468         ENDIF   
18469       ENDIF 
18470     
18471 C...Add on correct sign for result. 
18472       KFLCH=KFLCH*KFS   
18473       KFLSP=KFLSP*KFS   
18474     
18475       RETURN    
18476       END   
18477     
18478 C*********************************************************************  
18479     
18480       FUNCTION PYGAMM(X)    
18481     
18482 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;    
18483 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions 
18484 C...(Dover, 1965) 6.1.36.   
18485       DIMENSION B(8)    
18486       DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857, 
18487      &-0.756704078,0.482199394,-0.193527818,0.035868343/    
18488     
18489       NX=INT(X) 
18490       DX=X-NX   
18491     
18492       PYGAMM=1. 
18493       DO 100 I=1,8  
18494   100 PYGAMM=PYGAMM+B(I)*DX**I  
18495       IF(X.LT.1.) THEN  
18496         PYGAMM=PYGAMM/X 
18497       ELSE  
18498         DO 110 IX=1,NX-1    
18499   110   PYGAMM=(X-IX)*PYGAMM    
18500       ENDIF 
18501     
18502       RETURN    
18503       END   
18504     
18505 C***********************************************************************    
18506     
18507       FUNCTION PYW1AU(EPS,IREIM)    
18508     
18509 C...Calculates real and imaginary parts of the auxiliary function W1;   
18510 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
18511 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
18512       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
18513       SAVE 
18514     
18515       ASINH(X)=LOG(X+SQRT(X**2+1.)) 
18516       ACOSH(X)=LOG(X+SQRT(X**2-1.)) 
18517     
18518       IF(EPS.LT.0.) THEN    
18519         W1RE=2.*SQRT(1.-EPS)*ASINH(SQRT(-1./EPS))   
18520         W1IM=0. 
18521       ELSEIF(EPS.LT.1.) THEN    
18522         W1RE=2.*SQRT(1.-EPS)*ACOSH(SQRT(1./EPS))    
18523         W1IM=-PARU(1)*SQRT(1.-EPS)  
18524       ELSE  
18525         W1RE=2.*SQRT(EPS-1.)*ASIN(SQRT(1./EPS)) 
18526         W1IM=0. 
18527       ENDIF 
18528     
18529 c      IF(IREIM.EQ.1) -man
18530       PYW1AU=W1RE    
18531       IF(IREIM.EQ.2) PYW1AU=W1IM    
18532     
18533       RETURN    
18534       END   
18535     
18536 C***********************************************************************    
18537     
18538       FUNCTION PYW2AU(EPS,IREIM)    
18539     
18540 C...Calculates real and imaginary parts of the auxiliary function W2;   
18541 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
18542 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
18543       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
18544       SAVE 
18545     
18546       ASINH(X)=LOG(X+SQRT(X**2+1.)) 
18547       ACOSH(X)=LOG(X+SQRT(X**2-1.)) 
18548     
18549       IF(EPS.LT.0.) THEN    
18550         W2RE=4.*(ASINH(SQRT(-1./EPS)))**2   
18551         W2IM=0. 
18552       ELSEIF(EPS.LT.1.) THEN    
18553         W2RE=4.*(ACOSH(SQRT(1./EPS)))**2-PARU(1)**2 
18554         W2IM=-4.*PARU(1)*ACOSH(SQRT(1./EPS))    
18555       ELSE  
18556         W2RE=-4.*(ASIN(SQRT(1./EPS)))**2    
18557         W2IM=0. 
18558       ENDIF 
18559     
18560 c      IF(IREIM.EQ.1) -man
18561       PYW2AU=W2RE    
18562       IF(IREIM.EQ.2) PYW2AU=W2IM    
18563     
18564       RETURN    
18565       END   
18566     
18567 C***********************************************************************    
18568     
18569       FUNCTION PYI3AU(BE,EPS,IREIM) 
18570     
18571 C...Calculates real and imaginary parts of the auxiliary function I3;   
18572 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
18573 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
18574       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
18575       SAVE 
18576     
18577       PYI3AU=0.
18578 
18579       IF(EPS.LT.1.) GA=0.5*(1.+SQRT(1.-EPS))    
18580     
18581       IF(EPS.LT.0.) THEN    
18582         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+    
18583      &  PYSPEN((BE-GA)/BE,0.,1)-PYSPEN((BE-GA)/(BE-1.),0.,1)+   
18584      &  (LOG(BE)**2-LOG(BE-1.)**2)/2.+LOG(GA)*LOG((GA+BE-1.)/BE)+   
18585      &  LOG(GA-1.)*LOG((BE-1.)/(GA+BE-1.))  
18586         F3IM=0. 
18587       ELSEIF(EPS.LT.1.) THEN    
18588         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+    
18589      &  PYSPEN(GA/(GA-BE),0.,1)-PYSPEN((GA-1.)/(GA-BE),0.,1)+   
18590      &  LOG(GA/(1.-GA))*LOG((GA+BE-1.)/(BE-GA)) 
18591         F3IM=-PARU(1)*LOG((GA+BE-1.)/(BE-GA))   
18592       ELSE  
18593         RSQ=EPS/(EPS-1.+(2.*BE-1.)**2)  
18594         RCTHE=RSQ*(1.-2.*BE/EPS)    
18595         RSTHE=SQRT(RSQ-RCTHE**2)    
18596         RCPHI=RSQ*(1.+2.*(BE-1.)/EPS)   
18597         RSPHI=SQRT(RSQ-RCPHI**2)    
18598         R=SQRT(RSQ) 
18599         THE=ACOS(RCTHE/R)   
18600         PHI=ACOS(RCPHI/R)   
18601         F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-  
18602      &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+   
18603      &  (PHI-THE)*(PHI+THE-PARU(1)) 
18604         F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-  
18605      &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)    
18606       ENDIF 
18607     
18608       IF(IREIM.EQ.1) PYI3AU=2./(2.*BE-1.)*F3RE  
18609       IF(IREIM.EQ.2) PYI3AU=2./(2.*BE-1.)*F3IM  
18610     
18611       RETURN    
18612       END   
18613     
18614 C***********************************************************************    
18615     
18616       FUNCTION PYSPEN(XREIN,XIMIN,IREIM)    
18617     
18618 C...Calculates real and imaginary part of Spence function; see  
18619 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.    
18620       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
18621       DIMENSION B(0:14) 
18622       SAVE
18623 
18624       DATA B/   
18625      & 1.000000E+00,        -5.000000E-01,         1.666667E-01,    
18626      & 0.000000E+00,        -3.333333E-02,         0.000000E+00,    
18627      & 2.380952E-02,         0.000000E+00,        -3.333333E-02,    
18628      & 0.000000E+00,         7.575757E-02,         0.000000E+00,    
18629      &-2.531135E-01,         0.000000E+00,         1.166667E+00/    
18630     
18631       XRE=XREIN 
18632       XIM=XIMIN 
18633       PYSPEN=0.
18634       IF(ABS(1.-XRE).LT.1.E-6.AND.ABS(XIM).LT.1.E-6) THEN   
18635         IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6. 
18636         IF(IREIM.EQ.2) PYSPEN=0.    
18637         RETURN  
18638       ENDIF 
18639     
18640       XMOD=SQRT(XRE**2+XIM**2)  
18641       IF(XMOD.LT.1.E-6) THEN    
18642         IF(IREIM.EQ.1) PYSPEN=0.    
18643         IF(IREIM.EQ.2) PYSPEN=0.    
18644         RETURN  
18645       ENDIF 
18646     
18647       XARG=SIGN(ACOS(XRE/XMOD),XIM) 
18648       SP0RE=0.  
18649       SP0IM=0.  
18650       SGN=1.    
18651       IF(XMOD.GT.1.) THEN   
18652         ALGXRE=LOG(XMOD)    
18653         ALGXIM=XARG-SIGN(PARU(1),XARG)  
18654         SP0RE=-PARU(1)**2/6.-(ALGXRE**2-ALGXIM**2)/2.   
18655         SP0IM=-ALGXRE*ALGXIM    
18656         SGN=-1. 
18657         XMOD=1./XMOD    
18658         XARG=-XARG  
18659         XRE=XMOD*COS(XARG)  
18660         XIM=XMOD*SIN(XARG)  
18661       ENDIF 
18662       IF(XRE.GT.0.5) THEN   
18663         ALGXRE=LOG(XMOD)    
18664         ALGXIM=XARG 
18665         XRE=1.-XRE  
18666         XIM=-XIM    
18667         XMOD=SQRT(XRE**2+XIM**2)    
18668         XARG=SIGN(ACOS(XRE/XMOD),XIM)   
18669         ALGYRE=LOG(XMOD)    
18670         ALGYIM=XARG 
18671         SP0RE=SP0RE+SGN*(PARU(1)**2/6.-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))   
18672         SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)   
18673         SGN=-SGN    
18674       ENDIF 
18675     
18676       XRE=1.-XRE    
18677       XIM=-XIM  
18678       XMOD=SQRT(XRE**2+XIM**2)  
18679       XARG=SIGN(ACOS(XRE/XMOD),XIM) 
18680       ZRE=-LOG(XMOD)    
18681       ZIM=-XARG 
18682     
18683       SPRE=0.   
18684       SPIM=0.   
18685       SAVERE=1. 
18686       SAVEIM=0. 
18687       DO 100 I=0,14 
18688       TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/FLOAT(I+1) 
18689       TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/FLOAT(I+1) 
18690       SAVERE=TERMRE 
18691       SAVEIM=TERMIM 
18692       SPRE=SPRE+B(I)*TERMRE 
18693   100 SPIM=SPIM+B(I)*TERMIM 
18694     
18695       IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE  
18696       IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM  
18697     
18698       RETURN    
18699       END   
18700     
18701 *********************************************************************** 
18702     
18703       SUBROUTINE PYTEST(MTEST)  
18704     
18705 C...Purpose: to provide a simple program (disguised as a subroutine) to 
18706 C...run at installation as a check that the program works as intended.  
18707       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
18708       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
18709       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
18710       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
18711       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
18712       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
18713       SAVE
18714 
18715 C...Common initial values. Loop over initiating conditions. 
18716       MSTP(122)=1   
18717       IF(MTEST.LE.0) MSTP(122)=0    
18718       MDCY(LUCOMP(111),1)=0 
18719       NERR=0    
18720       DO 130 IPROC=1,7  
18721     
18722 C...Reset process type, kinematics cuts, and the flags used.    
18723       MSEL=0    
18724       DO 100 ISUB=1,200 
18725   100 MSUB(ISUB)=0  
18726       CKIN(1)=2.    
18727       CKIN(3)=0.    
18728       MSTP(2)=1 
18729       MSTP(33)=0    
18730       MSTP(81)=1    
18731       MSTP(82)=1    
18732       MSTP(111)=1   
18733       MSTP(131)=0   
18734       MSTP(133)=0   
18735       PARP(131)=0.01    
18736     
18737 C...Prompt photon production at fixed target.   
18738       IF(IPROC.EQ.1) THEN   
18739         PZSUM=300.  
18740         PESUM=SQRT(PZSUM**2+ULMASS(211)**2)+ULMASS(2212)    
18741         PQSUM=2.    
18742         MSEL=10 
18743         CKIN(3)=5.  
18744         CALL PYINIT('FIXT','pi+','p',PZSUM) 
18745     
18746 C...QCD processes at ISR energies.  
18747       ELSEIF(IPROC.EQ.2) THEN   
18748         PESUM=63.   
18749         PZSUM=0.    
18750         PQSUM=2.    
18751         MSEL=1  
18752         CKIN(3)=5.  
18753         CALL PYINIT('CMS','p','p',PESUM)    
18754     
18755 C...W production + multiple interactions at CERN Collider.  
18756       ELSEIF(IPROC.EQ.3) THEN   
18757         PESUM=630.  
18758         PZSUM=0.    
18759         PQSUM=0.    
18760         MSEL=12 
18761         CKIN(1)=20. 
18762         MSTP(82)=4  
18763         MSTP(2)=2   
18764         MSTP(33)=3  
18765         CALL PYINIT('CMS','p','pbar',PESUM) 
18766     
18767 C...W/Z gauge boson pairs + overlayed events at the Tevatron.   
18768       ELSEIF(IPROC.EQ.4) THEN   
18769         PESUM=1800. 
18770         PZSUM=0.    
18771         PQSUM=0.    
18772         MSUB(22)=1  
18773         MSUB(23)=1  
18774         MSUB(25)=1  
18775         CKIN(1)=200.    
18776         MSTP(111)=0 
18777         MSTP(131)=1 
18778         MSTP(133)=2 
18779         PARP(131)=0.04  
18780         CALL PYINIT('CMS','p','pbar',PESUM) 
18781     
18782 C...Higgs production at LHC.    
18783       ELSEIF(IPROC.EQ.5) THEN   
18784         PESUM=17000.    
18785         PZSUM=0.    
18786         PQSUM=0.    
18787         MSEL=16 
18788         PMAS(25,1)=300. 
18789         CKIN(1)=200.    
18790         MSTP(81)=0  
18791         MSTP(111)=0 
18792         CALL PYINIT('CMS','p','pbar',PESUM) 
18793     
18794 C...Z' production at SSC.   
18795       ELSEIF(IPROC.EQ.6) THEN   
18796         PESUM=40000.    
18797         PZSUM=0.    
18798         PQSUM=0.    
18799         MSEL=21 
18800         PMAS(32,1)=600. 
18801         CKIN(1)=400.    
18802         MSTP(81)=0  
18803         MSTP(111)=0 
18804         CALL PYINIT('CMS','p','pbar',PESUM) 
18805     
18806 C...W pair production at 1 TeV e+e- collider.   
18807       ELSEIF(IPROC.EQ.7) THEN   
18808         PESUM=1000. 
18809         PZSUM=0.    
18810         PQSUM=0.    
18811         MSUB(25)=1  
18812         CALL PYINIT('CMS','e+','e-',PESUM)  
18813       ENDIF 
18814     
18815 C...Generate 20 events of each required type.   
18816       DO 120 IEV=1,20   
18817       CALL PYTHIA   
18818       PESUMM=PESUM  
18819       IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM  
18820     
18821 C...Check conservation of energy/momentum/flavour.  
18822       MERR=0    
18823       DEVE=ABS(PLU(0,4)-PESUMM)+ABS(PLU(0,3)-PZSUM) 
18824       DEVT=ABS(PLU(0,1))+ABS(PLU(0,2))  
18825       DEVQ=ABS(PLU(0,6)-PQSUM)  
18826       IF(DEVE.GT.1E-3*PESUM.OR.DEVT.GT.MAX(0.01,1E-5*PESUM).OR. 
18827      &DEVQ.GT.0.1) MERR=1   
18828       IF(MERR.NE.0) WRITE(MSTU(11),1000) IPROC,IEV  
18829     
18830 C...Check that all KF codes are known ones, and that partons/particles  
18831 C...satisfy energy-momentum-mass relation.  
18832       DO 110 I=1,N  
18833       IF(K(I,1).GT.20) GOTO 110 
18834       IF(LUCOMP(K(I,2)).EQ.0) THEN  
18835         WRITE(MSTU(11),1100) I  
18836         MERR=MERR+1 
18837       ENDIF 
18838       PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2* 
18839      &SIGN(1.,P(I,5))   
18840       IF(ABS(PD).GT.MAX(0.1,0.002*P(I,4)**2,0.002*P(I,5)**2).OR.    
18841      &(P(I,5).GE.0..AND.P(I,4).LT.0.)) THEN 
18842         WRITE(MSTU(11),1200) I  
18843         MERR=MERR+1 
18844       ENDIF 
18845   110 CONTINUE  
18846     
18847 C...Listing of erronoeus events, and first event of each type.  
18848       IF(MERR.GE.1) NERR=NERR+1 
18849       IF(NERR.GE.10) THEN   
18850         WRITE(MSTU(11),1300)    
18851         CALL LULIST(1)  
18852         STOP    
18853       ENDIF 
18854       IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN   
18855         IF(MERR.GE.1) WRITE(MSTU(11),1400)  
18856         CALL LULIST(1)  
18857       ENDIF 
18858   120 CONTINUE  
18859     
18860 C...List statistics for each process type.  
18861       IF(MTEST.GE.1) CALL PYSTAT(1) 
18862   130 CONTINUE  
18863     
18864 C...Summarize result of run.    
18865       IF(NERR.EQ.0) WRITE(MSTU(11),1500)    
18866       IF(NERR.GT.0) WRITE(MSTU(11),1600) NERR   
18867       RETURN    
18868     
18869 C...Formats for information.    
18870  1000 FORMAT(/5X,'Energy/momentum/flavour nonconservation for process', 
18871      &I2,', event',I4)  
18872  1100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')   
18873  1200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',  
18874      &'kinematics') 
18875  1300 FORMAT(/5X,'This is the tenth error experienced! Something is ',  
18876      &'wrong.'/5X,'Execution will be stopped after listing of event.')  
18877  1400 FORMAT(5X,'Faulty event follows:')    
18878  1500 FORMAT(//5X,'End result of run: no errors detected.') 
18879  1600 FORMAT(//5X,'End result of run:',I2,' errors detected.'/  
18880      &5X,'This should not have happened!')  
18881       END   
18882     
18883 C*********************************************************************  
18884     
18885       BLOCK DATA PYDATA 
18886     
18887 C...Give sensible default values to all status codes and parameters.    
18888       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
18889       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
18890       COMMON/PYINT1/MINT(400),VINT(400) 
18891       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
18892       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
18893       COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
18894       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
18895       COMMON/PYINT6/PROC(0:200) 
18896       CHARACTER PROC*28 
18897       SAVE    
18898 
18899 C...Default values for allowed processes and kinematics constraints.    
18900       DATA MSEL/1/  
18901       DATA MSUB/200*0/  
18902       DATA ((KFIN(I,J),J=-40,40),I=1,2)/40*1,0,80*1,0,40*1/ 
18903       DATA CKIN/    
18904      &   2.0, -1.0,  0.0, -1.0,  1.0,  1.0, -10.,  10., -10.,  10., 
18905      1  -10.,  10., -10.,  10., -10.,  10., -1.0,  1.0, -1.0,  1.0, 
18906      2   0.0,  1.0,  0.0,  1.0, -1.0,  1.0, -1.0,  1.0,   0.,   0., 
18907      3   2.0, -1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18908      4   160*0./    
18909     
18910 C...Default values for main switches and parameters. Reset information. 
18911       DATA (MSTP(I),I=1,100)/   
18912      &     3,    1,    2,    0,    0,    0,    0,    0,    0,    0, 
18913      1     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18914      2     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18915      3     1,    2,    0,    0,    0,    2,    0,    0,    0,    0, 
18916      4     1,    0,    3,    7,    1,    0,    0,    0,    0,    0, 
18917      5     1,    1,   20,    6,    0,    0,    0,    0,    0,    0, 
18918      6     1,    2,    2,    2,    1,    0,    0,    0,    0,    0, 
18919      7     1,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18920      8     1,    1,  100,    0,    0,    0,    0,    0,    0,    0, 
18921      9     1,    4,    0,    0,    0,    0,    0,    0,    0,    0/ 
18922       DATA (MSTP(I),I=101,200)/ 
18923      &     1,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18924      1     1,    1,    1,    0,    0,    0,    0,    0,    0,    0, 
18925      2     0,    1,    2,    1,    1,   20,    0,    0,    0,    0, 
18926      3     0,    4,    0,    1,    0,    0,    0,    0,    0,    0, 
18927      4     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18928      5     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18929      6     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18930      7     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
18931      8     5,    3, 1989,   11,   24,    0,    0,    0,    0,    0, 
18932      9     0,    0,    0,    0,    0,    0,    0,    0,    0,    0/ 
18933       DATA (PARP(I),I=1,100)/   
18934      &  0.25,  10.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18935      1    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18936      2    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18937      3   1.5,  2.0, 0.075,  0.,  0.2,   0.,   0.,   0.,   0.,   0., 
18938      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18939      5   1.0, 2.26, 1.E4, 1.E-4,  0.,   0.,   0.,   0.,   0.,   0., 
18940      6  0.25,  1.0, 0.25,  1.0,  2.0, 1.E-3, 4.0,   0.,   0.,   0., 
18941      7   4.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18942      8   1.6, 1.85,  0.5,  0.2, 0.33, 0.66,  0.7,  0.5,   0.,   0., 
18943      9  0.44, 0.44,  2.0,  1.0,   0.,  3.0,  1.0, 0.75,   0.,   0./ 
18944       DATA (PARP(I),I=101,200)/ 
18945      & -0.02,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18946      1   2.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18947      2   0.4,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18948      3  0.01,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18949      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18950      5    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18951      6    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18952      7    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18953      8    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
18954      9    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0./ 
18955       DATA MSTI/200*0/  
18956       DATA PARI/200*0./ 
18957       DATA MINT/400*0/  
18958       DATA VINT/400*0./ 
18959     
18960 C...Constants for the generation of the various processes.  
18961       DATA (ISET(I),I=1,100)/   
18962      &    1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,   -2,  
18963      1    2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,  
18964      2   -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,  
18965      3    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
18966      4   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
18967      5   -1,   -1,    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
18968      6   -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,   -1,   -1,  
18969      7    4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,   -2,  
18970      8    2,    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18971      9    0,    0,    0,   -1,    0,    5,   -2,   -2,   -2,   -2/  
18972       DATA (ISET(I),I=101,200)/ 
18973      &   -1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18974      1    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,   -2,  
18975      2   -1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18976      3   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18977      4    1,    1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18978      5   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18979      6    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18980      7   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18981      8   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
18982      9   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2/  
18983       DATA ((KFPR(I,J),J=1,2),I=1,50)/  
18984      &   23,    0,   24,    0,   25,    0,   24,    0,   25,    0,  
18985      &   24,    0,   23,    0,   25,    0,    0,    0,    0,    0,  
18986      1    0,    0,    0,    0,   21,   21,   21,   22,   21,   23,  
18987      1   21,   24,   21,   25,   22,   22,   22,   23,   22,   24,  
18988      2   22,   25,   23,   23,   23,   24,   23,   25,   24,   24,  
18989      2   24,   25,   25,   25,    0,   21,    0,   22,    0,   23,  
18990      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
18991      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
18992      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
18993      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23/  
18994       DATA ((KFPR(I,J),J=1,2),I=51,100)/    
18995      5    0,   24,    0,   25,    0,    0,    0,    0,    0,    0,  
18996      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
18997      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
18998      6    0,    0,    0,    0,   21,   21,   24,   24,   22,   24,  
18999      7   23,   23,   24,   24,   23,   24,   23,   25,   22,   22,  
19000      7   23,   23,   24,   24,   24,   25,   25,   25,    0,    0,  
19001      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19002      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19003      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19004      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
19005       DATA ((KFPR(I,J),J=1,2),I=101,150)/   
19006      &   23,    0,   25,    0,    0,    0,    0,    0,    0,    0,  
19007      &    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19008      1   21,   25,    0,   25,   21,   25,   22,   22,   22,   23,  
19009      1   23,   23,   24,   24,    0,    0,    0,    0,    0,    0,  
19010      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19011      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19012      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19013      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19014      4   32,    0,   37,    0,   40,    0,    0,    0,    0,    0,  
19015      4    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
19016       DATA ((KFPR(I,J),J=1,2),I=151,200)/   
19017      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19018      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19019      6    0,   37,    0,    0,    0,    0,    0,    0,    0,    0,  
19020      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19021      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19022      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19023      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19024      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19025      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
19026      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
19027       DATA COEF/4000*0./    
19028       DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/    
19029      1 4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2, 
19030      2 3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2, 
19031      3 3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1, 
19032      4 3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0, 
19033      5 4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3, 
19034      6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2, 
19035      7 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
19036      8 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
19037      9 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
19038      & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ 
19039     
19040 C...Character constants: name of processes. 
19041       DATA PROC(0)/                    'All included subprocesses   '/  
19042       DATA (PROC(I),I=1,20)/    
19043      1'f + fb -> gamma*/Z0         ',  'f + fb'' -> W+/-             ', 
19044      2'f + fb -> H0                ',  'gamma + W+/- -> W+/-        ',  
19045      3'Z0 + Z0 -> H0               ',  'Z0 + W+/- -> W+/-           ',  
19046      4'                            ',  'W+ + W- -> H0               ',  
19047      5'                            ',  '                            ',  
19048      6'f + f'' -> f + f''            ','f + fb -> f'' + fb''          ',    
19049      7'f + fb -> g + g             ',  'f + fb -> g + gamma         ',  
19050      8'f + fb -> g + Z0            ',  'f + fb'' -> g + W+/-         ', 
19051      9'f + fb -> g + H0            ',  'f + fb -> gamma + gamma     ',  
19052      &'f + fb -> gamma + Z0        ',  'f + fb'' -> gamma + W+/-     '/ 
19053       DATA (PROC(I),I=21,40)/   
19054      1'f + fb -> gamma + H0        ',  'f + fb -> Z0 + Z0           ',  
19055      2'f + fb'' -> Z0 + W+/-        ', 'f + fb -> Z0 + H0           ',  
19056      3'f + fb -> W+ + W-           ',  'f + fb'' -> W+/- + H0        ', 
19057      4'f + fb -> H0 + H0           ',  'f + g -> f + g              ',  
19058      5'f + g -> f + gamma          ',  'f + g -> f + Z0             ',  
19059      6'f + g -> f'' + W+/-          ', 'f + g -> f + H0             ',  
19060      7'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',  
19061      8'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ', 
19062      9'f + gamma -> f + H0         ',  'f + Z0 -> f + g             ',  
19063      &'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/  
19064       DATA (PROC(I),I=41,60)/   
19065      1'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + H0            ',  
19066      2'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ', 
19067      3'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ', 
19068      4'f + W+/- -> f'' + H0         ', 'f + H0 -> f + g             ',  
19069      5'f + H0 -> f + gamma         ',  'f + H0 -> f + Z0            ',  
19070      6'f + H0 -> f'' + W+/-         ', 'f + H0 -> f + H0            ',  
19071      7'g + g -> f + fb             ',  'g + gamma -> f + fb         ',  
19072      8'g + Z0 -> f + fb            ',  'g + W+/- -> f + fb''         ', 
19073      9'g + H0 -> f + fb            ',  'gamma + gamma -> f + fb     ',  
19074      &'gamma + Z0 -> f + fb        ',  'gamma + W+/- -> f + fb''     '/ 
19075       DATA (PROC(I),I=61,80)/   
19076      1'gamma + H0 -> f + fb        ',  'Z0 + Z0 -> f + fb           ',  
19077      2'Z0 + W+/- -> f + fb''        ', 'Z0 + H0 -> f + fb           ',  
19078      3'W+ + W- -> f + fb           ',  'W+/- + H0 -> f + fb''        ', 
19079      4'H0 + H0 -> f + fb           ',  'g + g -> g + g              ',  
19080      5'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> gamma + W+/-',  
19081      6'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',  
19082      7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + H0          ',  
19083      8'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',  
19084      9'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + H0 -> W+/- + H0      ',  
19085      &'H0 + H0 -> H0 + H0          ',  '                            '/  
19086       DATA (PROC(I),I=81,100)/  
19087      1'q + qb -> Q + QB, massive   ',  'g + g -> Q + QB, massive    ',  
19088      2'                            ',  '                            ',  
19089      3'                            ',  '                            ',  
19090      4'                            ',  '                            ',  
19091      5'                            ',  '                            ',  
19092      6'Elastic scattering          ',  'Single diffractive          ',  
19093      7'Double diffractive          ',  'Central diffractive         ',  
19094      8'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',  
19095      9'                            ',  '                            ',  
19096      &'                            ',  '                            '/  
19097       DATA (PROC(I),I=101,120)/ 
19098      1'g + g -> gamma*/Z0          ',  'g + g -> H0                 ',  
19099      2'                            ',  '                            ',  
19100      3'                            ',  '                            ',  
19101      4'                            ',  '                            ',  
19102      5'                            ',  '                            ',  
19103      6'f + fb -> g + H0            ',  'q + g -> q + H0             ',  
19104      7'g + g -> g + H0             ',  'g + g -> gamma + gamma      ',  
19105      8'g + g -> gamma + Z0         ',  'g + g -> Z0 + Z0            ',  
19106      9'g + g -> W+ + W-            ',  '                            ',  
19107      &'                            ',  '                            '/  
19108       DATA (PROC(I),I=121,140)/ 
19109      1'g + g -> f + fb + H0        ',  '                            ',  
19110      2'                            ',  '                            ',  
19111      3'                            ',  '                            ',  
19112      4'                            ',  '                            ',  
19113      5'                            ',  '                            ',  
19114      6'                            ',  '                            ',  
19115      7'                            ',  '                            ',  
19116      8'                            ',  '                            ',  
19117      9'                            ',  '                            ',  
19118      &'                            ',  '                            '/  
19119       DATA (PROC(I),I=141,160)/ 
19120      1'f + fb -> gamma*/Z0/Z''0     ', 'f + fb'' -> H+/-             ', 
19121      2'f + fb -> R                 ',  '                            ',  
19122      3'                            ',  '                            ',  
19123      4'                            ',  '                            ',  
19124      5'                            ',  '                            ',  
19125      6'                            ',  '                            ',  
19126      7'                            ',  '                            ',  
19127      8'                            ',  '                            ',  
19128      9'                            ',  '                            ',  
19129      &'                            ',  '                            '/  
19130       DATA (PROC(I),I=161,180)/ 
19131      1'f + g -> f'' + H+/-          ', '                            ',  
19132      2'                            ',  '                            ',  
19133      3'                            ',  '                            ',  
19134      4'                            ',  '                            ',  
19135      5'                            ',  '                            ',  
19136      6'                            ',  '                            ',  
19137      7'                            ',  '                            ',  
19138      8'                            ',  '                            ',  
19139      9'                            ',  '                            ',  
19140      &'                            ',  '                            '/  
19141       DATA (PROC(I),I=181,200)/     20*'                            '/  
19142     
19143       END   
19144     
19145 C*********************************************************************  
19146     
19147       SUBROUTINE PYKCUT(MCUT)   
19148     
19149 C...Dummy routine, which the user can replace in order to make cuts on  
19150 C...the kinematics on the parton level before the matrix elements are   
19151 C...evaluated and the event is generated. The cross-section estimates   
19152 C...will automatically take these cuts into account, so the given   
19153 C...values are for the allowed phase space region only. MCUT=0 means    
19154 C...that the event has passed the cuts, MCUT=1 that it has failed.  
19155       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
19156       SAVE 
19157     
19158       MCUT=0    
19159     
19160       RETURN    
19161       END   
19162     
19163 C*********************************************************************  
19164     
19165       SUBROUTINE PYSTFE(KF,X,Q2,XPQ)    
19166     
19167 C...This is a dummy routine, where the user can introduce an interface  
19168 C...to his own external structure function parametrization. 
19169 C...Arguments in:   
19170 C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge  
19171 C...    conjugation for pbar, nbar or pi- is performed by PYSTFU.   
19172 C...X : x value.    
19173 C...Q2 : Q^2 value. 
19174 C...Arguments out:  
19175 C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,   
19176 C...    except that gluon is placed in 0. Thus XPQ(0) = xg, 
19177 C...    XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar, 
19178 C...    XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar, 
19179 C...    XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar. 
19180 C...    
19181 C...One such interface, to the Diemos, Ferroni, Longo, Martinelli   
19182 C...proton structure functions, already comes with the package. What    
19183 C...the user needs here is external files with the three routines   
19184 C...FXG160, FXG260 and FXG360 of the authors above, plus the    
19185 C...interpolation routine FINT, which is part of the CERN library   
19186 C...KERNLIB package. To avoid problems with unresolved external 
19187 C...references, the external calls are commented in the current 
19188 C...version. To enable this option, remove the C* at the beginning  
19189 C...of the relevant lines.  
19190 C...    
19191 C...Alternatively, the routine can be used as an interface to the   
19192 C...structure function evolution program of Tung. This can be achieved  
19193 C...by removing C* at the beginning of some of the lines below. 
19194       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
19195       SAVE /LUDAT1/ 
19196       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
19197       SAVE /LUDAT2/ 
19198       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
19199       SAVE /PYPARS/ 
19200       DIMENSION XPQ(-6:6),XFDFLM(9) 
19201       CHARACTER CHDFLM(9)*5,HEADER*40   
19202       DATA CHDFLM/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',  
19203      &'CBAR ','BBAR ','TBAR '/  
19204       DATA HEADER/'Tung evolution package has been invoked'/    
19205       DATA INIT/0/  
19206       KF=KF
19207       HEADER=HEADER
19208       CHDFLM(1)=CHDFLM(1)
19209 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 
19210 C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95. 
19211       IF(MSTP(51).GE.11.AND.MSTP(51).LE.13.AND.MSTP(52).LE.1) THEN  
19212         XDFLM=MAX(0.51E-4,X)    
19213         Q2DFLM=MAX(10.,MIN(1E8,Q2)) 
19214         IF(MSTP(52).EQ.0) Q2DFLM=10.    
19215         DO 100 J=1,9    
19216         IF(MSTP(52).EQ.1.AND.J.EQ.9) THEN   
19217           Q2DFLM=Q2DFLM*(40./PMAS(6,1))**2  
19218           Q2DFLM=MAX(10.,MIN(1E8,Q2))   
19219         ENDIF   
19220         XFDFLM(J)=0.    
19221 C...Remove C* on following three lines to enable the DFLM options.  
19222 C*      IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
19223 C*      IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
19224 C*      IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
19225   100   CONTINUE    
19226         IF(X.LT.0.51E-4.AND.ABS(PARP(51)-1.).GT.0.01) THEN  
19227           CXS=(0.51E-4/X)**(PARP(51)-1.)    
19228           DO 110 J=1,7  
19229   110     XFDFLM(J)=XFDFLM(J)*CXS   
19230         ENDIF   
19231         XPQ(0)=XFDFLM(3)    
19232         XPQ(1)=XFDFLM(2)+XFDFLM(5)  
19233         XPQ(2)=XFDFLM(1)+XFDFLM(5)  
19234         XPQ(3)=XFDFLM(6)    
19235         XPQ(4)=XFDFLM(7)    
19236         XPQ(5)=XFDFLM(8)    
19237         XPQ(6)=XFDFLM(9)    
19238         XPQ(-1)=XFDFLM(5)   
19239         XPQ(-2)=XFDFLM(5)   
19240         XPQ(-3)=XFDFLM(6)   
19241         XPQ(-4)=XFDFLM(7)   
19242         XPQ(-5)=XFDFLM(8)   
19243         XPQ(-6)=XFDFLM(9)   
19244     
19245 C...Proton structure function evolution from Wu-Ki Tung: parton 
19246 C...distribution functions incorporating heavy quark mass effects.  
19247 C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.  
19248       ELSE  
19249         IF(INIT.EQ.0) THEN  
19250           I1=0  
19251           IF(MSTP(52).EQ.4) I1=1    
19252           IHDRN=1   
19253           NU=MSTP(53)   
19254           I2=MSTP(51)   
19255           IF(MSTP(51).GE.11) I2=MSTP(51)-3  
19256           I3=0  
19257           IF(MSTP(52).EQ.3) I3=1    
19258     
19259 C...Convert to Lambda in CWZ scheme (approximately linear relation).    
19260           ALAM=0.75*PARP(1) 
19261           TPMS=PMAS(6,1)    
19262           QINI=PARP(52) 
19263           QMAX=PARP(53) 
19264           XMIN=PARP(54) 
19265     
19266 C...Initialize evolution (perform calculation or read results from  
19267 C...file).  
19268 C...Remove C* on following two lines to enable Tung initialization. 
19269 C*        CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,  
19270 C*   &    I2,I3,IRET,IRR)   
19271           INIT=1    
19272         ENDIF   
19273     
19274 C...Put into output array.  
19275         Q=SQRT(Q2)  
19276         DO 200 I=-6,6   
19277         FIXQ=0. 
19278 C...Remove C* on following line to enable structure function call.  
19279 C*      FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR)) 
19280   200   XPQ(I)=X*FIXQ   
19281     
19282 C...Change order of u and d quarks from Tung to PYTHIA convention.  
19283         XPS=XPQ(1)  
19284         XPQ(1)=XPQ(2)   
19285         XPQ(2)=XPS  
19286         XPS=XPQ(-1) 
19287         XPQ(-1)=XPQ(-2) 
19288         XPQ(-2)=XPS 
19289       ENDIF 
19290     
19291       RETURN    
19292       END