Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2021-02-14 13:29:32

0001 c.................... hipyset1.35.f

0002 C

0003 C

0004 C

0005 C     Modified for HIJING program

0006 c

0007 c    modification July 22, 1997  In pyremnn put an upper limit

0008 c     on the total pt kick the parton can accumulate via multiple

0009 C     scattering. Set the upper limit to be the sqrt(s)/2,

0010 c     this is fix cronin bug for Pb+Pb events at SPS energy.

0011 c

0012 C

0013 C Last modification Oct. 1993 to comply with non-vax

0014 C machines' compiler 

0015 C

0016 C*********************************************************************  

0017     
0018       SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)    
0019     
0020 C...Purpose: to store two partons/particles in their CM frame,  

0021 C...with the first along the +z axis.   

0022       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0023       SAVE /LUJETS/ 
0024       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0025       SAVE /LUDAT1/ 
0026       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0027       SAVE /LUDAT2/ 
0028     
0029 C...Standard checks.    

0030       MSTU(28)=0    
0031       IF(MSTU(12).GE.1) CALL LULIST(0)  
0032       IPA=MAX(1,IABS(IP))   
0033       IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,  
0034      &'(LU2ENT:) writing outside LUJETS memory')    
0035       KC1=LUCOMP(KF1)   
0036       KC2=LUCOMP(KF2)   
0037       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,  
0038      &'(LU2ENT:) unknown flavour code') 
0039     
0040 C...Find masses. Reset K, P and V vectors.  

0041       PM1=0.    
0042       IF(MSTU(10).EQ.1) PM1=P(IPA,5)    
0043       IF(MSTU(10).GE.2) PM1=ULMASS(KF1) 
0044       PM2=0.    
0045       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)  
0046       IF(MSTU(10).GE.2) PM2=ULMASS(KF2) 
0047       DO 100 I=IPA,IPA+1    
0048       DO 100 J=1,5  
0049       K(I,J)=0  
0050       P(I,J)=0. 
0051   100 V(I,J)=0. 
0052     
0053 C...Check flavours. 

0054       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)  
0055       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)  
0056       IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,  
0057      &'(LU2ENT:) unphysical flavour combination')   
0058       K(IPA,2)=KF1  
0059       K(IPA+1,2)=KF2    
0060     
0061 C...Store partons/particles in K vectors for normal case.   

0062       IF(IP.GE.0) THEN  
0063         K(IPA,1)=1  
0064         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2    
0065         K(IPA+1,1)=1    
0066     
0067 C...Store partons in K vectors for parton shower evolution. 

0068       ELSE  
0069         IF(KQ1.EQ.0.OR.KQ2.EQ.0) CALL LUERRM(2, 
0070      &  '(LU2ENT:) requested flavours can not develop parton shower')   
0071         K(IPA,1)=3  
0072         K(IPA+1,1)=3    
0073         K(IPA,4)=MSTU(5)*(IPA+1)    
0074         K(IPA,5)=K(IPA,4)   
0075         K(IPA+1,4)=MSTU(5)*IPA  
0076         K(IPA+1,5)=K(IPA+1,4)   
0077       ENDIF 
0078     
0079 C...Check kinematics and store partons/particles in P vectors.  

0080       IF(PECM.LE.PM1+PM2) CALL LUERRM(13,   
0081      &'(LU2ENT:) energy smaller than sum of masses')    
0082       PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/  
0083      &(2.*PECM) 
0084       P(IPA,3)=PA   
0085       P(IPA,4)=SQRT(PM1**2+PA**2)   
0086       P(IPA,5)=PM1  
0087       P(IPA+1,3)=-PA    
0088       P(IPA+1,4)=SQRT(PM2**2+PA**2) 
0089       P(IPA+1,5)=PM2    
0090     
0091 C...Set N. Optionally fragment/decay.   

0092       N=IPA+1   
0093       IF(IP.EQ.0) CALL LUEXEC   
0094     
0095       RETURN    
0096       END   
0097     
0098 C*********************************************************************  

0099     
0100       SUBROUTINE LUGIVE(CHIN)   
0101     
0102 C...Purpose: to set values of commonblock variables.    

0103       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0104       SAVE /LUJETS/ 
0105       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0106       SAVE /LUDAT1/ 
0107       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0108       SAVE /LUDAT2/ 
0109       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
0110       SAVE /LUDAT3/ 
0111       COMMON/LUDAT4/CHAF(500)   
0112       CHARACTER CHAF*8  
0113       SAVE /LUDAT4/ 
0114       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,   
0115      &CHNAM*4,CHVAR(17)*4,CHALP(2)*26,CHIND*8,CHINI*10,CHINR*16 
0116       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',    
0117      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/  
0118       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',  
0119      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
0120     
0121 C...Length of character variable. Subdivide it into instructions.   

0122       IF(MSTU(12).GE.1) CALL LULIST(0)  
0123       CHBIT=CHIN//' '   
0124       LBIT=101  
0125   100 LBIT=LBIT-1   
0126       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100  
0127       LTOT=0    
0128       DO 110 LCOM=1,LBIT    
0129       IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110  
0130       LTOT=LTOT+1   
0131       CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM) 
0132   110 CONTINUE  
0133       LLOW=0    
0134   120 LHIG=LLOW+1   
0135   130 LHIG=LHIG+1   
0136       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130 
0137       LBIT=LHIG-LLOW-1  
0138       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)    
0139     
0140 C...Identify commonblock variable.  

0141       LNAM=1    
0142   140 LNAM=LNAM+1   
0143       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.   
0144      &LNAM.LE.4) GOTO 140   
0145       CHNAM=CHBIT(1:LNAM-1)//' '    
0146       DO 150 LCOM=1,LNAM-1  
0147       DO 150 LALP=1,26  
0148   150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)= 
0149      &CHALP(2)(LALP:LALP)   
0150       IVAR=0    
0151       DO 160 IV=1,17    
0152   160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV    
0153       IF(IVAR.EQ.0) THEN    
0154         CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)   
0155         LLOW=LHIG   
0156         IF(LLOW.LT.LTOT) GOTO 120   
0157         RETURN  
0158       ENDIF 
0159     
0160 C...Identify any indices.   

0161       I=0   
0162       J=0   
0163       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN  
0164         LIND=LNAM   
0165   170   LIND=LIND+1 
0166         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170    
0167         CHIND=' '   
0168         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').    
0169      &  AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN 
0170           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)    
0171           READ(CHIND,'(I8)') I1 
0172           I=LUCOMP(I1)  
0173         ELSE    
0174           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)    
0175           READ(CHIND,'(I8)') I  
0176         ENDIF   
0177         LNAM=LIND   
0178         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 
0179       ENDIF 
0180       IF(CHBIT(LNAM:LNAM).EQ.',') THEN  
0181         LIND=LNAM   
0182   180   LIND=LIND+1 
0183         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180    
0184         CHIND=' '   
0185         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)  
0186         READ(CHIND,'(I8)') J    
0187         LNAM=LIND+1 
0188       ENDIF 
0189 C...cms initialize variable

0190       CHOLD=' '
0191 C...Check that indices allowed and save old value.  

0192       IERR=1    
0193       IF(CHBIT(LNAM:LNAM).NE.'=') GOTO 190  
0194       IF(IVAR.EQ.1) THEN    
0195         IF(I.NE.0.OR.J.NE.0) GOTO 190   
0196         IOLD=N  
0197       ELSEIF(IVAR.EQ.2) THEN    
0198         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0199         IOLD=K(I,J) 
0200       ELSEIF(IVAR.EQ.3) THEN    
0201         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0202         ROLD=P(I,J) 
0203       ELSEIF(IVAR.EQ.4) THEN    
0204         IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0205         ROLD=V(I,J) 
0206       ELSEIF(IVAR.EQ.5) THEN    
0207         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0208         IOLD=MSTU(I)    
0209       ELSEIF(IVAR.EQ.6) THEN    
0210         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0211         ROLD=PARU(I)    
0212       ELSEIF(IVAR.EQ.7) THEN    
0213         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0214         IOLD=MSTJ(I)    
0215       ELSEIF(IVAR.EQ.8) THEN    
0216         IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190   
0217         ROLD=PARJ(I)    
0218       ELSEIF(IVAR.EQ.9) THEN    
0219         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190 
0220         IOLD=KCHG(I,J)  
0221       ELSEIF(IVAR.EQ.10) THEN   
0222         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.4) GOTO 190 
0223         ROLD=PMAS(I,J)  
0224       ELSEIF(IVAR.EQ.11) THEN   
0225         IF(I.LT.1.OR.I.GT.2000.OR.J.NE.0) GOTO 190  
0226         ROLD=PARF(I)    
0227       ELSEIF(IVAR.EQ.12) THEN   
0228         IF(I.LT.1.OR.I.GT.4.OR.J.LT.1.OR.J.GT.4) GOTO 190   
0229         ROLD=VCKM(I,J)  
0230       ELSEIF(IVAR.EQ.13) THEN   
0231         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190 
0232         IOLD=MDCY(I,J)  
0233       ELSEIF(IVAR.EQ.14) THEN   
0234         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.2) GOTO 190 
0235         IOLD=MDME(I,J)  
0236       ELSEIF(IVAR.EQ.15) THEN   
0237         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.NE.0) GOTO 190   
0238         ROLD=BRAT(I)    
0239       ELSEIF(IVAR.EQ.16) THEN   
0240         IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.5) GOTO 190 
0241         IOLD=KFDP(I,J)  
0242       ELSEIF(IVAR.EQ.17) THEN   
0243         IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.NE.0) GOTO 190   
0244         CHOLD=CHAF(I)   
0245       ENDIF 
0246       IERR=0    
0247   190 IF(IERR.EQ.1) THEN    
0248         CALL LUERRM(18,'(LUGIVE:) unallowed indices for '// 
0249      &  CHBIT(1:LNAM-1))    
0250         LLOW=LHIG   
0251         IF(LLOW.LT.LTOT) GOTO 120   
0252         RETURN  
0253       ENDIF 
0254     
0255 C...Print current value of variable. Loop back. 

0256       IF(LNAM.GE.LBIT) THEN 
0257         CHBIT(LNAM:14)=' '  
0258         CHBIT(15:60)=' has the value                                '   
0259         IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR. 
0260      &  IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN   
0261           WRITE(CHBIT(51:60),'(I10)') IOLD  
0262         ELSEIF(IVAR.NE.17) THEN 
0263           WRITE(CHBIT(47:60),'(F14.5)') ROLD    
0264         ELSE    
0265           CHBIT(53:60)=CHOLD    
0266         ENDIF   
0267         IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)  
0268         LLOW=LHIG   
0269         IF(LLOW.LT.LTOT) GOTO 120   
0270         RETURN  
0271       ENDIF 
0272     
0273 C...Read in new variable value. 

0274       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.   
0275      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN 
0276         CHINI=' '   
0277         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)   
0278         READ(CHINI,'(I10)') INEW    
0279       ELSEIF(IVAR.NE.17) THEN   
0280         CHINR=' '   
0281         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)   
0282         READ(CHINR,'(F16.2)') RNEW  
0283       ELSE  
0284         CHNEW=CHBIT(LNAM+1:LBIT)//' '   
0285       ENDIF 
0286     
0287 C...Store new variable value.   

0288       IF(IVAR.EQ.1) THEN    
0289         N=INEW  
0290       ELSEIF(IVAR.EQ.2) THEN    
0291         K(I,J)=INEW 
0292       ELSEIF(IVAR.EQ.3) THEN    
0293         P(I,J)=RNEW 
0294       ELSEIF(IVAR.EQ.4) THEN    
0295         V(I,J)=RNEW 
0296       ELSEIF(IVAR.EQ.5) THEN    
0297         MSTU(I)=INEW    
0298       ELSEIF(IVAR.EQ.6) THEN    
0299         PARU(I)=RNEW    
0300       ELSEIF(IVAR.EQ.7) THEN    
0301         MSTJ(I)=INEW    
0302       ELSEIF(IVAR.EQ.8) THEN    
0303         PARJ(I)=RNEW    
0304       ELSEIF(IVAR.EQ.9) THEN    
0305         KCHG(I,J)=INEW  
0306       ELSEIF(IVAR.EQ.10) THEN   
0307         PMAS(I,J)=RNEW  
0308       ELSEIF(IVAR.EQ.11) THEN   
0309         PARF(I)=RNEW    
0310       ELSEIF(IVAR.EQ.12) THEN   
0311         VCKM(I,J)=RNEW  
0312       ELSEIF(IVAR.EQ.13) THEN   
0313         MDCY(I,J)=INEW  
0314       ELSEIF(IVAR.EQ.14) THEN   
0315         MDME(I,J)=INEW  
0316       ELSEIF(IVAR.EQ.15) THEN   
0317         BRAT(I)=RNEW    
0318       ELSEIF(IVAR.EQ.16) THEN   
0319         KFDP(I,J)=INEW  
0320       ELSEIF(IVAR.EQ.17) THEN   
0321         CHAF(I)=CHNEW   
0322       ENDIF 
0323     
0324 C...Write old and new value. Loop back. 

0325       CHBIT(LNAM:14)=' '    
0326       CHBIT(15:60)=' changed from                to               ' 
0327       IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.   
0328      &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN 
0329         WRITE(CHBIT(33:42),'(I10)') IOLD    
0330         WRITE(CHBIT(51:60),'(I10)') INEW    
0331       ELSEIF(IVAR.NE.17) THEN   
0332         WRITE(CHBIT(29:42),'(F14.5)') ROLD  
0333         WRITE(CHBIT(47:60),'(F14.5)') RNEW  
0334       ELSE  
0335         CHBIT(35:42)=CHOLD  
0336         CHBIT(53:60)=CHNEW  
0337       ENDIF 
0338       IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)    
0339       LLOW=LHIG 
0340       IF(LLOW.LT.LTOT) GOTO 120 
0341     
0342 C...Format statement for output on unit MSTU(11) (by default 6).    

0343  1000 FORMAT(5X,A60)    
0344     
0345       RETURN    
0346       END   
0347     
0348 C*********************************************************************  

0349     
0350       SUBROUTINE LUEXEC 
0351     
0352 C...Purpose: to administrate the fragmentation and decay chain. 

0353       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0354       SAVE /LUJETS/ 
0355       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0356       SAVE /LUDAT1/ 
0357       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0358       SAVE /LUDAT2/ 
0359       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
0360       SAVE /LUDAT3/ 
0361       DIMENSION PS(2,6) 
0362     
0363 C...Initialize and reset.   

0364       MSTU(24)=0    
0365       IF(MSTU(12).GE.1) CALL LULIST(0)  
0366       MSTU(31)=MSTU(31)+1   
0367       MSTU(1)=0 
0368       MSTU(2)=0 
0369       MSTU(3)=0 
0370       MCONS=1   
0371     
0372 C...Sum up momentum, energy and charge for starting entries.    

0373       NSAV=N    
0374       DO 100 I=1,2  
0375       DO 100 J=1,6  
0376   100 PS(I,J)=0.    
0377       DO 120 I=1,N  
0378       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120  
0379       DO 110 J=1,4  
0380   110 PS(1,J)=PS(1,J)+P(I,J)    
0381       PS(1,6)=PS(1,6)+LUCHGE(K(I,2))    
0382   120 CONTINUE  
0383       PARU(21)=PS(1,4)  
0384     
0385 C...Prepare system for subsequent fragmentation/decay.  

0386       CALL LUPREP(0)    
0387     
0388 C...Loop through jet fragmentation and particle decays. 

0389       MBE=0 
0390   130 MBE=MBE+1 
0391       IP=0  
0392   140 IP=IP+1   
0393       KC=0  
0394       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2)) 
0395       IF(KC.EQ.0) THEN  
0396     
0397 C...Particle decay if unstable and allowed. Save long-lived particle    

0398 C...decays until second pass after Bose-Einstein effects.   

0399       ELSEIF(KCHG(KC,2).EQ.0) THEN  
0400 clin-4/2008 break up compound IF statements:

0401 c        IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE. 

0402 c     &  EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))    

0403 c     &  CALL LUDECY(IP) 

0404          if(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1) then
0405             if(MSTJ(51).LE.0.OR.MBE.EQ.2.OR.PMAS(KC,2).GE.PARJ(91)
0406      &           .OR.IABS(K(IP,2)).EQ.311)
0407      &           CALL LUDECY(IP) 
0408          endif
0409 c    

0410 C...Decay products may develop a shower.    

0411         IF(MSTJ(92).GT.0) THEN  
0412           IP1=MSTJ(92)  
0413           QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,  
0414      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))    
0415           CALL LUSHOW(IP1,IP1+1,QMAX)   
0416           CALL LUPREP(IP1)  
0417           MSTJ(92)=0    
0418         ELSEIF(MSTJ(92).LT.0) THEN  
0419           IP1=-MSTJ(92) 
0420 clin-8/19/02 avoid actual argument in common blocks of LUSHOW:

0421 c          CALL LUSHOW(IP1,-3,P(IP,5))   

0422           pip5=P(IP,5)
0423           CALL LUSHOW(IP1,-3,pip5)   
0424           CALL LUPREP(IP1)  
0425           MSTJ(92)=0    
0426         ENDIF   
0427     
0428 C...Jet fragmentation: string or independent fragmentation. 

0429       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN 
0430         MFRAG=MSTJ(1)   
0431         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2 
0432         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN 
0433           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.   
0434      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN  
0435             IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)    
0436           ENDIF 
0437         ENDIF   
0438         IF(MFRAG.EQ.1) then
0439            CALL LUSTRF(IP)  
0440         endif
0441         IF(MFRAG.EQ.2) CALL LUINDF(IP)  
0442         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0 
0443         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0    
0444       ENDIF 
0445     
0446 C...Loop back if enough space left in LUJETS and no error abort.    

0447       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN  
0448       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN 
0449         GOTO 140    
0450       ELSEIF(IP.LT.N) THEN  
0451         CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')   
0452       ENDIF 
0453     
0454 C...Include simple Bose-Einstein effect parametrization if desired. 

0455       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN   
0456         CALL LUBOEI(NSAV)   
0457         GOTO 130    
0458       ENDIF 
0459     
0460 C...Check that momentum, energy and charge were conserved.  

0461       DO 160 I=1,N  
0462       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160  
0463       DO 150 J=1,4  
0464   150 PS(2,J)=PS(2,J)+P(I,J)    
0465       PS(2,6)=PS(2,6)+LUCHGE(K(I,2))    
0466   160 CONTINUE  
0467       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-  
0468      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4))) 
0469       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,   
0470      &'(LUEXEC:) four-momentum was not conserved')  
0471 c      IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) then

0472 c         CALL LUERRM(15,   

0473 c     &'(LUEXEC:) four-momentum was not conserved')  

0474 c         write(6,*) 'PS1,2=',PS(1,1),PS(1,2),PS(1,3),PS(1,4),

0475 c     1        '*',PS(2,1),PS(2,2),PS(2,3),PS(2,4)

0476 c      endif

0477 
0478       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,    
0479      &'(LUEXEC:) charge was not conserved') 
0480     
0481       RETURN    
0482       END   
0483     
0484 C*********************************************************************  

0485     
0486       SUBROUTINE LUPREP(IP) 
0487     
0488 C...Purpose: to rearrange partons along strings, to allow small systems 

0489 C...to collapse into one or two particles and to check flavours.    

0490       IMPLICIT DOUBLE PRECISION(D)  
0491       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0492       SAVE /LUJETS/ 
0493       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0494       SAVE /LUDAT1/ 
0495       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0496       SAVE /LUDAT2/ 
0497       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
0498       SAVE /LUDAT3/ 
0499       DIMENSION DPS(5),DPC(5),UE(3) 
0500     
0501 C...Rearrange parton shower product listing along strings: begin loop.  

0502       I1=N  
0503       DO 130 MQGST=1,2  
0504       DO 120 I=MAX(1,IP),N  
0505       IF(K(I,1).NE.3) GOTO 120  
0506       KC=LUCOMP(K(I,2)) 
0507       IF(KC.EQ.0) GOTO 120  
0508       KQ=KCHG(KC,2) 
0509       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120  
0510     
0511 C...Pick up loose string end.   

0512       KCS=4 
0513       IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 
0514       IA=I  
0515       NSTP=0    
0516   100 NSTP=NSTP+1   
0517       IF(NSTP.GT.4*N) THEN  
0518         CALL LUERRM(14,'(LUPREP:) caught in infinite loop') 
0519         RETURN  
0520       ENDIF 
0521     
0522 C...Copy undecayed parton.  

0523       IF(K(IA,1).EQ.3) THEN 
0524         IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN   
0525           CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS') 
0526           RETURN    
0527         ENDIF   
0528         I1=I1+1 
0529         K(I1,1)=2   
0530         IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1 
0531         K(I1,2)=K(IA,2) 
0532         K(I1,3)=IA  
0533         K(I1,4)=0   
0534         K(I1,5)=0   
0535         DO 110 J=1,5    
0536         P(I1,J)=P(IA,J) 
0537   110   V(I1,J)=V(IA,J) 
0538         K(IA,1)=K(IA,1)+10  
0539         IF(K(I1,1).EQ.1) GOTO 120   
0540       ENDIF 
0541     
0542 C...Go to next parton in colour space.  

0543       IB=IA 
0544       IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).   
0545      &NE.0) THEN    
0546         IA=MOD(K(IB,KCS),MSTU(5))   
0547         K(IB,KCS)=K(IB,KCS)+MSTU(5)**2  
0548         MREV=0  
0549       ELSE  
0550         IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)). 
0551      &  EQ.0) KCS=9-KCS 
0552         IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))   
0553         K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2    
0554         MREV=1  
0555       ENDIF 
0556       IF(IA.LE.0.OR.IA.GT.N) THEN   
0557         CALL LUERRM(12,'(LUPREP:) colour rearrangement failed') 
0558         RETURN  
0559       ENDIF 
0560       IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), 
0561      &MSTU(5)).EQ.IB) THEN  
0562         IF(MREV.EQ.1) KCS=9-KCS 
0563         IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS  
0564         K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2    
0565       ELSE  
0566         IF(MREV.EQ.0) KCS=9-KCS 
0567         IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS  
0568         K(IA,KCS)=K(IA,KCS)+MSTU(5)**2  
0569       ENDIF 
0570       IF(IA.NE.I) GOTO 100  
0571       K(I1,1)=1 
0572   120 CONTINUE  
0573   130 CONTINUE  
0574       N=I1  
0575     
0576 C...Find lowest-mass colour singlet jet system, OK if above thresh.  

0577       IF(MSTJ(14).LE.0) GOTO 320    
0578       NS=N  
0579   140 NSIN=N-NS 
0580       PDM=1.+PARJ(32)   
0581       IC=0
0582       IC1=0
0583       IC2=0
0584       DO 190 I=MAX(1,IP),NS 
0585       IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN  
0586       ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN  
0587         NSIN=NSIN+1 
0588         IC=I    
0589         DO 150 J=1,4    
0590   150   DPS(J)=dble(P(I,J))
0591         MSTJ(93)=1  
0592         DPS(5)=dble(ULMASS(K(I,2)))
0593       ELSEIF(K(I,1).EQ.2) THEN  
0594         DO 160 J=1,4    
0595   160   DPS(J)=DPS(J)+dble(P(I,J))
0596       ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN  
0597         DO 170 J=1,4    
0598   170   DPS(J)=DPS(J)+dble(P(I,J))
0599         MSTJ(93)=1  
0600         DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
0601         PD=sngl(SQRT(MAX(0D0,DPS(4)**2
0602      1       -DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5))    
0603         IF(PD.LT.PDM) THEN  
0604           PDM=PD    
0605           DO 180 J=1,5  
0606   180     DPC(J)=DPS(J) 
0607           IC1=IC    
0608           IC2=I 
0609         ENDIF   
0610         IC=0    
0611       ELSE  
0612         NSIN=NSIN+1 
0613       ENDIF 
0614   190 CONTINUE  
0615       IF(PDM.GE.PARJ(32)) GOTO 320  
0616     
0617 C...Fill small-mass system as cluster.  

0618       NSAV=N    
0619       PECM=sngl(SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)))
0620       K(N+1,1)=11   
0621       K(N+1,2)=91   
0622       K(N+1,3)=IC1  
0623       K(N+1,4)=N+2  
0624       K(N+1,5)=N+3  
0625       P(N+1,1)=sngl(DPC(1))
0626       P(N+1,2)=sngl(DPC(2))  
0627       P(N+1,3)=sngl(DPC(3))  
0628       P(N+1,4)=sngl(DPC(4))
0629       P(N+1,5)=PECM 
0630     
0631 C...Form two particles from flavours of lowest-mass system, if feasible.    

0632       K(N+2,1)=1    
0633       K(N+3,1)=1    
0634       IF(MSTU(16).NE.2) THEN    
0635         K(N+2,3)=N+1    
0636         K(N+3,3)=N+1    
0637       ELSE  
0638         K(N+2,3)=IC1    
0639         K(N+3,3)=IC2    
0640       ENDIF 
0641       K(N+2,4)=0    
0642       K(N+3,4)=0    
0643       K(N+2,5)=0    
0644       K(N+3,5)=0    
0645       IF(IABS(K(IC1,2)).NE.21) THEN 
0646         KC1=LUCOMP(K(IC1,2))    
0647         KC2=LUCOMP(K(IC2,2))    
0648         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320   
0649         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))   
0650         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))   
0651         IF(KQ1+KQ2.NE.0) GOTO 320   
0652   200   CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))   
0653         CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2)) 
0654         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200 
0655       ELSE  
0656         IF(IABS(K(IC2,2)).NE.21) GOTO 320   
0657   210   CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)    
0658         CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))   
0659         CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))    
0660         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210 
0661       ENDIF 
0662       P(N+2,5)=ULMASS(K(N+2,2)) 
0663       P(N+3,5)=ULMASS(K(N+3,2)) 
0664       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320 
0665       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260   
0666     
0667 C...Perform two-particle decay of jet system, if possible.  

0668 clin-5/2012:

0669 c      IF(PECM.GE.0.02d0*DPC(4)) THEN  

0670       IF(dble(PECM).GE.0.02d0*DPC(4)) THEN  
0671         PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-  
0672      &  (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)  
0673         UE(3)=2.*RLU(0)-1.  
0674         PHI=PARU(2)*RLU(0)  
0675         UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)    
0676         UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)    
0677         DO 220 J=1,3    
0678         P(N+2,J)=PA*UE(J)   
0679   220   P(N+3,J)=-PA*UE(J)  
0680         P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)    
0681         P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)    
0682         CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),  
0683      &  DPC(3)/DPC(4))  
0684       ELSE  
0685         NP=0    
0686         DO 230 I=IC1,IC2    
0687   230   IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1  
0688         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-   
0689      &  P(IC1,3)*P(IC2,3)   
0690         IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260    
0691         HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)   
0692         HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)   
0693         HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/    
0694      &  (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1. 
0695         HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2    
0696         HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC    
0697         HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC    
0698         DO 240 J=1,4    
0699         P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J) 
0700   240   P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J) 
0701       ENDIF 
0702       DO 250 J=1,4  
0703       V(N+1,J)=V(IC1,J) 
0704       V(N+2,J)=V(IC1,J) 
0705   250 V(N+3,J)=V(IC2,J) 
0706       V(N+1,5)=0.   
0707       V(N+2,5)=0.   
0708       V(N+3,5)=0.   
0709       N=N+3 
0710       GOTO 300  
0711     
0712 C...Else form one particle from the flavours available, if possible.    

0713   260 K(N+1,5)=N+2  
0714       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN  
0715         GOTO 320    
0716       ELSEIF(IABS(K(IC1,2)).NE.21) THEN 
0717         CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))  
0718       ELSE  
0719         KFLN=1+INT((2.+PARJ(2))*RLU(0)) 
0720         CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2)) 
0721       ENDIF 
0722       IF(K(N+2,2).EQ.0) GOTO 260    
0723       P(N+2,5)=ULMASS(K(N+2,2)) 
0724     
0725 C...Find parton/particle which combines to largest extra mass.  

0726       IR=0  
0727       HA=0. 
0728       DO 280 MCOMB=1,3  
0729       IF(IR.NE.0) GOTO 280  
0730       DO 270 I=MAX(1,IP),N  
0731       IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2. 
0732      &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270    
0733       IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2)) 
0734       IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270  
0735       IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270  
0736       IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100) 
0737      &GOTO 270  
0738       HCR=sngl(DPC(4))*P(I,4)-sngl(DPC(1))*P(I,1)
0739      1     -sngl(DPC(2))*P(I,2)-sngl(DPC(3))*P(I,3)   
0740       IF(HCR.GT.HA) THEN    
0741         IR=I    
0742         HA=HCR  
0743       ENDIF 
0744   270 CONTINUE  
0745   280 CONTINUE  
0746     
0747 C...Shuffle energy and momentum to put new particle on mass shell.  

0748       HB=PECM**2+HA 
0749       HC=P(N+2,5)**2+HA 
0750       HD=P(IR,5)**2+HA
0751 C******************CHANGES BY HIJING************  

0752       HK2=0.0
0753       IF(HA**2-(PECM*P(IR,5))**2.EQ.0.0.OR.HB+HD.EQ.0.0) GO TO 285
0754 C******************

0755       HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/ 
0756      &(HA**2-(PECM*P(IR,5))**2))-(HB+HC))/(HB+HD)   
0757   285 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB 
0758       DO 290 J=1,4  
0759       P(N+2,J)=(1.+HK1)*sngl(DPC(J))-HK2*P(IR,J)  
0760       P(IR,J)=(1.+HK2)*P(IR,J)-HK1*sngl(DPC(J))
0761       V(N+1,J)=V(IC1,J) 
0762   290 V(N+2,J)=V(IC1,J) 
0763       V(N+1,5)=0.   
0764       V(N+2,5)=0.   
0765       N=N+2 
0766     
0767 C...Mark collapsed system and store daughter pointers. Iterate. 

0768   300 DO 310 I=IC1,IC2  
0769       IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)  
0770      &THEN  
0771         K(I,1)=K(I,1)+10    
0772         IF(MSTU(16).NE.2) THEN  
0773           K(I,4)=NSAV+1 
0774           K(I,5)=NSAV+1 
0775         ELSE    
0776           K(I,4)=NSAV+2 
0777           K(I,5)=N  
0778         ENDIF   
0779       ENDIF 
0780   310 CONTINUE  
0781       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140  
0782     
0783 C...Check flavours and invariant masses in parton systems.  

0784   320 NP=0  
0785       KFN=0 
0786       KQS=0 
0787       DO 330 J=1,5  
0788   330 DPS(J)=0d0
0789       DO 360 I=MAX(1,IP),N  
0790       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360  
0791       KC=LUCOMP(K(I,2)) 
0792       IF(KC.EQ.0) GOTO 360  
0793       KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
0794       IF(KQ.EQ.0) GOTO 360  
0795       NP=NP+1   
0796       IF(KQ.NE.2) THEN  
0797         KFN=KFN+1   
0798         KQS=KQS+KQ  
0799         MSTJ(93)=1  
0800         DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
0801       ENDIF 
0802       DO 340 J=1,4  
0803   340 DPS(J)=DPS(J)+dble(P(I,J))
0804 
0805 clin-4/12/01:

0806 c     np: # of partons, KFN: number of quarks and diquarks, 

0807 c     KC=0 for color singlet system, -1 for quarks and anti-diquarks, 

0808 c     1 for quarks and anti-diquarks, and 2 for gluons:

0809       IF(K(I,1).EQ.1) THEN  
0810 clin-4/12/01     end of color singlet system.

0811         IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL 
0812      &  LUERRM(2,'(LUPREP:) unphysical flavour combination')    
0813 
0814 clin-4/16/01: 'jet system' should be defined as np.ne.2:

0815 c        IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.  

0816 c     &  (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,    

0817 c     &  '(LUPREP:) too small mass in jet system')   

0818         IF(NP.NE.2.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.  
0819      &  (0.9d0*dble(PARJ(32))+DPS(5))**2) then 
0820            CALL LUERRM(3,    
0821      &  '(LUPREP:) too small mass in jet system')   
0822            write (6,*) 'DPS(1-5),KI1-5=',DPS(1),DPS(2),DPS(3),DPS(4),
0823      1 DPS(5),'*',K(I,1),K(I,2),K(I,3),K(I,4),K(I,5)
0824         endif
0825 
0826         NP=0    
0827         KFN=0   
0828         KQS=0   
0829         DO 350 J=1,5    
0830   350   DPS(J)=0d0
0831       ENDIF 
0832   360 CONTINUE  
0833     
0834       RETURN    
0835       END   
0836     
0837 C*********************************************************************  

0838     
0839       SUBROUTINE LUSTRF(IP) 
0840 C...Purpose: to handle the fragmentation of an arbitrary colour singlet 

0841 C...jet system according to the Lund string fragmentation model.    

0842       IMPLICIT DOUBLE PRECISION(D)  
0843       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
0844       SAVE /LUJETS/ 
0845       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
0846       SAVE /LUDAT1/ 
0847       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
0848       SAVE /LUDAT2/ 
0849       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),    
0850      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),  
0851      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5)    
0852     
0853 C...Function: four-product of two vectors.  

0854       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) 
0855       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-   
0856      &DP(I,3)*DP(J,3)   
0857     
0858 C...Reset counters. Identify parton system. 

0859       MSTJ(91)=0    
0860       NSAV=N    
0861       NP=0  
0862       KQSUM=0   
0863       DO 100 J=1,5  
0864   100 DPS(J)=0d0 
0865       MJU(1)=0  
0866       MJU(2)=0  
0867       I=IP-1    
0868   110 I=I+1 
0869       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN 
0870         CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')    
0871         IF(MSTU(21).GE.1) RETURN    
0872       ENDIF 
0873       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110 
0874       KC=LUCOMP(K(I,2)) 
0875       IF(KC.EQ.0) GOTO 110  
0876       KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
0877       IF(KQ.EQ.0) GOTO 110  
0878       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN  
0879         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')   
0880         IF(MSTU(21).GE.1) RETURN    
0881       ENDIF 
0882 
0883 cms.. pre-initialize to avoid compiler warning

0884       JR=0
0885 
0886 C...Take copy of partons to be considered. Check flavour sum.   

0887       NP=NP+1   
0888       DO 120 J=1,5  
0889       K(N+NP,J)=K(I,J)  
0890       P(N+NP,J)=P(I,J)  
0891   120 DPS(J)=DPS(J)+dble(P(I,J))
0892       K(N+NP,3)=I   
0893       IF(P(N+NP,4)**2.LT.P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2) THEN   
0894         P(N+NP,4)=SQRT(P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2+  
0895      &  P(N+NP,5)**2)   
0896         DPS(4)=DPS(4)+dble(MAX(0.,P(N+NP,4)-P(I,4)))
0897       ENDIF 
0898       IF(KQ.NE.2) KQSUM=KQSUM+KQ    
0899       IF(K(I,1).EQ.41) THEN 
0900         KQSUM=KQSUM+2*KQ    
0901         IF(KQSUM.EQ.KQ) MJU(1)=N+NP 
0902         IF(KQSUM.NE.KQ) MJU(2)=N+NP 
0903       ENDIF 
0904       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110  
0905       IF(KQSUM.NE.0) THEN   
0906         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')  
0907         IF(MSTU(21).GE.1) RETURN    
0908       ENDIF 
0909 
0910 C...Boost copied system to CM frame (for better numerical precision).   

0911       CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4), 
0912      &-DPS(3)/DPS(4))   
0913 
0914 C...Search for very nearby partons that may be recombined.  

0915       NTRYR=0   
0916       PARU12=PARU(12)   
0917       PARU13=PARU(13)   
0918       MJU(3)=MJU(1) 
0919       MJU(4)=MJU(2) 
0920       NR=NP 
0921   130 IF(NR.GE.3) THEN  
0922         PDRMIN=2.*PARU12    
0923         IR=0
0924         DO 140 I=N+1,N+NR   
0925         IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 140 
0926         I1=I+1  
0927         IF(I.EQ.N+NR) I1=N+1    
0928         IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 140  
0929         IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)    
0930      &  GOTO 140    
0931         IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 140 
0932         PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+   
0933      &  P(I1,2)**2+P(I1,3)**2)) 
0934         PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)    
0935         PDR=4.*(PAP-PVP)**2/(PARU13**2*PAP+2.*(PAP-PVP))    
0936         IF(PDR.LT.PDRMIN) THEN  
0937           IR=I  
0938           PDRMIN=PDR    
0939         ENDIF   
0940   140   CONTINUE    
0941     
0942 C...Recombine very nearby partons to avoid machine precision problems.  

0943         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN    
0944           DO 150 J=1,4  
0945   150     P(N+1,J)=P(N+1,J)+P(N+NR,J)   
0946           P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- 
0947      &    P(N+1,3)**2)) 
0948           NR=NR-1   
0949           GOTO 130  
0950         ELSEIF(PDRMIN.LT.PARU12) THEN   
0951           DO 160 J=1,4  
0952   160     P(IR,J)=P(IR,J)+P(IR+1,J) 
0953           P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2- 
0954      &    P(IR,3)**2))  
0955           DO 170 I=IR+1,N+NR-1  
0956           K(I,2)=K(I+1,2)   
0957           DO 170 J=1,5  
0958   170     P(I,J)=P(I+1,J)   
0959           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)    
0960           NR=NR-1   
0961           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1  
0962           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1  
0963           GOTO 130  
0964         ENDIF   
0965       ENDIF 
0966       NTRYR=NTRYR+1 
0967     
0968 C...Reset particle counter. Skip ahead if no junctions are present; 

0969 C...this is usually the case!   

0970       NRS=MAX(5*NR+11,NP)   
0971       NTRY=0    
0972   180 NTRY=NTRY+1   
0973       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN   
0974         PARU12=4.*PARU12    
0975         PARU13=2.*PARU13    
0976         GOTO 130    
0977       ELSEIF(NTRY.GT.100) THEN  
0978         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') 
0979         IF(MSTU(21).GE.1) RETURN    
0980       ENDIF 
0981       I=N+NRS   
0982       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 500  
0983       DO 490 JT=1,2 
0984       NJS(JT)=0 
0985       IF(MJU(JT).EQ.0) GOTO 490 
0986       JS=3-2*JT 
0987     
0988 C...Find and sum up momentum on three sides of junction. Check flavours.    

0989       DO 190 IU=1,3 
0990       IJU(IU)=0 
0991       DO 190 J=1,5  
0992   190 PJU(IU,J)=0.  
0993       IU=0  
0994       DO 200 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS 
0995       IF(K(I1,2).NE.21.AND.IU.LE.2) THEN    
0996         IU=IU+1 
0997         IJU(IU)=I1  
0998       ENDIF 
0999       DO 200 J=1,4  
1000   200 PJU(IU,J)=PJU(IU,J)+P(I1,J)   
1001       DO 210 IU=1,3 
1002   210 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)    
1003       IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND. 
1004      &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN   
1005         CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')  
1006         IF(MSTU(21).GE.1) RETURN    
1007       ENDIF 
1008     
1009 C...Calculate (approximate) boost to rest frame of junction.    

1010       T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/  
1011      &(PJU(1,5)*PJU(2,5))   
1012       T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/  
1013      &(PJU(1,5)*PJU(3,5))   
1014       T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/  
1015      &(PJU(2,5)*PJU(3,5))   
1016       T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))  
1017       T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))  
1018       TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))    
1019       T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)    
1020       T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)    
1021       DO 220 J=1,3  
1022   220 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5)) 
1023       TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2) 
1024       DO 230 IU=1,3 
1025   230 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)- 
1026      &TJU(3)*PJU(IU,3)  
1027     
1028 C...Put junction at rest if motion could give inconsistencies.  

1029       IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN   
1030         DO 240 J=1,3    
1031   240   TJU(J)=0.   
1032         TJU(4)=1.   
1033         PJU(1,5)=PJU(1,4)   
1034         PJU(2,5)=PJU(2,4)   
1035         PJU(3,5)=PJU(3,4)   
1036       ENDIF 
1037     
1038 C...Start preparing for fragmentation of two strings from junction. 

1039       ISTA=I    
1040       DO 470 IU=1,2 
1041       NS=IJU(IU+1)-IJU(IU)  
1042     
1043 C...Junction strings: find longitudinal string directions.  

1044       DO 260 IS=1,NS    
1045       IS1=IJU(IU)+IS-1  
1046       IS2=IJU(IU)+IS    
1047       DO 250 J=1,5  
1048       DP(1,J)=dble(0.5*P(IS1,J))
1049       IF(IS.EQ.1) DP(1,J)=dble(P(IS1,J))
1050       DP(2,J)=dble(0.5*P(IS2,J))
1051   250 IF(IS.EQ.NS) DP(2,J)=-dble(PJU(IU,J))
1052       IF(IS.EQ.NS) DP(2,4)=dble(
1053      1     SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2))
1054       IF(IS.EQ.NS) DP(2,5)=0d0   
1055       DP(3,5)=DFOUR(1,1)    
1056       DP(4,5)=DFOUR(2,2)    
1057       DHKC=DFOUR(1,2)   
1058       IF(DP(3,5)+2d0*DHKC+DP(4,5).LE.0d0) THEN    
1059         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1060         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1061         DP(3,5)=0D0 
1062         DP(4,5)=0D0 
1063         DHKC=DFOUR(1,2) 
1064       ENDIF 
1065       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))    
1066       DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1d0) 
1067       DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1d0) 
1068       IN1=N+NR+4*IS-3   
1069       P(IN1,5)=sngl(SQRT(DP(3,5)+2d0*DHKC+DP(4,5)))
1070       DO 260 J=1,4  
1071       P(IN1,J)=sngl((1d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1072   260 P(IN1+1,J)=sngl((1d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1073     
1074 C...Junction strings: initialize flavour, momentum and starting pos.    

1075       ISAV=I    
1076   270 NTRY=NTRY+1   
1077       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN   
1078         PARU12=4.*PARU12    
1079         PARU13=2.*PARU13    
1080         GOTO 130    
1081       ELSEIF(NTRY.GT.100) THEN  
1082         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') 
1083         IF(MSTU(21).GE.1) RETURN    
1084       ENDIF 
1085       I=ISAV    
1086       IRANKJ=0  
1087       IE(1)=K(N+1+(JT/2)*(NP-1),3)  
1088       IN(4)=N+NR+1  
1089       IN(5)=IN(4)+1 
1090       IN(6)=N+NR+4*NS+1 
1091       DO 280 JQ=1,2 
1092       DO 280 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4 
1093       P(IN1,1)=2-JQ 
1094       P(IN1,2)=JQ-1 
1095   280 P(IN1,3)=1.   
1096       KFL(1)=K(IJU(IU),2)   
1097       PX(1)=0.  
1098       PY(1)=0.  
1099       GAM(1)=0. 
1100       DO 290 J=1,5  
1101   290 PJU(IU+3,J)=0.    
1102     
1103 C...Junction strings: find initial transverse directions.   

1104       DO 300 J=1,4  
1105       DP(1,J)=dble(P(IN(4),J))
1106       DP(2,J)=dble(P(IN(4)+1,J))
1107       DP(3,J)=0d0    
1108   300 DP(4,J)=0d0    
1109       DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)    
1110       DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)    
1111       DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)   
1112       DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)   
1113       DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)   
1114       IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1d0    
1115       IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0    
1116       IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0    
1117       IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0    
1118       DHC12=DFOUR(1,2)  
1119       DHCX1=DFOUR(3,1)/DHC12    
1120       DHCX2=DFOUR(3,2)/DHC12    
1121       DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) 
1122       DHCY1=DFOUR(4,1)/DHC12    
1123       DHCY2=DFOUR(4,2)/DHC12    
1124       DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12   
1125       DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)    
1126       DO 310 J=1,4  
1127       DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))   
1128       P(IN(6),J)=sngl(DP(3,J))
1129   310 P(IN(6)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-  
1130      &DHCYX*DP(3,J)))    
1131     
1132 C...Junction strings: produce new particle, origin. 

1133   320 I=I+1 
1134       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN   
1135         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')   
1136         IF(MSTU(21).GE.1) RETURN    
1137       ENDIF 
1138       IRANKJ=IRANKJ+1   
1139       K(I,1)=1  
1140       K(I,3)=IE(1)  
1141       K(I,4)=0  
1142       K(I,5)=0  
1143     
1144 C...Junction strings: generate flavour, hadron, pT, z and Gamma.    

1145   330 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))   
1146       IF(K(I,2).EQ.0) GOTO 270  
1147       IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.  
1148      &IABS(KFL(3)).GT.10) THEN  
1149         IF(RLU(0).GT.PARJ(19)) GOTO 330 
1150       ENDIF 
1151       P(I,5)=ULMASS(K(I,2)) 
1152       CALL LUPTDI(KFL(1),PX(3),PY(3))   
1153       PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2 
1154       CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)    
1155       GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)    
1156       DO 340 J=1,3  
1157   340 IN(J)=IN(3+J) 
1158 
1159 C...Junction strings: stepping within or from 'low' string region easy. 

1160       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*  
1161      &P(IN(1),5)**2.GE.PR(1)) THEN  
1162         P(IN(1)+2,4)=Z*P(IN(1)+2,3) 
1163         P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2) 
1164         DO 350 J=1,4    
1165   350   P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)  
1166         GOTO 420    
1167       ELSEIF(IN(1)+1.EQ.IN(2)) THEN 
1168         P(IN(2)+2,4)=P(IN(2)+2,3)   
1169         P(IN(2)+2,1)=1. 
1170         IN(2)=IN(2)+4   
1171         IF(IN(2).GT.N+NR+4*NS) GOTO 270 
1172         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1173           P(IN(1)+2,4)=P(IN(1)+2,3) 
1174           P(IN(1)+2,1)=0.   
1175           IN(1)=IN(1)+4 
1176         ENDIF   
1177       ENDIF 
1178     
1179 C...Junction strings: find new transverse directions.   

1180   360 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.   
1181      &IN(1).GT.IN(2)) GOTO 270  
1182       IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN 
1183         DO 370 J=1,4    
1184         DP(1,J)=dble(P(IN(1),J))
1185         DP(2,J)=dble(P(IN(2),J))
1186         DP(3,J)=0d0  
1187   370   DP(4,J)=0d0  
1188         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1189         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1190         DHC12=DFOUR(1,2)    
1191 clin-5/2012:

1192 c        IF(DHC12.LE.1E-2) THEN  

1193         IF(DHC12.LE.1D-2) THEN  
1194           P(IN(1)+2,4)=P(IN(1)+2,3) 
1195           P(IN(1)+2,1)=0.   
1196           IN(1)=IN(1)+4 
1197           GOTO 360  
1198         ENDIF   
1199         IN(3)=N+NR+4*NS+5   
1200         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) 
1201         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) 
1202         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) 
1203         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1d0  
1204         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0  
1205         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0  
1206         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0  
1207         DHCX1=DFOUR(3,1)/DHC12  
1208         DHCX2=DFOUR(3,2)/DHC12  
1209         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)   
1210         DHCY1=DFOUR(4,1)/DHC12  
1211         DHCY2=DFOUR(4,2)/DHC12  
1212         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 
1213         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)  
1214         DO 380 J=1,4    
1215         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) 
1216         P(IN(3),J)=sngl(DP(3,J))
1217   380   P(IN(3)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-    
1218      &  DHCYX*DP(3,J)))  
1219 C...Express pT with respect to new axes, if sensible.   

1220         PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))    
1221         PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))    
1222         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN   
1223           PX(3)=PXP 
1224           PY(3)=PYP 
1225         ENDIF   
1226       ENDIF 
1227     
1228 C...Junction strings: sum up known four-momentum, coefficients for m2.  

1229       DO 400 J=1,4  
1230       DHG(J)=0d0 
1231       P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+  
1232      &PY(3)*P(IN(3)+1,J)    
1233       DO 390 IN1=IN(4),IN(1)-4,4    
1234   390 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) 
1235       DO 400 IN2=IN(5),IN(2)-4,4    
1236   400 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) 
1237       DHM(1)=dble(FOUR(I,I))
1238       DHM(2)=dble(2.*FOUR(I,IN(1)))   
1239       DHM(3)=dble(2.*FOUR(I,IN(2)))  
1240       DHM(4)=dble(2.*FOUR(IN(1),IN(2))) 
1241     
1242 C...Junction strings: find coefficients for Gamma expression.   

1243       DO 410 IN2=IN(1)+1,IN(2),4    
1244       DO 410 IN1=IN(1),IN2-1,4  
1245       DHC=dble(2.*FOUR(IN1,IN2))
1246       DHG(1)=DHG(1)+dble(P(IN1+2,1)*P(IN2+2,1))*DHC   
1247       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(P(IN2+2,1))*DHC 
1248       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(P(IN1+2,1))*DHC 
1249   410 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC   
1250     
1251 C...Junction strings: solve (m2, Gamma) equation system for energies.   

1252       DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)  
1253 clin-5/2012:

1254 c      IF(ABS(DHS1).LT.1E-4) GOTO 270    

1255       IF(DABS(DHS1).LT.1D-4) GOTO 270    
1256       DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(2)*DHG(3)-DHG(4)* 
1257      &(dble(P(I,5))**2-DHM(1))+DHG(2)*DHM(3)  
1258       DHS3=DHM(2)*(dble(GAM(3))-DHG(1))
1259      1     -DHG(2)*(dble(P(I,5))**2-DHM(1)) 
1260       P(IN(2)+2,4)=0.5*sngl(SQRT(MAX(0D0,DHS2**2-4d0*DHS1*DHS3))
1261      &     /ABS(DHS1)-DHS2/DHS1)
1262       IF(DHM(2)+DHM(4)*dble(P(IN(2)+2,4)).LE.0d0) GOTO 270 
1263       P(IN(1)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(3))*P(IN(2)+2,4))/  
1264      &(sngl(DHM(2))+sngl(DHM(4))*P(IN(2)+2,4))  
1265 
1266 C...Junction strings: step to new region if necessary.  

1267       IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN 
1268         P(IN(2)+2,4)=P(IN(2)+2,3)   
1269         P(IN(2)+2,1)=1. 
1270         IN(2)=IN(2)+4   
1271         IF(IN(2).GT.N+NR+4*NS) GOTO 270 
1272         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1273           P(IN(1)+2,4)=P(IN(1)+2,3) 
1274           P(IN(1)+2,1)=0.   
1275           IN(1)=IN(1)+4 
1276         ENDIF   
1277         GOTO 360    
1278       ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN 
1279         P(IN(1)+2,4)=P(IN(1)+2,3)   
1280         P(IN(1)+2,1)=0. 
1281         IN(1)=IN(1)+JS  
1282         GOTO 710    
1283       ENDIF 
1284     
1285 C...Junction strings: particle four-momentum, remainder, loop back. 

1286   420 DO 430 J=1,4  
1287       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J) 
1288   430 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)    
1289       IF(P(I,4).LE.0.) GOTO 270 
1290       PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-    
1291      &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) 
1292       IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN 
1293         KFL(1)=-KFL(3)  
1294         PX(1)=-PX(3)    
1295         PY(1)=-PY(3)    
1296         GAM(1)=GAM(3)   
1297         IF(IN(3).NE.IN(6)) THEN 
1298           DO 440 J=1,4  
1299           P(IN(6),J)=P(IN(3),J) 
1300   440     P(IN(6)+1,J)=P(IN(3)+1,J) 
1301         ENDIF   
1302         DO 450 JQ=1,2   
1303         IN(3+JQ)=IN(JQ) 
1304         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)   
1305   450   P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)  
1306         GOTO 320    
1307       ENDIF 
1308     
1309 C...Junction strings: save quantities left after each string.   

1310       IF(IABS(KFL(1)).GT.10) GOTO 270   
1311       I=I-1 
1312       KFJH(IU)=KFL(1)   
1313       DO 460 J=1,4  
1314   460 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)  
1315   470 CONTINUE  
1316     
1317 C...Junction strings: put together to new effective string endpoint.    

1318       NJS(JT)=I-ISTA    
1319       KFJS(JT)=K(K(MJU(JT+2),3),2)  
1320       KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1   
1321       IF(KFJH(1).EQ.KFJH(2)) KFLS=3 
1322       IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),  
1323      &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+  
1324      &KFLS,KFJH(1)) 
1325       DO 480 J=1,4  
1326       PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)  
1327   480 PJS(JT+2,J)=PJU(4,J)+PJU(5,J) 
1328       PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2- 
1329      &PJS(JT,3)**2))    
1330   490 CONTINUE  
1331     
1332 C...Open versus closed strings. Choose breakup region for latter.   

1333   500 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN  
1334         NS=MJU(2)-MJU(1)    
1335         NB=MJU(1)-N 
1336       ELSEIF(MJU(1).NE.0) THEN  
1337         NS=N+NR-MJU(1)  
1338         NB=MJU(1)-N 
1339       ELSEIF(MJU(2).NE.0) THEN  
1340         NS=MJU(2)-N 
1341         NB=1    
1342       ELSEIF(IABS(K(N+1,2)).NE.21) THEN 
1343         NS=NR-1 
1344         NB=1    
1345       ELSE  
1346         NS=NR+1 
1347         W2SUM=0.    
1348         DO 510 IS=1,NR  
1349         P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))   
1350   510   W2SUM=W2SUM+P(N+NR+IS,1)    
1351         W2RAN=RLU(0)*W2SUM  
1352         NB=0    
1353   520   NB=NB+1 
1354         W2SUM=W2SUM-P(N+NR+NB,1)    
1355         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 520    
1356       ENDIF 
1357     
1358 C...Find longitudinal string directions (i.e. lightlike four-vectors).  

1359       DO 540 IS=1,NS    
1360       IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)   
1361       IS2=N+IS+NB-NR*((IS+NB-1)/NR) 
1362       DO 530 J=1,5  
1363       DP(1,J)=dble(P(IS1,J))
1364       IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5d0*DP(1,J)  
1365       IF(IS1.EQ.MJU(1)) DP(1,J)=dble(PJS(1,J)-PJS(3,J))
1366       DP(2,J)=dble(P(IS2,J))
1367       IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5d0*DP(2,J)  
1368   530 IF(IS2.EQ.MJU(2)) DP(2,J)=dble(PJS(2,J)-PJS(4,J))
1369       DP(3,5)=DFOUR(1,1)    
1370       DP(4,5)=DFOUR(2,2)    
1371       DHKC=DFOUR(1,2)   
1372       IF(DP(3,5)+2.d0*DHKC+DP(4,5).LE.0.d0) THEN    
1373         DP(3,5)=DP(1,5)**2  
1374         DP(4,5)=DP(2,5)**2  
1375         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)   
1376         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)   
1377         DHKC=DFOUR(1,2) 
1378       ENDIF 
1379       DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))    
1380       DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1.d0) 
1381       DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1.d0) 
1382       IN1=N+NR+4*IS-3   
1383       P(IN1,5)=SQRT(sngl(DP(3,5)+2.d0*DHKC+DP(4,5)))
1384       DO 540 J=1,4  
1385       P(IN1,J)=sngl((1.d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1386   540 P(IN1+1,J)=sngl((1.d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1387     
1388 C...Begin initialization: sum up energy, set starting position. 

1389       ISAV=I    
1390   550 NTRY=NTRY+1   
1391       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN   
1392         PARU12=4.*PARU12    
1393         PARU13=2.*PARU13    
1394         GOTO 130    
1395       ELSEIF(NTRY.GT.100) THEN  
1396         CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') 
1397         IF(MSTU(21).GE.1) RETURN    
1398       ENDIF 
1399       I=ISAV    
1400       DO 560 J=1,4  
1401       P(N+NRS,J)=0. 
1402       DO 560 IS=1,NR    
1403   560 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)   
1404       DO 570 JT=1,2 
1405       IRANK(JT)=0   
1406       IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)    
1407       IF(NS.GT.NR) IRANK(JT)=1  
1408       IE(JT)=K(N+1+(JT/2)*(NP-1),3) 
1409       IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1) 
1410       IN(3*JT+2)=IN(3*JT+1)+1   
1411       IN(3*JT+3)=N+NR+4*NS+2*JT-1   
1412       DO 570 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4 
1413       P(IN1,1)=2-JT 
1414       P(IN1,2)=JT-1 
1415   570 P(IN1,3)=1.   
1416     
1417 C...Initialize flavour and pT variables for open string.    

1418       IF(NS.LT.NR) THEN 
1419         PX(1)=0.    
1420         PY(1)=0.    
1421         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))   
1422         PX(2)=-PX(1)    
1423         PY(2)=-PY(1)    
1424         DO 580 JT=1,2   
1425         KFL(JT)=K(IE(JT),2) 
1426         IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)   
1427         MSTJ(93)=1  
1428         PMQ(JT)=ULMASS(KFL(JT)) 
1429   580   GAM(JT)=0.  
1430     
1431 C...Closed string: random initial breakup flavour, pT and vertex.   

1432       ELSE  
1433         KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)    
1434         CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)  
1435         KFL(2)=-KFL(1)  
1436         IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN   
1437           KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))  
1438         ELSEIF(IABS(KFL(1)).GT.10) THEN 
1439           KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))  
1440         ENDIF   
1441         CALL LUPTDI(KFL(1),PX(1),PY(1)) 
1442         PX(2)=-PX(1)    
1443         PY(2)=-PY(1)    
1444         PR3=MIN(25.,0.1*P(N+NR+1,5)**2) 
1445   590   CALL LUZDIS(KFL(1),KFL(2),PR3,Z)    
1446         ZR=PR3/(Z*P(N+NR+1,5)**2)   
1447         IF(ZR.GE.1.) GOTO 590   
1448 
1449         DO 600 JT=1,2   
1450         MSTJ(93)=1  
1451         PMQ(JT)=ULMASS(KFL(JT)) 
1452         GAM(JT)=PR3*(1.-Z)/Z    
1453         IN1=N+NR+3+4*(JT/2)*(NS-1)  
1454         P(IN1,JT)=1.-Z  
1455         P(IN1,3-JT)=JT-1    
1456         P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z 
1457         P(IN1+1,JT)=ZR  
1458         P(IN1+1,3-JT)=2-JT  
1459   600   P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR 
1460       ENDIF 
1461     
1462 C...Find initial transverse directions (i.e. spacelike four-vectors).   

1463       DO 640 JT=1,2 
1464       IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN    
1465         IN1=IN(3*JT+1)  
1466         IN3=IN(3*JT+3)  
1467         DO 610 J=1,4    
1468         DP(1,J)=dble(P(IN1,J))
1469         DP(2,J)=dble(P(IN1+1,J))
1470         DP(3,J)=0.d0
1471   610   DP(4,J)=0.d0
1472         DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1473         DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1474         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) 
1475         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) 
1476         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) 
1477         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1478         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1479         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1480         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1481         DHC12=DFOUR(1,2)    
1482         DHCX1=DFOUR(3,1)/DHC12  
1483         DHCX2=DFOUR(3,2)/DHC12  
1484         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)   
1485         DHCY1=DFOUR(4,1)/DHC12  
1486         DHCY2=DFOUR(4,2)/DHC12  
1487         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 
1488         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)  
1489         DO 620 J=1,4    
1490         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) 
1491         P(IN3,J)=sngl(DP(3,J))
1492   620   P(IN3+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-  
1493      &  DHCYX*DP(3,J)))
1494       ELSE  
1495         DO 630 J=1,4    
1496         P(IN3+2,J)=P(IN3,J) 
1497   630   P(IN3+3,J)=P(IN3+1,J)   
1498       ENDIF 
1499   640 CONTINUE  
1500     
1501 C...Remove energy used up in junction string fragmentation. 

1502       IF(MJU(1)+MJU(2).GT.0) THEN   
1503         DO 660 JT=1,2   
1504         IF(NJS(JT).EQ.0) GOTO 660   
1505         DO 650 J=1,4    
1506   650   P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)   
1507   660   CONTINUE    
1508       ENDIF 
1509     
1510 C...Produce new particle: side, origin. 

1511   670 I=I+1 
1512       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN   
1513         CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')   
1514         IF(MSTU(21).GE.1) RETURN    
1515       ENDIF 
1516       JT=int(1.5+RLU(0))
1517       IF(IABS(KFL(3-JT)).GT.10) JT=3-JT 
1518       JR=3-JT   
1519       JS=3-2*JT 
1520       IRANK(JT)=IRANK(JT)+1 
1521       K(I,1)=1  
1522       K(I,3)=IE(JT) 
1523       K(I,4)=0  
1524       K(I,5)=0  
1525     
1526 C...Generate flavour, hadron and pT.    

1527   680 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))  
1528       IF(K(I,2).EQ.0) GOTO 550  
1529       IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.  
1530      &IABS(KFL(3)).GT.10) THEN  
1531         IF(RLU(0).GT.PARJ(19)) GOTO 680 
1532       ENDIF 
1533       P(I,5)=ULMASS(K(I,2)) 
1534       CALL LUPTDI(KFL(JT),PX(3),PY(3))  
1535       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2  
1536     
1537 C...Final hadrons for small invariant mass. 

1538       MSTJ(93)=1    
1539       PMQ(3)=ULMASS(KFL(3)) 
1540       WMIN=PARJ(32+MSTJ(11))+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)  
1541       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=  
1542      &WMIN-0.5*PARJ(36)*PMQ(3)  
1543       WREM2=FOUR(N+NRS,N+NRS)   
1544       IF(WREM2.LT.0.10) GOTO 550    
1545       IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),    
1546      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 810  
1547     
1548 C...Choose z, which gives Gamma. Shift z for heavy flavours.    

1549       CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)  
1550 
1551       KFL1A=IABS(KFL(1))    
1552       KFL2A=IABS(KFL(2))    
1553       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),    
1554      &MOD(KFL2A/1000,10)).GE.4) THEN    
1555         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2  
1556         PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))    
1557         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)   
1558         PR(JR)=(PMQ(JR)+PARJ(32+MSTJ(11)))**2+(PX(JR)-PX(3))**2+    
1559      &  (PY(JR)-PY(3))**2   
1560         IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 810  
1561       ENDIF 
1562       GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)  
1563       DO 690 J=1,3  
1564   690 IN(J)=IN(3*JT+J)  
1565     
1566 C...Stepping within or from 'low' string region easy.   

1567       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*  
1568      &P(IN(1),5)**2.GE.PR(JT)) THEN 
1569         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)   
1570         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)  
1571         DO 700 J=1,4    
1572   700   P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)    
1573         GOTO 770    
1574       ELSEIF(IN(1)+1.EQ.IN(2)) THEN 
1575         P(IN(JR)+2,4)=P(IN(JR)+2,3) 
1576         P(IN(JR)+2,JT)=1.   
1577         IN(JR)=IN(JR)+4*JS  
1578         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550   
1579         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1580           P(IN(JT)+2,4)=P(IN(JT)+2,3)   
1581           P(IN(JT)+2,JT)=0. 
1582           IN(JT)=IN(JT)+4*JS    
1583         ENDIF   
1584       ENDIF 
1585     
1586 C...Find new transverse directions (i.e. spacelike string vectors). 

1587   710 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR. 
1588      &IN(1).GT.IN(2)) GOTO 550  
1589       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN   
1590         DO 720 J=1,4    
1591         DP(1,J)=dble(P(IN(1),J))
1592         DP(2,J)=dble(P(IN(2),J))
1593         DP(3,J)=0.d0
1594   720   DP(4,J)=0.d0
1595         DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)  
1596         DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)  
1597         DHC12=DFOUR(1,2)    
1598 clin-5/2012:

1599 c        IF(DHC12.LE.1E-2) THEN  

1600         IF(DHC12.LE.1D-2) THEN  
1601           P(IN(JT)+2,4)=P(IN(JT)+2,3)   
1602           P(IN(JT)+2,JT)=0. 
1603           IN(JT)=IN(JT)+4*JS    
1604           GOTO 710  
1605         ENDIF   
1606         IN(3)=N+NR+4*NS+5   
1607         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) 
1608         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) 
1609         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) 
1610         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1611         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1612         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1613         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1614         DHCX1=DFOUR(3,1)/DHC12  
1615         DHCX2=DFOUR(3,2)/DHC12  
1616         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)   
1617         DHCY1=DFOUR(4,1)/DHC12  
1618         DHCY2=DFOUR(4,2)/DHC12  
1619         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 
1620         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)  
1621         DO 730 J=1,4    
1622         DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) 
1623         P(IN(3),J)=sngl(DP(3,J))
1624   730   P(IN(3)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-    
1625      &  DHCYX*DP(3,J))) 
1626 C...Express pT with respect to new axes, if sensible.   

1627         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*   
1628      &  FOUR(IN(3*JT+3)+1,IN(3)))   
1629         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)* 
1630      &  FOUR(IN(3*JT+3)+1,IN(3)+1)) 
1631         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN   
1632           PX(3)=PXP 
1633           PY(3)=PYP 
1634         ENDIF   
1635       ENDIF 
1636     
1637 C...Sum up known four-momentum. Gives coefficients for m2 expression.   

1638       DO 750 J=1,4  
1639       DHG(J)=0.d0
1640       P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+   
1641      &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)   
1642       DO 740 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS 
1643   740 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) 
1644       DO 750 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS 
1645   750 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) 
1646       DHM(1)=dble(FOUR(I,I))
1647       DHM(2)=dble(2.*FOUR(I,IN(1)))  
1648       DHM(3)=dble(2.*FOUR(I,IN(2)))
1649       DHM(4)=dble(2.*FOUR(IN(1),IN(2)))
1650     
1651 C...Find coefficients for Gamma expression. 

1652       DO 760 IN2=IN(1)+1,IN(2),4    
1653       DO 760 IN1=IN(1),IN2-1,4  
1654       DHC=dble(2.*FOUR(IN1,IN2))
1655       DHG(1)=DHG(1)+dble(P(IN1+2,JT)*P(IN2+2,JT))*DHC 
1656       IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(float(JS)*P(IN2+2,JT))*DHC 
1657       IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(float(JS)*P(IN1+2,JT))*DHC 
1658   760 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC   
1659     
1660 C...Solve (m2, Gamma) equation system for energies taken.   

1661       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)    
1662 clin-5/2012:

1663 c      IF(ABS(DHS1).LT.1E-4) GOTO 550    

1664       IF(DABS(DHS1).LT.1D-4) GOTO 550    
1665       DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*   
1666      &(dble(P(I,5))**2-DHM(1))+DHG(JT+1)*DHM(JR+1)    
1667       DHS3=DHM(JT+1)*(dble(GAM(3))-DHG(1))-DHG(JT+1)
1668      &     *(dble(P(I,5))**2-DHM(1))   
1669       P(IN(JR)+2,4)=0.5*sngl((SQRT(MAX(0D0,DHS2**2-4.d0*DHS1*DHS3)))
1670      &/ABS(DHS1)-DHS2/DHS1)
1671       IF(DHM(JT+1)+DHM(4)*dble(P(IN(JR)+2,4)).LE.0.d0) GOTO 550 
1672       P(IN(JT)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(JR+1))
1673      &     *P(IN(JR)+2,4))/(sngl(DHM(JT+1))+sngl(DHM(4))*P(IN(JR)+2,4))
1674     
1675 C...Step to new region if necessary.    

1676       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN   
1677         P(IN(JR)+2,4)=P(IN(JR)+2,3) 
1678         P(IN(JR)+2,JT)=1.   
1679         IN(JR)=IN(JR)+4*JS  
1680         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550   
1681         IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN  
1682           P(IN(JT)+2,4)=P(IN(JT)+2,3)   
1683           P(IN(JT)+2,JT)=0. 
1684           IN(JT)=IN(JT)+4*JS    
1685         ENDIF   
1686         GOTO 710    
1687       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN   
1688         P(IN(JT)+2,4)=P(IN(JT)+2,3) 
1689         P(IN(JT)+2,JT)=0.   
1690         IN(JT)=IN(JT)+4*JS  
1691         GOTO 710    
1692       ENDIF 
1693     
1694 C...Four-momentum of particle. Remaining quantities. Loop back. 

1695   770 DO 780 J=1,4  
1696       P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J) 
1697   780 P(N+NRS,J)=P(N+NRS,J)-P(I,J)  
1698       IF(P(I,4).LE.0.) GOTO 550 
1699       KFL(JT)=-KFL(3)   
1700       PMQ(JT)=PMQ(3)    
1701       PX(JT)=-PX(3) 
1702       PY(JT)=-PY(3) 
1703       GAM(JT)=GAM(3)    
1704       IF(IN(3).NE.IN(3*JT+3)) THEN  
1705         DO 790 J=1,4    
1706         P(IN(3*JT+3),J)=P(IN(3),J)  
1707   790   P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)  
1708       ENDIF 
1709       DO 800 JQ=1,2 
1710       IN(3*JT+JQ)=IN(JQ)    
1711       P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) 
1712   800 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)   
1713       GOTO 670  
1714     
1715 C...Final hadron: side, flavour, hadron, mass.  

1716   810 I=I+1 
1717       K(I,1)=1  
1718       K(I,3)=IE(JR) 
1719       K(I,4)=0  
1720       K(I,5)=0  
1721       CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))    
1722       IF(K(I,2).EQ.0) GOTO 550  
1723       P(I,5)=ULMASS(K(I,2)) 
1724       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2  
1725 
1726 C...Final two hadrons: find common setup of four-vectors.   

1727       JQ=1  
1728       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)* 
1729      &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2    
1730       DHC12=dble(FOUR(IN(3*JQ+1),IN(3*JQ+2)))
1731       DHR1=dble(FOUR(N+NRS,IN(3*JQ+2)))/DHC12
1732       DHR2=dble(FOUR(N+NRS,IN(3*JQ+1)))/DHC12
1733       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN 
1734         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ) 
1735         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)   
1736         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*    
1737      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2   
1738       ENDIF 
1739     
1740 C...Solve kinematics for final two hadrons, if possible.    

1741       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2 
1742       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)  
1743       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 180  
1744       IF(FD.GE.1.) GOTO 550 
1745       FA=WREM2+PR(JT)-PR(JR)    
1746       IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(37+MSTJ(11))  
1747       IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-100.,LOG(FD)* 
1748      &PARJ(37+MSTJ(11))*(PR(1)+PR(2))**2))  
1749       FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV)) 
1750       KFL1A=IABS(KFL(1))    
1751       KFL2A=IABS(KFL(2))    
1752       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),    
1753      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-  
1754      &4.*WREM2*PR(JT))),FLOAT(JS))  
1755       DO 820 J=1,4  
1756       P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*   
1757      &P(IN(3*JQ+3)+1,J)+0.5*(sngl(DHR1)*(FA+FB)*P(IN(3*JQ+1),J)+  
1758      &sngl(DHR2)*(FA-FB)*P(IN(3*JQ+2),J))/WREM2   
1759   820 P(I,J)=P(N+NRS,J)-P(I-1,J)    
1760 
1761 C...Mark jets as fragmented and give daughter pointers. 

1762       N=I-NRS+1 
1763       DO 830 I=NSAV+1,NSAV+NP   
1764       IM=K(I,3) 
1765       K(IM,1)=K(IM,1)+10    
1766       IF(MSTU(16).NE.2) THEN    
1767         K(IM,4)=NSAV+1  
1768         K(IM,5)=NSAV+1  
1769       ELSE  
1770         K(IM,4)=NSAV+2  
1771         K(IM,5)=N   
1772       ENDIF 
1773   830 CONTINUE  
1774     
1775 C...Document string system. Move up particles.  

1776       NSAV=NSAV+1   
1777       K(NSAV,1)=11  
1778       K(NSAV,2)=92  
1779       K(NSAV,3)=IP  
1780       K(NSAV,4)=NSAV+1  
1781       K(NSAV,5)=N   
1782       DO 840 J=1,4  
1783       P(NSAV,J)=sngl(DPS(J))
1784   840 V(NSAV,J)=V(IP,J) 
1785       P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
1786      &     -DPS(3)**2)))
1787       V(NSAV,5)=0.
1788       DO 850 I=NSAV+1,N 
1789 
1790       DO 850 J=1,5  
1791       K(I,J)=K(I+NRS-1,J)   
1792       P(I,J)=P(I+NRS-1,J)   
1793   850 V(I,J)=0. 
1794     
1795 C...Order particles in rank along the chain. Update mother pointer. 

1796       DO 860 I=NSAV+1,N 
1797       DO 860 J=1,5  
1798       K(I-NSAV+N,J)=K(I,J)  
1799   860 P(I-NSAV+N,J)=P(I,J)  
1800       I1=NSAV   
1801       DO 880 I=N+1,2*N-NSAV 
1802       IF(K(I,3).NE.IE(1)) GOTO 880  
1803       I1=I1+1   
1804       DO 870 J=1,5  
1805       K(I1,J)=K(I,J)    
1806   870 P(I1,J)=P(I,J)    
1807       IF(MSTU(16).NE.2) K(I1,3)=NSAV    
1808   880 CONTINUE  
1809       DO 900 I=2*N-NSAV,N+1,-1  
1810       IF(K(I,3).EQ.IE(1)) GOTO 900  
1811       I1=I1+1   
1812       DO 890 J=1,5  
1813       K(I1,J)=K(I,J)    
1814   890 P(I1,J)=P(I,J)    
1815       IF(MSTU(16).NE.2) K(I1,3)=NSAV    
1816   900 CONTINUE  
1817     
1818 C...Boost back particle system. Set production vertices.    

1819       CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),   
1820      &DPS(3)/DPS(4))    
1821       DO 910 I=NSAV+1,N 
1822 
1823       DO 910 J=1,4  
1824   910 V(I,J)=V(IP,J)    
1825     
1826       RETURN    
1827       END   
1828     
1829 C*********************************************************************  

1830     
1831       SUBROUTINE LUINDF(IP) 
1832     
1833 C...Purpose: to handle the fragmentation of a jet system (or a single   

1834 C...jet) according to independent fragmentation models. 

1835       IMPLICIT DOUBLE PRECISION(D)  
1836       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
1837       SAVE /LUJETS/ 
1838       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
1839       SAVE /LUDAT1/ 
1840       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
1841       SAVE /LUDAT2/ 
1842       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),    
1843      &KFLO(2),PXO(2),PYO(2),WO(2)   
1844 
1845 C...Reset counters. Identify parton system and take copy. Check flavour.    

1846       NSAV=N    
1847       NJET=0    
1848       KQSUM=0   
1849       DO 100 J=1,5  
1850   100 DPS(J)=0.d0
1851       I=IP-1    
1852   110 I=I+1 
1853       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN 
1854         CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')    
1855         IF(MSTU(21).GE.1) RETURN    
1856       ENDIF 
1857       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110  
1858       KC=LUCOMP(K(I,2)) 
1859       IF(KC.EQ.0) GOTO 110  
1860       KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) 
1861       IF(KQ.EQ.0) GOTO 110  
1862       NJET=NJET+1   
1863       IF(KQ.NE.2) KQSUM=KQSUM+KQ    
1864       DO 120 J=1,5  
1865       K(NSAV+NJET,J)=K(I,J) 
1866       P(NSAV+NJET,J)=P(I,J) 
1867   120 DPS(J)=DPS(J)+dble(P(I,J))
1868       K(NSAV+NJET,3)=I  
1869       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.   
1870      &K(I+1,1).EQ.2)) GOTO 110  
1871       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN 
1872         CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')  
1873         IF(MSTU(21).GE.1) RETURN    
1874       ENDIF 
1875     
1876 C...Boost copied system to CM frame. Find CM energy and sum flavours.   

1877       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),  
1878      &-DPS(2)/DPS(4),-DPS(3)/DPS(4))    
1879       PECM=0.   
1880       DO 130 J=1,3  
1881   130 NFI(J)=0  
1882       DO 140 I=NSAV+1,NSAV+NJET 
1883       PECM=PECM+P(I,4)  
1884       KFA=IABS(K(I,2))  
1885       IF(KFA.LE.3) THEN 
1886         NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))   
1887       ELSEIF(KFA.GT.1000) THEN  
1888         KFLA=MOD(KFA/1000,10)   
1889         KFLB=MOD(KFA/100,10)    
1890         IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))   
1891         IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))   
1892       ENDIF 
1893   140 CONTINUE  
1894     
1895 C...Loop over attempts made. Reset counters.    

1896       NTRY=0    
1897   150 NTRY=NTRY+1   
1898       N=NSAV+NJET   
1899       IF(NTRY.GT.200) THEN  
1900         CALL LUERRM(14,'(LUINDF:) caught in infinite loop') 
1901         IF(MSTU(21).GE.1) RETURN    
1902       ENDIF 
1903       DO 160 J=1,3  
1904       NFL(J)=NFI(J) 
1905       IFET(J)=0 
1906   160 KFLF(J)=0 
1907     
1908 C...Loop over jets to be fragmented.    

1909       DO 230 IP1=NSAV+1,NSAV+NJET   
1910       MSTJ(91)=0    
1911       NSAV1=N   
1912     
1913 C...Initial flavour and momentum values. Jet along +z axis. 

1914       KFLH=IABS(K(IP1,2))   
1915       IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10) 
1916       KFLO(2)=0 
1917       WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2) 
1918     
1919 C...Initial values for quark or diquark jet.    

1920   170 IF(IABS(K(IP1,2)).NE.21) THEN 
1921         NSTR=1  
1922         KFLO(1)=K(IP1,2)    
1923         CALL LUPTDI(0,PXO(1),PYO(1))    
1924         WO(1)=WF    
1925     
1926 C...Initial values for gluon treated like random quark jet. 

1927       ELSEIF(MSTJ(2).LE.2) THEN 
1928         NSTR=1  
1929         IF(MSTJ(2).EQ.2) MSTJ(91)=1 
1930         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)   
1931         CALL LUPTDI(0,PXO(1),PYO(1))    
1932         WO(1)=WF    
1933     
1934 C...Initial values for gluon treated like quark-antiquark jet pair, 

1935 C...sharing energy according to Altarelli-Parisi splitting function.    

1936       ELSE  
1937         NSTR=2  
1938         IF(MSTJ(2).EQ.4) MSTJ(91)=1 
1939         KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)   
1940         KFLO(2)=-KFLO(1)    
1941         CALL LUPTDI(0,PXO(1),PYO(1))    
1942         PXO(2)=-PXO(1)  
1943         PYO(2)=-PYO(1)  
1944         WO(1)=WF*RLU(0)**(1./3.)    
1945         WO(2)=WF-WO(1)  
1946       ENDIF 
1947     
1948 C...Initial values for rank, flavour, pT and W+.    

1949       DO 220 ISTR=1,NSTR    
1950   180 I=N   
1951       IRANK=0   
1952       KFL1=KFLO(ISTR)   
1953       PX1=PXO(ISTR) 
1954       PY1=PYO(ISTR) 
1955       W=WO(ISTR)    
1956     
1957 C...New hadron. Generate flavour and hadron species.    

1958   190 I=I+1 
1959       IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN 
1960         CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')   
1961         IF(MSTU(21).GE.1) RETURN    
1962       ENDIF 
1963       IRANK=IRANK+1 
1964       K(I,1)=1  
1965       K(I,3)=IP1    
1966       K(I,4)=0  
1967       K(I,5)=0  
1968   200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))   
1969       IF(K(I,2).EQ.0) GOTO 180  
1970       IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND. 
1971      &IABS(KFL2).GT.10) THEN    
1972         IF(RLU(0).GT.PARJ(19)) GOTO 200 
1973       ENDIF 
1974     
1975 C...Find hadron mass. Generate four-momentum.   

1976       P(I,5)=ULMASS(K(I,2)) 
1977       CALL LUPTDI(KFL1,PX2,PY2) 
1978       P(I,1)=PX1+PX2    
1979       P(I,2)=PY1+PY2    
1980       PR=P(I,5)**2+P(I,1)**2+P(I,2)**2  
1981       CALL LUZDIS(KFL1,KFL2,PR,Z)   
1982       P(I,3)=0.5*(Z*W-PR/(Z*W)) 
1983       P(I,4)=0.5*(Z*W+PR/(Z*W)) 
1984       IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND. 
1985      &P(I,3).LE.0.001) THEN 
1986         IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180   
1987         P(I,3)=0.0001   
1988         P(I,4)=SQRT(PR) 
1989         Z=P(I,4)/W  
1990       ENDIF 
1991     
1992 C...Remaining flavour and momentum. 

1993       KFL1=-KFL2    
1994       PX1=-PX2  
1995       PY1=-PY2  
1996       W=(1.-Z)*W    
1997       DO 210 J=1,5  
1998   210 V(I,J)=0. 
1999     
2000 C...Check if pL acceptable. Go back for new hadron if enough energy.    

2001       IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) I=I-1   
2002       IF(W.GT.PARJ(31)) GOTO 190    
2003   220 N=I   
2004       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32) 
2005       IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170   
2006     
2007 C...Rotate jet to new direction.    

2008       THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))    
2009       PHI=ULANGL(P(IP1,1),P(IP1,2)) 
2010       CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)    
2011       K(K(IP1,3),4)=NSAV1+1 
2012       K(K(IP1,3),5)=N   
2013     
2014 C...End of jet generation loop. Skip conservation in some cases.    

2015   230 CONTINUE  
2016       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470    
2017       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150 
2018     
2019 C...Subtract off produced hadron flavours, finished if zero.    

2020       DO 240 I=NSAV+NJET+1,N    
2021       KFA=IABS(K(I,2))  
2022       KFLA=MOD(KFA/1000,10) 
2023       KFLB=MOD(KFA/100,10)  
2024       KFLC=MOD(KFA/10,10)   
2025       IF(KFLA.EQ.0) THEN    
2026         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB    
2027         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB    
2028       ELSE  
2029         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))   
2030         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))   
2031         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))   
2032       ENDIF 
2033   240 CONTINUE  
2034       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ 
2035      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3    
2036       IF(NREQ.EQ.0) GOTO 320    
2037     
2038 C...Take away flavour of low-momentum particles until enough freedom.   

2039       NREM=0    
2040   250 IREM=0    
2041       P2MIN=PECM**2 
2042       DO 260 I=NSAV+NJET+1,N    
2043       P2=P(I,1)**2+P(I,2)**2+P(I,3)**2  
2044       IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I    
2045   260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2  
2046       IF(IREM.EQ.0) GOTO 150    
2047       K(IREM,1)=7   
2048       KFA=IABS(K(IREM,2))   
2049       KFLA=MOD(KFA/1000,10) 
2050       KFLB=MOD(KFA/100,10)  
2051       KFLC=MOD(KFA/10,10)   
2052       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8    
2053       IF(K(IREM,1).EQ.8) GOTO 250   
2054       IF(KFLA.EQ.0) THEN    
2055         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB  
2056         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN  
2057         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN  
2058       ELSE  
2059         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))    
2060         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))    
2061         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))    
2062       ENDIF 
2063       NREM=NREM+1   
2064       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ 
2065      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3    
2066       IF(NREQ.GT.NREM) GOTO 250 
2067       DO 270 I=NSAV+NJET+1,N    
2068   270 IF(K(I,1).EQ.8) K(I,1)=1  
2069     
2070 C...Find combination of existing and new flavours for hadron.   

2071   280 NFET=2    
2072       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3  
2073       IF(NREQ.LT.NREM) NFET=1   
2074       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0    
2075       DO 290 J=1,NFET   
2076       IFET(J)=1+int((IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0))
2077       KFLF(J)=ISIGN(1,NFL(1))   
2078       IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))   
2079   290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))  
2080       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))    
2081      &GOTO 280  
2082       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.    
2083      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).    
2084      &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280    
2085       IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))  
2086       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)    
2087       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))  
2088       IF(NFET.LE.2) KFLF(3)=0   
2089       IF(KFLF(3).NE.0) THEN 
2090         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+  
2091      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1)) 
2092         IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)  
2093      &  KFLFC=KFLFC+ISIGN(2,KFLFC)  
2094       ELSE  
2095         KFLFC=KFLF(1)   
2096       ENDIF 
2097       CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)  
2098       IF(KF.EQ.0) GOTO 280  
2099       DO 300 J=1,MAX(2,NFET)    
2100   300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))    
2101     
2102 C...Store hadron at random among free positions.    

2103       NPOS=MIN(1+INT(RLU(0)*NREM),NREM) 
2104       DO 310 I=NSAV+NJET+1,N    
2105       IF(K(I,1).EQ.7) NPOS=NPOS-1   
2106       IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310 
2107       K(I,1)=1  
2108       K(I,2)=KF 
2109       P(I,5)=ULMASS(K(I,2)) 
2110       P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)  
2111   310 CONTINUE  
2112       NREM=NREM-1   
2113       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ 
2114      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3    
2115       IF(NREM.GT.0) GOTO 280    
2116     
2117 C...Compensate for missing momentum in global scheme (3 options).   

2118   320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN  
2119         DO 330 J=1,3    
2120         PSI(J)=0.   
2121         DO 330 I=NSAV+NJET+1,N  
2122   330   PSI(J)=PSI(J)+P(I,J)    
2123         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2    
2124         PWS=0.  
2125         DO 340 I=NSAV+NJET+1,N  
2126         IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)  
2127         IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+  
2128      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) 
2129   340   IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.  
2130 cms..preinitialize

2131         PW=0.
2132         DO 360 I=NSAV+NJET+1,N  
2133         IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)   
2134         IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+   
2135      &  PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) 
2136         IF(MOD(MSTJ(3),5).EQ.3) PW=1.   
2137         DO 350 J=1,3    
2138   350   P(I,J)=P(I,J)-PSI(J)*PW/PWS 
2139   360   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)    
2140     
2141 C...Compensate for missing momentum withing each jet separately.    

2142       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN  
2143         DO 370 I=N+1,N+NJET 
2144         K(I,1)=0    
2145         DO 370 J=1,5    
2146   370   P(I,J)=0.   
2147         DO 390 I=NSAV+NJET+1,N  
2148         IR1=K(I,3)  
2149         IR2=N+IR1-NSAV  
2150         K(IR2,1)=K(IR2,1)+1 
2151         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/  
2152      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)   
2153         DO 380 J=1,3    
2154   380   P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)   
2155         P(IR2,4)=P(IR2,4)+P(I,4)    
2156   390   P(IR2,5)=P(IR2,5)+PLS   
2157         PSS=0.  
2158         DO 400 I=N+1,N+NJET 
2159   400   IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))  
2160         DO 420 I=NSAV+NJET+1,N  
2161         IR1=K(I,3)  
2162         IR2=N+IR1-NSAV  
2163         PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/  
2164      &  (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)   
2165         DO 410 J=1,3    
2166   410   P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS* 
2167      &  P(IR1,J)    
2168   420   P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)    
2169       ENDIF 
2170     
2171 C...Scale momenta for energy conservation.  

2172       IF(MOD(MSTJ(3),5).NE.0) THEN  
2173         PMS=0.  
2174         PES=0.  
2175         PQS=0.  
2176         DO 430 I=NSAV+NJET+1,N  
2177         PMS=PMS+P(I,5)  
2178         PES=PES+P(I,4)  
2179   430   PQS=PQS+P(I,5)**2/P(I,4)    
2180         IF(PMS.GE.PECM) GOTO 150    
2181         NECO=0  
2182   440   NECO=NECO+1 
2183         PFAC=(PECM-PQS)/(PES-PQS)   
2184         PES=0.  
2185         PQS=0.  
2186         DO 460 I=NSAV+NJET+1,N  
2187         DO 450 J=1,3    
2188   450   P(I,J)=PFAC*P(I,J)  
2189         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)    
2190         PES=PES+P(I,4)  
2191   460   PQS=PQS+P(I,5)**2/P(I,4)    
2192         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440  
2193       ENDIF 
2194     
2195 C...Origin of produced particles and parton daughter pointers.  

2196   470 DO 480 I=NSAV+NJET+1,N    
2197       IF(MSTU(16).NE.2) K(I,3)=NSAV+1   
2198   480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)  
2199       DO 490 I=NSAV+1,NSAV+NJET 
2200       I1=K(I,3) 
2201       K(I1,1)=K(I1,1)+10    
2202       IF(MSTU(16).NE.2) THEN    
2203         K(I1,4)=NSAV+1  
2204         K(I1,5)=NSAV+1  
2205       ELSE  
2206         K(I1,4)=K(I1,4)-NJET+1  
2207         K(I1,5)=K(I1,5)-NJET+1  
2208         IF(K(I1,5).LT.K(I1,4)) THEN 
2209           K(I1,4)=0 
2210           K(I1,5)=0 
2211         ENDIF   
2212       ENDIF 
2213   490 CONTINUE  
2214     
2215 C...Document independent fragmentation system. Remove copy of jets. 

2216       NSAV=NSAV+1   
2217       K(NSAV,1)=11  
2218       K(NSAV,2)=93  
2219       K(NSAV,3)=IP  
2220       K(NSAV,4)=NSAV+1  
2221       K(NSAV,5)=N-NJET+1    
2222       DO 500 J=1,4  
2223       P(NSAV,J)=sngl(DPS(J))
2224   500 V(NSAV,J)=V(IP,J) 
2225       P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
2226      &     -DPS(3)**2)))
2227       V(NSAV,5)=0.  
2228       DO 510 I=NSAV+NJET,N  
2229       DO 510 J=1,5  
2230       K(I-NJET+1,J)=K(I,J)  
2231       P(I-NJET+1,J)=P(I,J)  
2232   510 V(I-NJET+1,J)=V(I,J)  
2233       N=N-NJET+1    
2234     
2235 C...Boost back particle system. Set production vertices.    

2236       IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),   
2237      &DPS(2)/DPS(4),DPS(3)/DPS(4))  
2238       DO 520 I=NSAV+1,N 
2239       DO 520 J=1,4  
2240   520 V(I,J)=V(IP,J)    
2241     
2242       RETURN    
2243       END   
2244     
2245 C*********************************************************************  

2246     
2247       SUBROUTINE LUDECY(IP) 
2248     
2249 C...Purpose: to handle the decay of unstable particles. 

2250       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
2251       SAVE /LUJETS/ 
2252       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
2253       SAVE /LUDAT1/ 
2254       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
2255       SAVE /LUDAT2/ 
2256       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
2257       SAVE /LUDAT3/ 
2258       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),  
2259      &WTCOR(10) 
2260 clin-2/18/03 for resonance decay in hadron cascade:

2261       common/resdcy/NSAV,iksdcy
2262       SAVE /resdcy/
2263       DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./ 
2264     
2265 C...Functions: momentum in two-particle decays, four-product and    

2266 C...matrix element times phase space in weak decays.    

2267       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)  
2268       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) 
2269       HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))* 
2270      &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)    
2271     
2272 C...Initial values. 

2273       NTRY=0    
2274       NSAV=N    
2275       KFA=IABS(K(IP,2)) 
2276       KFS=ISIGN(1,K(IP,2))  
2277       KC=LUCOMP(KFA)    
2278       MSTJ(92)=0    
2279     
2280 C...Choose lifetime and determine decay vertex. 

2281       IF(K(IP,1).EQ.5) THEN 
2282         V(IP,5)=0.  
2283       ELSEIF(K(IP,1).NE.4) THEN 
2284         V(IP,5)=-PMAS(KC,4)*LOG(RLU(0)) 
2285       ENDIF 
2286       DO 100 J=1,4  
2287   100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)   
2288     
2289 C...Determine whether decay allowed or not. 

2290       MOUT=0    
2291       IF(MSTJ(22).EQ.2) THEN    
2292         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1   
2293       ELSEIF(MSTJ(22).EQ.3) THEN    
2294         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1  
2295       ELSEIF(MSTJ(22).EQ.4) THEN    
2296         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 
2297         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 
2298       ENDIF 
2299       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN   
2300         K(IP,1)=4   
2301         RETURN  
2302       ENDIF 
2303     
2304 C...Check existence of decay channels. Particle/antiparticle rules. 

2305       KCA=KC    
2306       IF(MDCY(KC,2).GT.0) THEN  
2307         MDMDCY=MDME(MDCY(KC,2),2)   
2308         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY    
2309       ENDIF 
2310       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN 
2311         CALL LUERRM(9,'(LUDECY:) no decay channel defined') 
2312         RETURN  
2313       ENDIF 
2314       IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS   
2315       IF(KCHG(KC,3).EQ.0) THEN  
2316         KFSP=1  
2317         KFSN=0  
2318         IF(RLU(0).GT.0.5) KFS=-KFS  
2319       ELSEIF(KFS.GT.0) THEN 
2320         KFSP=1  
2321         KFSN=0  
2322       ELSE  
2323         KFSP=0  
2324         KFSN=1  
2325       ENDIF 
2326     
2327 C...Sum branching ratios of allowed decay channels. 

2328 clin  110 NOPE=0    

2329       NOPE=0    
2330       BRSU=0.   
2331       DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1  
2332       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.    
2333      &KFSN*MDME(IDL,1).NE.3) GOTO 120   
2334       IF(MDME(IDL,2).GT.100) GOTO 120   
2335       NOPE=NOPE+1   
2336       BRSU=BRSU+BRAT(IDL)   
2337   120 CONTINUE  
2338       IF(NOPE.EQ.0) THEN    
2339         CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')    
2340         RETURN  
2341       ENDIF 
2342     
2343 C...Select decay channel among allowed ones.    

2344   130 RBR=BRSU*RLU(0)   
2345       IDL=MDCY(KCA,2)-1 
2346 cms.. preinitialize..

2347       IDC=0.
2348   140 IDL=IDL+1 
2349       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.    
2350      &KFSN*MDME(IDL,1).NE.3) THEN   
2351         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140   
2352       ELSEIF(MDME(IDL,2).GT.100) THEN   
2353         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140   
2354       ELSE  
2355         IDC=IDL 
2356         RBR=RBR-BRAT(IDL)   
2357         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140 
2358       ENDIF 
2359     
2360 C...Start readout of decay channel: matrix element, reset counters. 

2361       MMAT=MDME(IDC,2)  
2362   150 NTRY=NTRY+1   
2363       IF(NTRY.GT.1000) THEN 
2364         CALL LUERRM(14,'(LUDECY:) caught in infinite loop') 
2365         IF(MSTU(21).GE.1) RETURN    
2366       ENDIF 
2367       I=N   
2368       NP=0  
2369       NQ=0  
2370       MBST=0    
2371       IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1   
2372       DO 160 J=1,4  
2373       PV(1,J)=0.    
2374   160 IF(MBST.EQ.0) PV(1,J)=P(IP,J) 
2375       IF(MBST.EQ.1) PV(1,4)=P(IP,5) 
2376       PV(1,5)=P(IP,5)   
2377       PS=0. 
2378       PSQ=0.    
2379       MREM=0    
2380     
2381 C...Read out decay products. Convert to standard flavour code.  

2382       JTMAX=5   
2383       IF(MDME(IDC+1,2).EQ.101) JTMAX=10 
2384       DO 170 JT=1,JTMAX 
2385       IF(JT.LE.5) KP=KFDP(IDC,JT)   
2386       IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)   
2387       IF(KP.EQ.0) GOTO 170  
2388       KPA=IABS(KP)  
2389       KCP=LUCOMP(KPA)   
2390       IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN 
2391         KFP=KP  
2392       ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN  
2393         KFP=KFS*KP  
2394       ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN  
2395         KFP=-KFS*MOD(KFA/10,10) 
2396       ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN  
2397         KFP=KFS*(100*MOD(KFA/10,100)+3) 
2398       ELSEIF(KPA.EQ.81) THEN    
2399         KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1) 
2400       ELSEIF(KP.EQ.82) THEN 
2401         CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)   
2402         IF(KFP.EQ.0) GOTO 150   
2403         MSTJ(93)=1  
2404         IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150 
2405       ELSEIF(KP.EQ.-82) THEN    
2406         KFP=-KFP    
2407         IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)    
2408       ENDIF 
2409       IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)    
2410     
2411 C...Add decay product to event record or to quark flavour list. 

2412       KFPA=IABS(KFP)    
2413       KQP=KCHG(KCP,2)   
2414       IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN   
2415         NQ=NQ+1 
2416         KFLO(NQ)=KFP    
2417         MSTJ(93)=2  
2418         PSQ=PSQ+ULMASS(KFLO(NQ))    
2419       ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)  
2420      &THEN  
2421         NQ=NQ-1 
2422         PS=PS-P(I,5)    
2423         K(I,1)=1    
2424         KFI=K(I,2)  
2425         CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))  
2426         IF(K(I,2).EQ.0) GOTO 150    
2427         MSTJ(93)=1  
2428         P(I,5)=ULMASS(K(I,2))   
2429         PS=PS+P(I,5)    
2430       ELSE  
2431         I=I+1   
2432         NP=NP+1 
2433         IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1 
2434         IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1    
2435         K(I,1)=1+MOD(NQ,2)  
2436         IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2    
2437         IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1  
2438         K(I,2)=KFP  
2439         K(I,3)=IP   
2440         K(I,4)=0    
2441         K(I,5)=0    
2442         P(I,5)=ULMASS(KFP)  
2443         IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)   
2444         PS=PS+P(I,5)    
2445       ENDIF 
2446   170 CONTINUE  
2447     
2448 C...Choose decay multiplicity in phase space model. 

2449 cms.. preinitialize

2450       PQT=0.
2451 
2452   180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN    
2453         PSP=PS  
2454         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))   
2455         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)   
2456   190   NTRY=NTRY+1 
2457         IF(NTRY.GT.1000) THEN   
2458           CALL LUERRM(14,'(LUDECY:) caught in infinite loop')   
2459           IF(MSTU(21).GE.1) RETURN  
2460         ENDIF   
2461         IF(MMAT.LE.20) THEN 
2462           GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*  
2463      &    SIN(PARU(2)*RLU(0))   
2464           ND=int(0.5+0.5*NP+0.25*NQ+CNDE+GAUSS)
2465           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190 
2466           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190   
2467           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190   
2468           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190   
2469         ELSE    
2470           ND=MMAT-20    
2471         ENDIF   
2472     
2473 C...Form hadrons from flavour content.  

2474         DO 200 JT=1,4   
2475   200   KFL1(JT)=KFLO(JT)   
2476         IF(ND.EQ.NP+NQ/2) GOTO 220  
2477         DO 210 I=N+NP+1,N+ND-NQ/2   
2478         JT=1+INT((NQ-1)*RLU(0)) 
2479         CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2)) 
2480         IF(K(I,2).EQ.0) GOTO 190    
2481   210   KFL1(JT)=-KFL2  
2482   220   JT=2    
2483         JT2=3   
2484         JT3=4   
2485         IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4 
2486         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))* 
2487      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3    
2488         IF(JT.EQ.3) JT2=2   
2489         IF(JT.EQ.4) JT3=2   
2490         CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))   
2491         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190  
2492         IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))   
2493         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190 
2494     
2495 C...Check that sum of decay product masses not too large.   

2496         PS=PSP  
2497         DO 230 I=N+NP+1,N+ND    
2498         K(I,1)=1    
2499         K(I,3)=IP   
2500         K(I,4)=0    
2501         K(I,5)=0    
2502         P(I,5)=ULMASS(K(I,2))   
2503   230   PS=PS+P(I,5)    
2504         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190 
2505     
2506 C...Rescale energy to subtract off spectator quark mass.    

2507       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).    
2508      &AND.NP.GE.3) THEN 
2509         PS=PS-P(N+NP,5) 
2510         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)    
2511         DO 240 J=1,5    
2512         P(N+NP,J)=PQT*PV(1,J)   
2513   240   PV(1,J)=(1.-PQT)*PV(1,J)    
2514         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150 
2515         ND=NP-1 
2516         MREM=1  
2517     
2518 C...Phase space factors imposed in W decay. 

2519       ELSEIF(MMAT.EQ.46) THEN   
2520         MSTJ(93)=1  
2521         PSMC=ULMASS(K(N+1,2))   
2522         MSTJ(93)=1  
2523         PSMC=PSMC+ULMASS(K(N+2,2))  
2524         IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130   
2525         HR1=(P(N+1,5)/PV(1,5))**2   
2526         HR2=(P(N+2,5)/PV(1,5))**2   
2527         IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).  
2528      &  LT.2.*RLU(0)) GOTO 130  
2529         ND=NP   
2530     
2531 C...Fully specified final state: check mass broadening effects. 

2532       ELSE  
2533         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150 
2534         ND=NP   
2535       ENDIF 
2536     
2537 C...Select W mass in decay Q -> W + q, without W propagator.    

2538       IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN 
2539         HLQ=(PARJ(32)/PV(1,5))**2   
2540         HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2 
2541         HRQ=(P(N+2,5)/PV(1,5))**2   
2542   250   HW=HLQ+RLU(0)*(HUQ-HLQ) 
2543         IF(HMEPS(HW).LT.RLU(0)) GOTO 250    
2544         P(N+1,5)=PV(1,5)*SQRT(HW)   
2545     
2546 C...Ditto, including W propagator. Divide mass range into three regions.    

2547       ELSEIF(MMAT.EQ.45) THEN   
2548         HQW=(PV(1,5)/PMAS(24,1))**2 
2549         HLW=(PARJ(32)/PMAS(24,1))**2    
2550         HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2 
2551         HRQ=(P(N+2,5)/PV(1,5))**2   
2552         HG=PMAS(24,2)/PMAS(24,1)    
2553         HATL=ATAN((HLW-1.)/HG)  
2554         HM=MIN(1.,HUW-0.001)    
2555         HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)   
2556   260   HM=HM-HG    
2557         HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)   
2558         HSAV1=HMEPS(HM/HQW) 
2559         HSAV2=1./((HM-1.)**2+HG**2) 
2560         IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN  
2561           HMV1=HMV2 
2562           GOTO 260  
2563         ENDIF   
2564         HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)    
2565         HM1=1.-SQRT(1./HMV-HG**2)   
2566         IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN   
2567           HM=HM1    
2568         ELSEIF(HMV2.LE.HMV1) THEN   
2569           HM=MAX(HLW,HM-MIN(0.1,1.-HM)) 
2570         ENDIF   
2571         HATM=ATAN((HM-1.)/HG)   
2572         HWT1=(HATM-HATL)/HG 
2573         HWT2=HMV*(MIN(1.,HUW)-HM)   
2574         HWT3=0. 
2575 cms.. preinitialize..

2576         HMP1=0.
2577         HATU=0.
2578         IF(HUW.GT.1.) THEN  
2579           HATU=ATAN((HUW-1.)/HG)    
2580           HMP1=HMEPS(1./HQW)    
2581           HWT3=HMP1*HATU/HG 
2582         ENDIF   
2583     
2584 C...Select mass region and W mass there. Accept according to weight.    

2585   270   HREG=RLU(0)*(HWT1+HWT2+HWT3)    
2586         IF(HREG.LE.HWT1) THEN   
2587           HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL)) 
2588           HACC=HMEPS(HW/HQW)    
2589         ELSEIF(HREG.LE.HWT1+HWT2) THEN  
2590           HW=HM+RLU(0)*(MIN(1.,HUW)-HM) 
2591           HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV 
2592         ELSE    
2593           HW=1.+HG*TAN(RLU(0)*HATU) 
2594           HACC=HMEPS(HW/HQW)/HMP1   
2595         ENDIF   
2596         IF(HACC.LT.RLU(0)) GOTO 270 
2597         P(N+1,5)=PMAS(24,1)*SQRT(HW)    
2598       ENDIF 
2599     
2600 C...Determine position of grandmother, number of sisters, Q -> W sign.  

2601       NM=0  
2602       MSGN=0    
2603 cms..preinitialize

2604       IM=0
2605       IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN  
2606         IM=K(IP,3)  
2607         IF(IM.LT.0.OR.IM.GE.IP) IM=0    
2608         IF(IM.NE.0) KFAM=IABS(K(IM,2))  
2609         IF(IM.NE.0.AND.MMAT.EQ.3) THEN  
2610           DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)  
2611   280     IF(K(IL,3).EQ.IM) NM=NM+1 
2612           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.    
2613      &    MOD(KFAM/1000,10).NE.0) NM=0  
2614         ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN 
2615           MSGN=ISIGN(1,K(IM,2)*K(IP,2)) 
2616           IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=  
2617      &    MSGN*(-1)**MOD(KFAM/100,10)   
2618         ENDIF   
2619       ENDIF 
2620     
2621 C...Kinematics of one-particle decays.  

2622       IF(ND.EQ.1) THEN  
2623         DO 290 J=1,4    
2624   290   P(N+1,J)=P(IP,J)    
2625         GOTO 510    
2626       ENDIF 
2627     
2628 C...Calculate maximum weight ND-particle decay. 

2629       PV(ND,5)=P(N+ND,5)    
2630 cms .. preinitialize...

2631       WTMAX=1.
2632       IF(ND.GE.3) THEN  
2633         WTMAX=1./WTCOR(ND-2)    
2634         PMAX=PV(1,5)-PS+P(N+ND,5)   
2635         PMIN=0. 
2636         DO 300 IL=ND-1,1,-1 
2637         PMAX=PMAX+P(N+IL,5) 
2638         PMIN=PMIN+P(N+IL+1,5)   
2639   300   WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))   
2640       ENDIF 
2641     
2642 C...Find virtual gamma mass in Dalitz decay.    

2643 cms.. preinitialize..

2644       PMST=0.
2645       PMES=0.
2646   310 IF(ND.EQ.2) THEN  
2647       ELSEIF(MMAT.EQ.2) THEN    
2648         PMES=4.*PMAS(11,1)**2   
2649         PMRHO2=PMAS(131,1)**2   
2650         PGRHO2=PMAS(131,2)**2   
2651   320   PMST=PMES*(P(IP,5)**2/PMES)**RLU(0) 
2652         WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*    
2653      &  (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/ 
2654      &  ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2) 
2655         IF(WT.LT.RLU(0)) GOTO 320   
2656         PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))  
2657     
2658 C...M-generator gives weight. If rejected, try again.   

2659       ELSE  
2660   330   RORD(1)=1.  
2661         DO 350 IL1=2,ND-1   
2662         RSAV=RLU(0) 
2663         DO 340 IL2=IL1-1,1,-1   
2664         IF(RSAV.LE.RORD(IL2)) GOTO 350  
2665   340   RORD(IL2+1)=RORD(IL2)   
2666   350   RORD(IL2+1)=RSAV    
2667         RORD(ND)=0. 
2668         WT=1.   
2669         DO 360 IL=ND-1,1,-1 
2670         PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)    
2671   360   WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))   
2672         IF(WT.LT.RLU(0)*WTMAX) GOTO 330 
2673       ENDIF 
2674     
2675 C...Perform two-particle decays in respective CM frame. 

2676   370 DO 390 IL=1,ND-1  
2677       PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))    
2678       UE(3)=2.*RLU(0)-1.    
2679       PHI=PARU(2)*RLU(0)    
2680       UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)  
2681       UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)  
2682       DO 380 J=1,3  
2683       P(N+IL,J)=PA*UE(J)    
2684   380 PV(IL+1,J)=-PA*UE(J)  
2685       P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)    
2686   390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)  
2687     
2688 C...Lorentz transform decay products to lab frame.  

2689       DO 400 J=1,4  
2690   400 P(N+ND,J)=PV(ND,J)    
2691       DO 430 IL=ND-1,1,-1   
2692       DO 410 J=1,3  
2693   410 BE(J)=PV(IL,J)/PV(IL,4)   
2694       GA=PV(IL,4)/PV(IL,5)  
2695       DO 430 I=N+IL,N+ND    
2696       BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)    
2697       DO 420 J=1,3  
2698   420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)    
2699   430 P(I,4)=GA*(P(I,4)+BEP)    
2700     
2701 C...Matrix elements for omega and phi decays.   

2702       IF(MMAT.EQ.1) THEN    
2703         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2  
2704      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2    
2705      &  +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)   
2706         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310    
2707     
2708 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. 

2709       ELSEIF(MMAT.EQ.2) THEN    
2710         FOUR12=FOUR(N+1,N+2)    
2711         FOUR13=FOUR(N+1,N+3)    
2712         FOUR23=0.5*PMST-0.25*PMES   
2713         WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+   
2714      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)    
2715         IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370    
2716     
2717 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, 

2718 C...V vector), of form cos**2(theta02) in V1 rest frame.    

2719       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN    
2720         IF((P(IP,5)**2*FOUR(IM,N+1)-FOUR(IP,IM)*FOUR(IP,N+1))**2.LE.    
2721      &  RLU(0)*(FOUR(IP,IM)**2-(P(IP,5)*P(IM,5))**2)*(FOUR(IP,N+1)**2-  
2722      &  (P(IP,5)*P(N+1,5))**2)) GOTO 370    
2723     
2724 C...Matrix element for "onium" -> g + g + g or gamma + g + g.   

2725       ELSEIF(MMAT.EQ.4) THEN    
2726         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2  
2727         HX2=2.*FOUR(IP,N+2)/P(IP,5)**2  
2728         HX3=2.*FOUR(IP,N+3)/P(IP,5)**2  
2729         WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+ 
2730      &  ((1.-HX3)/(HX1*HX2))**2 
2731         IF(WT.LT.2.*RLU(0)) GOTO 310    
2732         IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)   
2733      &  GOTO 310    
2734     
2735 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.    

2736       ELSEIF(MMAT.EQ.41) THEN   
2737         HX1=2.*FOUR(IP,N+1)/P(IP,5)**2  
2738         IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310    
2739     
2740 C...Matrix elements for weak decays (only semileptonic for c and b) 

2741       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN    
2742         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3) 
2743         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3) 
2744         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310  
2745       ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN    
2746         DO 440 J=1,4    
2747         P(N+NP+1,J)=0.  
2748         DO 440 IS=N+3,N+NP  
2749   440   P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J) 
2750         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)  
2751         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)  
2752         IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310  
2753     
2754 C...Angular distribution in W decay.    

2755       ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN 
2756         IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)    
2757         IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)    
2758         IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370  
2759       ENDIF 
2760     
2761 C...Scale back energy and reattach spectator.   

2762       IF(MREM.EQ.1) THEN    
2763         DO 450 J=1,5    
2764   450   PV(1,J)=PV(1,J)/(1.-PQT)    
2765         ND=ND+1 
2766         MREM=0  
2767       ENDIF 
2768     
2769 C...Low invariant mass for system with spectator quark gives particle,  

2770 C...not two jets. Readjust momenta accordingly. 

2771       IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN   
2772         MSTJ(93)=1  
2773         PM2=ULMASS(K(N+2,2))    
2774         MSTJ(93)=1  
2775         PM3=ULMASS(K(N+3,2))    
2776         IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE. 
2777      &  (PARJ(32)+PM2+PM3)**2) GOTO 510 
2778         K(N+2,1)=1  
2779         KFTEMP=K(N+2,2) 
2780         CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))    
2781         IF(K(N+2,2).EQ.0) GOTO 150  
2782         P(N+2,5)=ULMASS(K(N+2,2))   
2783         PS=P(N+1,5)+P(N+2,5)    
2784         PV(2,5)=P(N+2,5)    
2785         MMAT=0  
2786         ND=2    
2787         GOTO 370    
2788       ELSEIF(MMAT.EQ.44) THEN   
2789         MSTJ(93)=1  
2790         PM3=ULMASS(K(N+3,2))    
2791         MSTJ(93)=1  
2792         PM4=ULMASS(K(N+4,2))    
2793         IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE. 
2794      &  (PARJ(32)+PM3+PM4)**2) GOTO 480 
2795         K(N+3,1)=1  
2796         KFTEMP=K(N+3,2) 
2797         CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))    
2798         IF(K(N+3,2).EQ.0) GOTO 150  
2799         P(N+3,5)=ULMASS(K(N+3,2))   
2800         DO 460 J=1,3    
2801   460   P(N+3,J)=P(N+3,J)+P(N+4,J)  
2802         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)  
2803         HA=P(N+1,4)**2-P(N+2,4)**2  
2804         HB=HA-(P(N+1,5)**2-P(N+2,5)**2) 
2805         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+   
2806      &  (P(N+1,3)-P(N+2,3))**2  
2807         HD=(PV(1,4)-P(N+3,4))**2    
2808         HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2  
2809         HF=HD*HC-HB**2  
2810         HG=HD*HC-HA*HB  
2811         HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)   
2812         DO 470 J=1,3    
2813         PCOR=HH*(P(N+1,J)-P(N+2,J)) 
2814         P(N+1,J)=P(N+1,J)+PCOR  
2815   470   P(N+2,J)=P(N+2,J)-PCOR  
2816         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)  
2817         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)  
2818         ND=ND-1 
2819       ENDIF 
2820     
2821 C...Check invariant mass of W jets. May give one particle or start over.    

2822   480 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN   
2823         PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))  
2824         MSTJ(93)=1  
2825         PM1=ULMASS(K(N+1,2))    
2826         MSTJ(93)=1  
2827         PM2=ULMASS(K(N+2,2))    
2828         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 490    
2829         KFLDUM=INT(1.5+RLU(0))  
2830         CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)    
2831         CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)    
2832         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150   
2833         PSM=ULMASS(KF1)+ULMASS(KF2) 
2834         IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 490 
2835         IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 490 
2836         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150   
2837         K(N+1,1)=1  
2838         KFTEMP=K(N+1,2) 
2839         CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))    
2840         IF(K(N+1,2).EQ.0) GOTO 150  
2841         P(N+1,5)=ULMASS(K(N+1,2))   
2842         K(N+2,2)=K(N+3,2)   
2843         P(N+2,5)=P(N+3,5)   
2844         PS=P(N+1,5)+P(N+2,5)    
2845         PV(2,5)=P(N+3,5)    
2846         MMAT=0  
2847         ND=2    
2848         GOTO 370    
2849       ENDIF 
2850     
2851 C...Phase space decay of partons from W decay. 

2852 cms.. preinitialize - should never get called - for compiler only

2853       PMR=0.
2854   490 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN  
2855         KFLO(1)=K(N+1,2)    
2856         KFLO(2)=K(N+2,2)    
2857         K(N+1,1)=K(N+3,1)   
2858         K(N+1,2)=K(N+3,2)   
2859         DO 500 J=1,5    
2860         PV(1,J)=P(N+1,J)+P(N+2,J)   
2861   500   P(N+1,J)=P(N+3,J)   
2862         PV(1,5)=PMR 
2863         N=N+1   
2864         NP=0    
2865         NQ=2    
2866         PS=0.   
2867         MSTJ(93)=2  
2868         PSQ=ULMASS(KFLO(1)) 
2869         MSTJ(93)=2  
2870         PSQ=PSQ+ULMASS(KFLO(2)) 
2871         MMAT=11 
2872         GOTO 180    
2873       ENDIF 
2874     
2875 C...Boost back for rapidly moving particle. 

2876   510 N=N+ND    
2877       IF(MBST.EQ.1) THEN    
2878         DO 520 J=1,3    
2879   520   BE(J)=P(IP,J)/P(IP,4)   
2880         GA=P(IP,4)/P(IP,5)  
2881         DO 540 I=NSAV+1,N   
2882         BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)  
2883         DO 530 J=1,3    
2884   530   P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)  
2885   540   P(I,4)=GA*(P(I,4)+BEP)  
2886       ENDIF 
2887     
2888 C...Fill in position of decay vertex.   

2889       DO 560 I=NSAV+1,N 
2890       DO 550 J=1,4  
2891   550 V(I,J)=VDCY(J)    
2892   560 V(I,5)=0. 
2893     
2894 C...Set up for parton shower evolution from jets.   

2895       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN    
2896         K(NSAV+1,1)=3   
2897         K(NSAV+2,1)=3   
2898         K(NSAV+3,1)=3   
2899         K(NSAV+1,4)=MSTU(5)*(NSAV+2)    
2900         K(NSAV+1,5)=MSTU(5)*(NSAV+3)    
2901         K(NSAV+2,4)=MSTU(5)*(NSAV+3)    
2902         K(NSAV+2,5)=MSTU(5)*(NSAV+1)    
2903         K(NSAV+3,4)=MSTU(5)*(NSAV+1)    
2904         K(NSAV+3,5)=MSTU(5)*(NSAV+2)    
2905         MSTJ(92)=-(NSAV+1)  
2906       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN  
2907         K(NSAV+2,1)=3   
2908         K(NSAV+3,1)=3   
2909         K(NSAV+2,4)=MSTU(5)*(NSAV+3)    
2910         K(NSAV+2,5)=MSTU(5)*(NSAV+3)    
2911         K(NSAV+3,4)=MSTU(5)*(NSAV+2)    
2912         K(NSAV+3,5)=MSTU(5)*(NSAV+2)    
2913         MSTJ(92)=NSAV+2 
2914       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).    
2915      &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN 
2916         K(NSAV+1,1)=3   
2917         K(NSAV+2,1)=3   
2918         K(NSAV+1,4)=MSTU(5)*(NSAV+2)    
2919         K(NSAV+1,5)=MSTU(5)*(NSAV+2)    
2920         K(NSAV+2,4)=MSTU(5)*(NSAV+1)    
2921         K(NSAV+2,5)=MSTU(5)*(NSAV+1)    
2922         MSTJ(92)=NSAV+1 
2923       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)  
2924      &THEN  
2925         K(NSAV+1,1)=3   
2926         K(NSAV+2,1)=3   
2927         K(NSAV+3,1)=3   
2928         KCP=LUCOMP(K(NSAV+1,2)) 
2929         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))    
2930         JCON=4  
2931         IF(KQP.LT.0) JCON=5 
2932         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2) 
2933         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)   
2934         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3) 
2935         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)   
2936         MSTJ(92)=NSAV+1 
2937       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN 
2938         K(NSAV+1,1)=3   
2939         K(NSAV+3,1)=3   
2940         K(NSAV+1,4)=MSTU(5)*(NSAV+3)    
2941         K(NSAV+1,5)=MSTU(5)*(NSAV+3)    
2942         K(NSAV+3,4)=MSTU(5)*(NSAV+1)    
2943         K(NSAV+3,5)=MSTU(5)*(NSAV+1)    
2944         MSTJ(92)=NSAV+1 
2945       ENDIF 
2946     
2947 C...Mark decayed particle.  

2948       IF(K(IP,1).EQ.5) K(IP,1)=15   
2949       IF(K(IP,1).LE.10) K(IP,1)=11  
2950       K(IP,4)=NSAV+1    
2951       K(IP,5)=N 
2952     
2953       RETURN    
2954       END   
2955     
2956 C*********************************************************************  

2957     
2958       SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)  
2959     
2960 C...Purpose: to generate a new flavour pair and combine off a hadron.   

2961       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
2962       SAVE /LUDAT1/ 
2963       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
2964       SAVE /LUDAT2/ 
2965     
2966 C...Default flavour values. Input consistency checks.   

2967       KF1A=IABS(KFL1)   
2968       KF2A=IABS(KFL2)   
2969       KFL3=0    
2970       KF=0  
2971       IF(KF1A.EQ.0) RETURN  
2972       IF(KF2A.NE.0) THEN    
2973         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN 
2974         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN    
2975         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN    
2976       ENDIF 
2977     
2978 C...Check if tabulated flavour probabilities are to be used.    

2979       IF(MSTJ(15).EQ.1) THEN    
2980         KTAB1=-1    
2981         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A  
2982         KFL1A=MOD(KF1A/1000,10) 
2983         KFL1B=MOD(KF1A/100,10)  
2984         KFL1S=MOD(KF1A,10)  
2985         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4) 
2986      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2 
2987         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1  
2988         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A  
2989         KTAB2=0 
2990         IF(KF2A.NE.0) THEN  
2991           KTAB2=-1  
2992           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A    
2993           KFL2A=MOD(KF2A/1000,10)   
2994           KFL2B=MOD(KF2A/100,10)    
2995           KFL2S=MOD(KF2A,10)    
2996           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)   
2997      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2   
2998           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1    
2999         ENDIF   
3000         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140  
3001       ENDIF 
3002     
3003 C...Parameters and breaking diquark parameter combinations. 

3004   100 PAR2=PARJ(2)  
3005       PAR3=PARJ(3)  
3006       PAR4=3.*PARJ(4)   
3007 cms.. preinitialize to avoid compiler warning

3008       PARSM=0.
3009       PARS2=0.
3010       PARDM=0.
3011       PAR4M=0.
3012       PAR3M=0.
3013       PARS0=0.
3014       PARS1=0.
3015       IF(MSTJ(12).GE.2) THEN    
3016         PAR3M=SQRT(PARJ(3)) 
3017         PAR4M=1./(3.*SQRT(PARJ(4))) 
3018         PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))   
3019         PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))   
3020         PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+ 
3021      &  PAR2*PAR3M*PARJ(6)*PARJ(7)) 
3022         PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)    
3023         PARSM=MAX(PARS0,PARS1,PARS2)    
3024         PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))  
3025       ENDIF 
3026     
3027 C...Choice of whether to generate meson or baryon.  

3028       MBARY=0   
3029       KFDA=0    
3030       IF(KF1A.LE.10) THEN   
3031         IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)   
3032      &  MBARY=1 
3033         IF(KF2A.GT.10) MBARY=2  
3034         IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A  
3035       ELSE  
3036         MBARY=2 
3037         IF(KF1A.LE.10000) KFDA=KF1A 
3038       ENDIF 
3039     
3040 C...Possibility of process diquark -> meson + new diquark.  

3041       IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN  
3042         KFLDA=MOD(KFDA/1000,10) 
3043         KFLDB=MOD(KFDA/100,10)  
3044         KFLDS=MOD(KFDA,10)  
3045         WTDQ=PARS0  
3046         IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1    
3047         IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2    
3048         IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M) 
3049         IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1 
3050         IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN    
3051       ENDIF 
3052     
3053 C...Flavour for meson, possibly with new flavour.   

3054       IF(MBARY.LE.0) THEN   
3055         KFS=ISIGN(1,KFL1)   
3056         IF(MBARY.EQ.0) THEN 
3057           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)   
3058           KFLA=MAX(KF1A,KF2A+IABS(KFL3))    
3059           KFLB=MIN(KF1A,KF2A+IABS(KFL3))    
3060           IF(KFLA.NE.KF1A) KFS=-KFS 
3061     
3062 C...Splitting of diquark into meson plus new diquark.   

3063         ELSE    
3064           KFL1A=MOD(KF1A/1000,10)   
3065           KFL1B=MOD(KF1A/100,10)    
3066   110     KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A) 
3067           KFL1E=KFL1A+KFL1B-KFL1D   
3068           IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.   
3069      &    RLU(0).LT.PARDM)) THEN    
3070             KFL1D=KFL1A+KFL1B-KFL1D 
3071             KFL1E=KFL1A+KFL1B-KFL1E 
3072           ENDIF 
3073           KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))   
3074           IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).    
3075      &    OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))    
3076      &    GOTO 110  
3077           KFLDS=3   
3078           IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1    
3079           KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+  
3080      &    KFLDS,-KFL1)  
3081           KFLA=MAX(KFL1D,KFL3A) 
3082           KFLB=MIN(KFL1D,KFL3A) 
3083           IF(KFLA.NE.KFL1D) KFS=-KFS    
3084         ENDIF   
3085     
3086 C...Form meson, with spin and flavour mixing for diagonal states.   

3087         KMUL=0
3088         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0)) 
3089         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0)) 
3090         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0)) 
3091         IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN   
3092           IF(RLU(0).LT.PARJ(14)) KMUL=2 
3093         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN 
3094           RMUL=RLU(0)   
3095           IF(RMUL.LT.PARJ(15)) KMUL=3   
3096           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4    
3097           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5   
3098         ENDIF   
3099         KFLS=3  
3100         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1   
3101         IF(KMUL.EQ.5) KFLS=5    
3102         IF(KFLA.NE.KFLB) THEN   
3103           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA 
3104         ELSE    
3105           RMIX=RLU(0)   
3106           IMIX=2*KFLA+10*KMUL   
3107           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+   
3108      &    INT(RMIX+PARF(IMIX)))+KFLS    
3109           IF(KFLA.GE.4) KF=110*KFLA+KFLS    
3110         ENDIF   
3111         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)    
3112         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF) 
3113     
3114 C...Generate diquark flavour.   

3115       ELSE  
3116   120   IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN   
3117           KFLA=KF1A 
3118   130     KFLB=1+INT((2.+PAR2*PAR3)*RLU(0)) 
3119           KFLC=1+INT((2.+PAR2*PAR3)*RLU(0)) 
3120           KFLDS=1   
3121           IF(KFLB.GE.KFLC) KFLDS=3  
3122           IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130 
3123           IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130    
3124           KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1) 
3125     
3126 C...Take diquark flavour from input.    

3127         ELSEIF(KF1A.LE.10) THEN 
3128           KFLA=KF1A 
3129           KFLB=MOD(KF2A/1000,10)    
3130           KFLC=MOD(KF2A/100,10) 
3131           KFLDS=MOD(KF2A,10)    
3132     
3133 C...Generate (or take from input) quark to go with diquark. 

3134         ELSE    
3135           IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)    
3136           KFLA=KF2A+IABS(KFL3)  
3137           KFLB=MOD(KF1A/1000,10)    
3138           KFLC=MOD(KF1A/100,10) 
3139           KFLDS=MOD(KF1A,10)    
3140         ENDIF   
3141     
3142 C...SU(6) factors for formation of baryon. Try again if fails.  

3143         KBARY=KFLDS 
3144         IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5 
3145         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1 
3146         WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)   
3147         IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN   
3148           WTDQ=PARS0    
3149           IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1    
3150           IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2    
3151           IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)   
3152           IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))  
3153           IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM) 
3154         ENDIF   
3155         IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120 
3156     
3157 C...Form baryon. Distinguish Lambda- and Sigmalike baryons. 

3158         KFLD=MAX(KFLA,KFLB,KFLC)    
3159         KFLF=MIN(KFLA,KFLB,KFLC)    
3160         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF   
3161         KFLS=2  
3162         IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.  
3163      &  PARF(60+KBARY)) KFLS=4  
3164         KFLL=0  
3165         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN    
3166           IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1    
3167           IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0)) 
3168           IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0)) 
3169         ENDIF   
3170         IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)    
3171         IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)    
3172       ENDIF 
3173       RETURN    
3174     
3175 C...Use tabulated probabilities to select new flavour and hadron.   

3176   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN 
3177         KT3L=1  
3178         KT3U=6  
3179       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN  
3180         KT3L=1  
3181         KT3U=6  
3182       ELSEIF(KTAB2.EQ.0) THEN   
3183         KT3L=1  
3184         KT3U=22 
3185       ELSE  
3186         KT3L=KTAB2  
3187         KT3U=KTAB2  
3188       ENDIF 
3189       RFL=0.    
3190       DO 150 KTS=0,2    
3191       DO 150 KT3=KT3L,KT3U  
3192       RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3) 
3193   150 CONTINUE  
3194 cms.. preinitialize to avoid compiler warning

3195       KTAB3=0.
3196       RFL=RLU(0)*RFL    
3197       DO 160 KTS=0,2    
3198       KTABS=KTS 
3199       DO 160 KT3=KT3L,KT3U  
3200       KTAB3=KT3 
3201       RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3) 
3202   160 IF(RFL.LE.0.) GOTO 170    
3203   170 CONTINUE  
3204     
3205 C...Reconstruct flavour of produced quark/diquark.  

3206       IF(KTAB3.LE.6) THEN   
3207         KFL3A=KTAB3 
3208         KFL3B=0 
3209         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13)) 
3210       ELSE  
3211         KFL3A=1 
3212         IF(KTAB3.GE.8) KFL3A=2  
3213         IF(KTAB3.GE.11) KFL3A=3 
3214         IF(KTAB3.GE.16) KFL3A=4 
3215         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2   
3216         KFL3=1000*KFL3A+100*KFL3B+1 
3217         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=  
3218      &  KFL3+2  
3219         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))  
3220       ENDIF 
3221     
3222 C...Reconstruct meson code. 

3223       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.  
3224      &KFL3B.NE.0)) THEN 
3225         RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+  
3226      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))  
3227         KF=110+2*KTABS+1    
3228         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1 
3229         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+    
3230      &  25*KTABS)) KF=330+2*KTABS+1 
3231       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN    
3232         KFLA=MAX(KTAB1,KTAB3)   
3233         KFLB=MIN(KTAB1,KTAB3)   
3234         KFS=ISIGN(1,KFL1)   
3235         IF(KFLA.NE.KF1A) KFS=-KFS   
3236         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA  
3237       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN    
3238         KFS=ISIGN(1,KFL1)   
3239         IF(KFL1A.EQ.KFL3A) THEN 
3240           KFLA=MAX(KFL1B,KFL3B) 
3241           KFLB=MIN(KFL1B,KFL3B) 
3242           IF(KFLA.NE.KFL1B) KFS=-KFS    
3243         ELSEIF(KFL1A.EQ.KFL3B) THEN 
3244           KFLA=KFL3A    
3245           KFLB=KFL1B    
3246           KFS=-KFS  
3247         ELSEIF(KFL1B.EQ.KFL3A) THEN 
3248           KFLA=KFL1A    
3249           KFLB=KFL3B    
3250         ELSEIF(KFL1B.EQ.KFL3B) THEN 
3251           KFLA=MAX(KFL1A,KFL3A) 
3252           KFLB=MIN(KFL1A,KFL3A) 
3253           IF(KFLA.NE.KFL1A) KFS=-KFS    
3254         ELSE    
3255           CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')  
3256           GOTO 100  
3257         ENDIF   
3258         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA  
3259     
3260 C...Reconstruct baryon code.    

3261       ELSE  
3262         IF(KTAB1.GE.7) THEN 
3263           KFLA=KFL3A    
3264           KFLB=KFL1A    
3265           KFLC=KFL1B    
3266         ELSE    
3267           KFLA=KFL1A    
3268           KFLB=KFL3A    
3269           KFLC=KFL3B    
3270         ENDIF   
3271         KFLD=MAX(KFLA,KFLB,KFLC)    
3272         KFLF=MIN(KFLA,KFLB,KFLC)    
3273         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF   
3274         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)  
3275         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)    
3276       ENDIF 
3277     
3278 C...Check that constructed flavour code is an allowed one.  

3279       IF(KFL2.NE.0) KFL3=0  
3280       KC=LUCOMP(KF) 
3281       IF(KC.EQ.0) THEN  
3282         CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '// 
3283      &  'failed')   
3284         GOTO 100    
3285       ENDIF 
3286     
3287       RETURN    
3288       END   
3289     
3290 C*********************************************************************  

3291     
3292       SUBROUTINE LUPTDI(KFL,PX,PY)  
3293     
3294 C...Purpose: to generate transverse momentum according to a Gaussian.   

3295       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
3296       SAVE /LUDAT1/ 
3297     
3298 C...Generate p_T and azimuthal angle, gives p_x and p_y.    

3299       KFLA=IABS(KFL)    
3300       PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0)))) 
3301       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT  
3302       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0. 
3303       PHI=PARU(2)*RLU(0)    
3304       PX=PT*COS(PHI)    
3305       PY=PT*SIN(PHI)    
3306     
3307       RETURN    
3308       END   
3309     
3310 C*********************************************************************  

3311     
3312       SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z) 
3313     
3314 C...Purpose: to generate the longitudinal splitting variable z. 

3315       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
3316       SAVE /LUDAT1/ 
3317     
3318 C...Check if heavy flavour fragmentation.   

3319       KFLA=IABS(KFL1)   
3320       KFLB=IABS(KFL2)   
3321       KFLH=KFLA 
3322       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10) 
3323     
3324 C...Lund symmetric scaling function: determine parameters of shape. 

3325       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3)) THEN   
3326         FA=PARJ(41) 
3327         IF(MSTJ(91).EQ.1) FA=PARJ(43)   
3328         IF(KFLB.GE.10) FA=FA+PARJ(45)   
3329         FB=PARJ(42)*PR  
3330         IF(MSTJ(91).EQ.1) FB=PARJ(44)*PR    
3331         FC=1.   
3332         IF(KFLA.GE.10) FC=FC-PARJ(45)   
3333         IF(KFLB.GE.10) FC=FC+PARJ(45)   
3334         MC=1    
3335         IF(ABS(FC-1.).GT.0.01) MC=2 
3336     
3337 C...Determine position of maximum. Special cases for a = 0 or a = c.    

3338         IF(FA.LT.0.02) THEN 
3339           MA=1  
3340           ZMAX=1.   
3341           IF(FC.GT.FB) ZMAX=FB/FC   
3342         ELSEIF(ABS(FC-FA).LT.0.01) THEN 
3343           MA=2  
3344           ZMAX=FB/(FB+FC)   
3345         ELSE    
3346           MA=3  
3347           ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)    
3348           IF(ZMAX.GT.0.99.AND.FB.GT.100.) ZMAX=1.-FA/FB 
3349         ENDIF   
3350     
3351 C...Subdivide z range if distribution very peaked near endpoint.    

3352         MMAX=2
3353 cms .. redefine variables to avoid compiler warning

3354         ZDIV=0.
3355         ZDIVC=0.
3356         FINT=0.
3357         IF(ZMAX.LT.0.1) THEN    
3358           MMAX=1    
3359           ZDIV=2.75*ZMAX    
3360           IF(MC.EQ.1) THEN  
3361             FINT=1.-LOG(ZDIV)   
3362           ELSE  
3363             ZDIVC=ZDIV**(1.-FC) 
3364             FINT=1.+(1.-1./ZDIVC)/(FC-1.)   
3365           ENDIF 
3366         ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN  
3367           MMAX=3    
3368           FSCB=SQRT(4.+(FC/FB)**2)  
3369           ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))  
3370           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)    
3371           ZDIV=MIN(ZMAX,MAX(0.,ZDIV))   
3372           FINT=1.+FB*(1.-ZDIV)  
3373         ENDIF   
3374     
3375 C...Choice of z, preweighted for peaks at low or high z.    

3376   100   Z=RLU(0)    
3377         FPRE=1. 
3378         IF(MMAX.EQ.1) THEN  
3379           IF(FINT*RLU(0).LE.1.) THEN    
3380             Z=ZDIV*Z    
3381           ELSEIF(MC.EQ.1) THEN  
3382             Z=ZDIV**Z   
3383             FPRE=ZDIV/Z 
3384           ELSE  
3385             Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC)) 
3386             FPRE=(ZDIV/Z)**FC   
3387           ENDIF 
3388         ELSEIF(MMAX.EQ.3) THEN  
3389           IF(FINT*RLU(0).LE.1.) THEN    
3390             Z=ZDIV+LOG(Z)/FB    
3391             FPRE=EXP(FB*(Z-ZDIV))   
3392           ELSE  
3393             Z=ZDIV+Z*(1.-ZDIV)  
3394           ENDIF 
3395         ENDIF   
3396     
3397 C...Weighting according to correct formula. 

3398         IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100    
3399         FVAL=(ZMAX/Z)**FC*EXP(FB*(1./ZMAX-1./Z))    
3400         IF(MA.GE.2) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL    
3401         IF(FVAL.LT.RLU(0)*FPRE) GOTO 100    
3402     
3403 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.  

3404       ELSE  
3405         FC=PARJ(50+MAX(1,KFLH)) 
3406         IF(MSTJ(91).EQ.1) FC=PARJ(59)   
3407   110   Z=RLU(0)    
3408         IF(FC.GE.0..AND.FC.LE.1.) THEN  
3409           IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)  
3410         ELSEIF(FC.GT.-1.) THEN  
3411           IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110 
3412         ELSE    
3413           IF(FC.GT.0.) Z=1.-Z**(1./FC)  
3414           IF(FC.LT.0.) Z=Z**(-1./FC)    
3415         ENDIF   
3416       ENDIF 
3417     
3418       RETURN    
3419       END   
3420     
3421 C*********************************************************************  

3422     
3423       SUBROUTINE LUSHOW(IP1,IP2,QMAX)   
3424     
3425 C...Purpose: to generate timelike parton showers from given partons.    

3426       IMPLICIT DOUBLE PRECISION(D)  
3427       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
3428       SAVE /LUJETS/ 
3429       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
3430       SAVE /LUDAT1/ 
3431       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
3432       SAVE /LUDAT2/ 
3433       DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),  
3434      &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4)   
3435     
3436 C...Initialization of cutoff masses etc.    

3437       IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.  
3438      &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN   
3439       PMTH(1,21)=ULMASS(21) 
3440       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)   
3441       PMTH(3,21)=2.*PMTH(2,21)  
3442       PMTH(4,21)=PMTH(3,21) 
3443       PMTH(5,21)=PMTH(3,21) 
3444       PMTH(1,22)=ULMASS(22) 
3445       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)   
3446       PMTH(3,22)=2.*PMTH(2,22)  
3447       PMTH(4,22)=PMTH(3,22) 
3448       PMTH(5,22)=PMTH(3,22) 
3449       PMQTH1=PARJ(82)   
3450       IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))   
3451       PMQTH2=PMTH(2,21) 
3452       IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))   
3453       DO 100 IF=1,8 
3454       PMTH(1,IF)=ULMASS(IF) 
3455       PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2) 
3456       PMTH(3,IF)=PMTH(2,IF)+PMQTH2  
3457       PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)    
3458   100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)    
3459       PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2  
3460       ALAMS=PARJ(81)**2 
3461       ALFM=LOG(PT2MIN/ALAMS)    
3462     
3463 C...Store positions of shower initiating partons.   

3464       M3JC=0    
3465 cms..pre-initialization

3466       NPA=0
3467 cms..pre-initialization

3468       ZM=0.
3469       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN 
3470         NPA=1   
3471         IPA(1)=IP1  
3472       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-   
3473      &MSTU(32))) THEN   
3474         NPA=2   
3475         IPA(1)=IP1  
3476         IPA(2)=IP2  
3477       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.  
3478      &AND.IP2.GE.-3) THEN   
3479         NPA=IABS(IP2)   
3480         DO 110 I=1,NPA  
3481   110   IPA(I)=IP1+I-1  
3482       ELSE  
3483         CALL LUERRM(12, 
3484      &  '(LUSHOW:) failed to reconstruct showering system') 
3485         IF(MSTU(21).GE.1) RETURN    
3486       ENDIF 
3487     
3488 C...Check on phase space available for emission.    

3489       IREJ=0    
3490       DO 120 J=1,5  
3491   120 PS(J)=0.  
3492       PM=0. 
3493       DO 130 I=1,NPA    
3494       KFLA(I)=IABS(K(IPA(I),2)) 
3495       PMA(I)=P(IPA(I),5)    
3496       IF(KFLA(I).NE.0.AND.(KFLA(I).LE.8.OR.KFLA(I).EQ.21))  
3497      &PMA(I)=PMTH(3,KFLA(I))    
3498       PM=PM+PMA(I)  
3499       IF(KFLA(I).EQ.0.OR.(KFLA(I).GT.8.AND.KFLA(I).NE.21).OR.   
3500      &PMA(I).GT.QMAX) IREJ=IREJ+1   
3501       DO 130 J=1,4  
3502   130 PS(J)=PS(J)+P(IPA(I),J)   
3503       IF(IREJ.EQ.NPA) RETURN    
3504       PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))   
3505       IF(NPA.EQ.1) PS(5)=PS(4)  
3506       IF(PS(5).LE.PM+PMQTH1) RETURN 
3507       IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN   
3508         IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.  
3509      &  KFLA(2).LE.8) M3JC=1    
3510         IF(MSTJ(47).GE.2) M3JC=1    
3511       ENDIF 
3512     
3513 C...Define imagined single initiator of shower for parton system.   

3514       NS=N  
3515       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN  
3516         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')   
3517         IF(MSTU(21).GE.1) RETURN    
3518       ENDIF 
3519       IF(NPA.GE.2) THEN 
3520         K(N+1,1)=11 
3521         K(N+1,2)=21 
3522         K(N+1,3)=0  
3523         K(N+1,4)=0  
3524         K(N+1,5)=0  
3525         P(N+1,1)=0. 
3526         P(N+1,2)=0. 
3527         P(N+1,3)=0. 
3528         P(N+1,4)=PS(5)  
3529         P(N+1,5)=PS(5)  
3530         V(N+1,5)=PS(5)**2   
3531         N=N+1   
3532       ENDIF 
3533     
3534 C...Loop over partons that may branch.  

3535       NEP=NPA   
3536       IM=NS 
3537       IF(NPA.EQ.1) IM=NS-1  
3538   140 IM=IM+1   
3539       IF(N.GT.NS) THEN  
3540         IF(IM.GT.N) GOTO 380    
3541         KFLM=IABS(K(IM,2))  
3542         IF(KFLM.EQ.0.OR.(KFLM.GT.8.AND.KFLM.NE.21)) GOTO 140    
3543         IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140    
3544         IGM=K(IM,3) 
3545       ELSE  
3546         IGM=-1  
3547       ENDIF 
3548       IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN  
3549         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')   
3550         IF(MSTU(21).GE.1) RETURN    
3551       ENDIF 
3552     
3553 C...Position of aunt (sister to branching parton).  

3554 C...Origin and flavour of daughters.    

3555       IAU=0 
3556       IF(IGM.GT.0) THEN 
3557         IF(K(IM-1,3).EQ.IGM) IAU=IM-1   
3558         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1 
3559       ENDIF 
3560       IF(IGM.GE.0) THEN 
3561         K(IM,4)=N+1 
3562         DO 150 I=1,NEP  
3563   150   K(N+I,3)=IM 
3564       ELSE  
3565         K(N+1,3)=IPA(1) 
3566       ENDIF 
3567       IF(IGM.LE.0) THEN 
3568         DO 160 I=1,NEP  
3569   160   K(N+I,2)=K(IPA(I),2)    
3570       ELSEIF(KFLM.NE.21) THEN   
3571         K(N+1,2)=K(IM,2)    
3572         K(N+2,2)=K(IM,5)    
3573       ELSEIF(K(IM,5).EQ.21) THEN    
3574         K(N+1,2)=21 
3575         K(N+2,2)=21 
3576       ELSE  
3577         K(N+1,2)=K(IM,5)    
3578         K(N+2,2)=-K(IM,5)   
3579       ENDIF 
3580     
3581 C...Reset flags on daughers and tries made. 

3582       DO 170 IP=1,NEP   
3583       K(N+IP,1)=3   
3584       K(N+IP,4)=0   
3585       K(N+IP,5)=0   
3586       KFLD(IP)=IABS(K(N+IP,2))  
3587       ITRY(IP)=0    
3588       ISL(IP)=0 
3589       ISI(IP)=0 
3590   170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1 
3591       ISLM=0    
3592     
3593 C...Maximum virtuality of daughters.    

3594 cms..pre-initialization

3595       PEM=0.
3596       IF(IGM.LE.0) THEN 
3597         DO 180 I=1,NPA  
3598         IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)- 
3599      &  PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)  
3600         P(N+I,5)=MIN(QMAX,PS(5))    
3601         IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))    
3602   180   IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)    
3603       ELSE  
3604         IF(MSTJ(43).LE.2) PEM=V(IM,2)   
3605         IF(MSTJ(43).GE.3) PEM=P(IM,4)   
3606         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)   
3607         P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)  
3608         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)  
3609       ENDIF 
3610       DO 190 I=1,NEP    
3611       PMSD(I)=P(N+I,5)  
3612       IF(ISI(I).EQ.1) THEN  
3613         IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))    
3614       ENDIF 
3615   190 V(N+I,5)=P(N+I,5)**2  
3616     
3617 C...Choose one of the daughters for evolution.  

3618   200 INUM=0    
3619       IF(NEP.EQ.1) INUM=1   
3620       DO 210 I=1,NEP    
3621   210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I  
3622       DO 220 I=1,NEP    
3623       IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN   
3624         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I  
3625       ENDIF 
3626   220 CONTINUE  
3627       IF(INUM.EQ.0) THEN    
3628         RMAX=0. 
3629         DO 230 I=1,NEP  
3630         IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN  
3631           RPM=P(N+I,5)/PMSD(I)  
3632           IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN  
3633             RMAX=RPM    
3634             INUM=I  
3635           ENDIF 
3636         ENDIF   
3637   230   CONTINUE    
3638       ENDIF 
3639     
3640 C...Store information on choice of evolving daughter.   

3641       INUM=MAX(1,INUM)  
3642       IEP(1)=N+INUM 
3643       DO 240 I=2,NEP    
3644       IEP(I)=IEP(I-1)+1 
3645   240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1    
3646       DO 250 I=1,NEP    
3647   250 KFL(I)=IABS(K(IEP(I),2))  
3648       ITRY(INUM)=ITRY(INUM)+1   
3649       IF(ITRY(INUM).GT.200) THEN    
3650         CALL LUERRM(14,'(LUSHOW:) caught in infinite loop') 
3651         IF(MSTU(21).GE.1) RETURN    
3652       ENDIF 
3653       Z=0.5 
3654       IF(KFL(1).EQ.0.OR.(KFL(1).GT.8.AND.KFL(1).NE.21)) GOTO 300    
3655       IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300    
3656     
3657 C...Calculate allowed z range.  

3658 cms.. pre-initialization for compiler

3659       PMED=0.
3660       IF(NEP.EQ.1) THEN 
3661         PMED=PS(4)  
3662       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN    
3663         PMED=P(IM,5)    
3664       ELSE  
3665         IF(INUM.EQ.1) PMED=V(IM,1)*PEM  
3666         IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM 
3667       ENDIF 
3668       IF(MOD(MSTJ(43),2).EQ.1) THEN 
3669         ZC=PMTH(2,21)/PMED  
3670         ZCE=PMTH(2,22)/PMED 
3671       ELSE  
3672         ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))    
3673         IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2  
3674         ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))   
3675         IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2    
3676       ENDIF 
3677       ZC=MIN(ZC,0.491)  
3678       ZCE=MIN(ZCE,0.491)    
3679       IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.  
3680      &MIN(ZC,ZCE).GT.0.49)) THEN    
3681         P(IEP(1),5)=PMTH(1,KFL(1))  
3682         V(IEP(1),5)=P(IEP(1),5)**2  
3683         GOTO 300    
3684       ENDIF 
3685     
3686 C...Integral of Altarelli-Parisi z kernel for QCD.  

3687       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN   
3688         FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)    
3689       ELSEIF(MSTJ(49).EQ.0) THEN    
3690         FBR=(8./3.)*LOG((1.-ZC)/ZC) 
3691     
3692 C...Integral of Altarelli-Parisi z kernel for scalar gluon. 

3693       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN   
3694         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC) 
3695       ELSEIF(MSTJ(49).EQ.1) THEN    
3696         FBR=(1.-2.*ZC)/3.   
3697         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR   
3698     
3699 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. 

3700       ELSEIF(KFL(1).EQ.21) THEN 
3701         FBR=6.*MSTJ(45)*(0.5-ZC)    
3702       ELSE  
3703         FBR=2.*LOG((1.-ZC)/ZC)  
3704       ENDIF 
3705     
3706 C...Integral of Altarelli-Parisi kernel for photon emission.    

3707       FBRE=0.
3708       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) 
3709      &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)  
3710     
3711 C...Inner veto algorithm starts. Find maximum mass for evolution.   

3712 cms.. pre-initialization

3713       PM2=0.
3714   260 PMS=V(IEP(1),5)   
3715       IF(IGM.GE.0) THEN 
3716         PM2=0.  
3717         DO 270 I=2,NEP  
3718         PM=P(IEP(I),5)  
3719         IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=   
3720      &  PMTH(2,KFL(I))  
3721   270   PM2=PM2+PM  
3722         PMS=MIN(PMS,(P(IM,5)-PM2)**2)   
3723       ENDIF 
3724     
3725 C...Select mass for daughter in QCD evolution.  

3726       B0=27./6. 
3727       DO 280 IF=4,MSTJ(45)  
3728   280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6. 
3729       IF(MSTJ(44).LE.0) THEN    
3730         PMSQCD=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))  
3731       ELSEIF(MSTJ(44).EQ.1) THEN    
3732         PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))    
3733       ELSE  
3734         PMSQCD=PMS*RLU(0)**(ALFM*B0/FBR)    
3735       ENDIF 
3736       IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD= 
3737      &PMTH(2,KFL(1))**2 
3738       V(IEP(1),5)=PMSQCD    
3739       MCE=1 
3740     
3741 C...Select mass for daughter in QED evolution.  

3742       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN    
3743         PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE))) 
3744         IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=  
3745      &  PMTH(2,KFL(1))**2   
3746         IF(PMSQED.GT.PMSQCD) THEN   
3747           V(IEP(1),5)=PMSQED    
3748           MCE=2 
3749         ENDIF   
3750       ENDIF 
3751     
3752 C...Check whether daughter mass below cutoff.   

3753       P(IEP(1),5)=SQRT(V(IEP(1),5)) 
3754       IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN    
3755         P(IEP(1),5)=PMTH(1,KFL(1))  
3756         V(IEP(1),5)=P(IEP(1),5)**2  
3757         GOTO 300    
3758       ENDIF 
3759     
3760 C...Select z value of branching: q -> qgamma.   

3761       IF(MCE.EQ.2) THEN 
3762         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)    
3763         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260   
3764         K(IEP(1),5)=22  
3765     
3766 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.  

3767       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN   
3768         Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)   
3769         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260   
3770         K(IEP(1),5)=21  
3771       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN    
3772         Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)  
3773         IF(RLU(0).GT.0.5) Z=1.-Z    
3774         IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260 
3775         K(IEP(1),5)=21  
3776       ELSEIF(MSTJ(49).NE.1) THEN    
3777         Z=ZC+(1.-2.*ZC)*RLU(0)  
3778         IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260   
3779         KFLB=1+INT(MSTJ(45)*RLU(0)) 
3780         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)  
3781         IF(PMQ.GE.1.) GOTO 260  
3782         PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)   
3783         IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.   
3784      &  RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260    
3785         K(IEP(1),5)=KFLB    
3786     
3787 C...Ditto for scalar gluon model.   

3788       ELSEIF(KFL(1).NE.21) THEN 
3789         Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))  
3790         K(IEP(1),5)=21  
3791       ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN  
3792         Z=ZC+(1.-2.*ZC)*RLU(0)  
3793         K(IEP(1),5)=21  
3794       ELSE  
3795         Z=ZC+(1.-2.*ZC)*RLU(0)  
3796         KFLB=1+INT(MSTJ(45)*RLU(0)) 
3797         PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)  
3798         IF(PMQ.GE.1.) GOTO 260  
3799         K(IEP(1),5)=KFLB    
3800       ENDIF 
3801       IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN   
3802         IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260 
3803         IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260 
3804       ENDIF 
3805     
3806 C...Check if z consistent with chosen m.    

3807       IF(KFL(1).EQ.21) THEN 
3808         KFLGD1=IABS(K(IEP(1),5))    
3809         KFLGD2=KFLGD1   
3810       ELSE  
3811         KFLGD1=KFL(1)   
3812         KFLGD2=IABS(K(IEP(1),5))    
3813       ENDIF 
3814       PED=0.
3815       IF(NEP.EQ.1) THEN 
3816         PED=PS(4)   
3817       ELSEIF(NEP.GE.3) THEN 
3818         PED=P(IEP(1),4) 
3819       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN    
3820         PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)    
3821       ELSE  
3822         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM   
3823         IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM  
3824       ENDIF 
3825       IF(MOD(MSTJ(43),2).EQ.1) THEN 
3826         PMQTH3=0.5*PARJ(82) 
3827         IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)    
3828         PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)  
3829         PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)  
3830         ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-  
3831      &  4.*PMQ1*PMQ2))) 
3832         ZH=1.+PMQ1-PMQ2 
3833       ELSE  
3834         ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))  
3835         ZH=1.   
3836       ENDIF 
3837       ZL=0.5*(ZH-ZD)    
3838       ZU=0.5*(ZH+ZD)    
3839       IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260   
3840       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL* 
3841      &(1.-ZU))) 
3842       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))    
3843     
3844 C...Three-jet matrix element correction.    

3845       IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN   
3846         X1=Z*(1.+V(IEP(1),5)/V(NS+1,5)) 
3847         X2=1.-V(IEP(1),5)/V(NS+1,5) 
3848         X3=(1.-X1)+(1.-X2)  
3849         IF(MCE.EQ.2) THEN   
3850           KI1=K(IPA(INUM),2)    
3851           KI2=K(IPA(3-INUM),2)  
3852           QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3. 
3853           QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3. 
3854           WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+ 
3855      &    QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)    
3856           WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)  
3857         ELSEIF(MSTJ(49).NE.1) THEN  
3858           WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+  
3859      &    (1.-X2)/X3*(X2/(2.-X1))**2    
3860           WME=X1**2+X2**2   
3861         ELSE    
3862           WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)   
3863           WME=X3**2 
3864         ENDIF   
3865         IF(WME.LT.RLU(0)*WSHOW) GOTO 260    
3866     
3867 C...Impose angular ordering by rejection of nonordered emission.    

3868       ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN  
3869         MAOM=1  
3870         ZM=V(IM,1)  
3871         IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1) 
3872         THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5) 
3873         IAOM=IM 
3874   290   IF(K(IAOM,5).EQ.22) THEN    
3875           IAOM=K(IAOM,3)    
3876           IF(K(IAOM,3).LE.NS) MAOM=0    
3877           IF(MAOM.EQ.1) GOTO 290    
3878         ENDIF   
3879         IF(MAOM.EQ.1) THEN  
3880           THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)    
3881           IF(THE2ID.LT.THE2IM) GOTO 260 
3882         ENDIF   
3883       ENDIF 
3884     
3885 C...Impose user-defined maximum angle at first branching.   

3886       IF(MSTJ(48).EQ.1) THEN    
3887         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN  
3888           THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)  
3889           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260 
3890         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN    
3891           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)  
3892           IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260 
3893         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN    
3894           THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)  
3895           IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260 
3896         ENDIF   
3897       ENDIF 
3898     
3899 C...End of inner veto algorithm. Check if only one leg evolved so far.  

3900   300 V(IEP(1),1)=Z 
3901       ISL(1)=0  
3902       ISL(2)=0  
3903       IF(NEP.EQ.1) GOTO 330 
3904       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200  
3905       DO 310 I=1,NEP    
3906       IF(ITRY(I).EQ.0.AND.KFLD(I).GT.0.AND.(KFLD(I).LE.8.OR.KFLD(I).EQ. 
3907      &21)) THEN 
3908         IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200    
3909       ENDIF 
3910   310 CONTINUE  
3911     
3912 C...Check if chosen multiplet m1,m2,z1,z2 is physical.  

3913 cms.. pre-initialization

3914       PTS=0.
3915       PA1S=0.
3916       PA2S=0.
3917       PA3S=0.
3918       IF(NEP.EQ.3) THEN 
3919         PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))    
3920         PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))    
3921         PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))    
3922         PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-   
3923      &  PA1S**2-PA2S**2-PA3S**2)/PA1S   
3924         IF(PTS.LE.0.) GOTO 200  
3925       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN    
3926         DO 320 I1=N+1,N+2   
3927         KFLDA=IABS(K(I1,2)) 
3928         IF(KFLDA.EQ.0.OR.(KFLDA.GT.8.AND.KFLDA.NE.21)) GOTO 320 
3929         IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320   
3930         IF(KFLDA.EQ.21) THEN    
3931           KFLGD1=IABS(K(I1,5))  
3932           KFLGD2=KFLGD1 
3933         ELSE    
3934           KFLGD1=KFLDA  
3935           KFLGD2=IABS(K(I1,5))  
3936         ENDIF   
3937         I2=2*N+3-I1 
3938         IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN  
3939           PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) 
3940         ELSE    
3941 cms.. modified to avoid comp. warning

3942 cc..          IF(I1.EQ.N+1) ZM=V(IM,1)  

3943           ZM=V(IM,1)
3944           IF(I1.EQ.N+2) ZM=1.-V(IM,1)   
3945           PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-  
3946      &    4.*V(N+1,5)*V(N+2,5)) 
3947           PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)    
3948         ENDIF   
3949         IF(MOD(MSTJ(43),2).EQ.1) THEN   
3950           PMQTH3=0.5*PARJ(82)   
3951           IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)  
3952           PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)    
3953           PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)    
3954           ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-    
3955      &    4.*PMQ1*PMQ2)))   
3956           ZH=1.+PMQ1-PMQ2   
3957         ELSE    
3958           ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))    
3959           ZH=1. 
3960         ENDIF   
3961         ZL=0.5*(ZH-ZD)  
3962         ZU=0.5*(ZH+ZD)  
3963         IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1 
3964         IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1 
3965         IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))   
3966         IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))   
3967   320   CONTINUE    
3968         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN  
3969           ISL(3-ISLM)=0 
3970           ISLM=3-ISLM   
3971         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN    
3972           ZDR1=MAX(0.,V(N+1,3)/V(N+1,4)-1.) 
3973           ZDR2=MAX(0.,V(N+2,3)/V(N+2,4)-1.) 
3974           IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0   
3975           IF(ISL(1).EQ.1) ISL(2)=0  
3976           IF(ISL(1).EQ.0) ISLM=1    
3977           IF(ISL(2).EQ.0) ISLM=2    
3978         ENDIF   
3979         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200 
3980       ENDIF 
3981       IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.    
3982      &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN 
3983         PMQ1=V(N+1,5)/V(IM,5)   
3984         PMQ2=V(N+2,5)/V(IM,5)   
3985         ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-  
3986      &  4.*PMQ1*PMQ2))) 
3987         ZH=1.+PMQ1-PMQ2 
3988         ZL=0.5*(ZH-ZD)  
3989         ZU=0.5*(ZH+ZD)  
3990         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200 
3991       ENDIF 
3992     
3993 C...Accepted branch. Construct four-momentum for initial partons.   

3994   330 MAZIP=0   
3995       MAZIC=0
3996 cms.. pre-initialization for compiler

3997       PZM=0.
3998       PMLS=0.
3999       PT=0.
4000       IF(NEP.EQ.1) THEN 
4001         P(N+1,1)=0. 
4002         P(N+1,2)=0. 
4003         P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-   
4004      &  P(N+1,5)))) 
4005         P(N+1,4)=P(IPA(1),4)    
4006         V(N+1,2)=P(N+1,4)   
4007       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN    
4008         PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)    
4009         P(N+1,1)=0. 
4010         P(N+1,2)=0. 
4011         P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))  
4012         P(N+1,4)=PED1   
4013         P(N+2,1)=0. 
4014         P(N+2,2)=0. 
4015         P(N+2,3)=-P(N+1,3)  
4016         P(N+2,4)=P(IM,5)-PED1   
4017         V(N+1,2)=P(N+1,4)   
4018         V(N+2,2)=P(N+2,4)   
4019       ELSEIF(NEP.EQ.3) THEN 
4020         P(N+1,1)=0. 
4021         P(N+1,2)=0. 
4022         P(N+1,3)=SQRT(MAX(0.,PA1S)) 
4023         P(N+2,1)=SQRT(PTS)  
4024         P(N+2,2)=0. 
4025         P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)  
4026         P(N+3,1)=-P(N+2,1)  
4027         P(N+3,2)=0. 
4028         P(N+3,3)=-(P(N+1,3)+P(N+2,3))   
4029         V(N+1,2)=P(N+1,4)   
4030         V(N+2,2)=P(N+2,4)   
4031         V(N+3,2)=P(N+3,4)   
4032     
4033 C...Construct transverse momentum for ordinary branching in shower. 

4034       ELSE  
4035         ZM=V(IM,1)  
4036         PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))   
4037         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)    
4038         IF(PZM.LE.0.) THEN  
4039           PTS=0.    
4040         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN   
4041           PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)- 
4042      &    ZM*V(N+2,5))-0.25*PMLS)/PZM**2    
4043         ELSE    
4044           PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2  
4045         ENDIF   
4046         PT=SQRT(MAX(0.,PTS))    
4047     
4048 C...Find coefficient of azimuthal asymmetry due to gluon polarization.  

4049         HAZIP=0.    
4050         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.    
4051      &  AND.IAU.NE.0) THEN  
4052           IF(K(IGM,3).NE.0) MAZIP=1 
4053           ZAU=V(IGM,1)  
4054           IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)   
4055           IF(MAZIP.EQ.0) ZAU=0. 
4056           IF(K(IGM,2).NE.21) THEN   
4057             HAZIP=2.*ZAU/(1.+ZAU**2)    
4058           ELSE  
4059             HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2    
4060           ENDIF 
4061           IF(K(N+1,2).NE.21) THEN   
4062             HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM)) 
4063           ELSE  
4064             HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2 
4065           ENDIF 
4066         ENDIF   
4067     
4068 C...Find coefficient of azimuthal asymmetry due to soft gluon   

4069 C...interference.   

4070         HAZIC=0.    
4071         IF(MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.K(N+2,2).EQ.21).    
4072      &  AND.IAU.NE.0) THEN  
4073           IF(K(IGM,3).NE.0) MAZIC=N+1   
4074           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2    
4075           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.   
4076      &    ZM.GT.0.5) MAZIC=N+2  
4077           IF(K(IAU,2).EQ.22) MAZIC=0    
4078           ZS=ZM 
4079           IF(MAZIC.EQ.N+2) ZS=1.-ZM 
4080           ZGM=V(IGM,1)  
4081           IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)   
4082           IF(MAZIC.EQ.0) ZGM=1. 
4083           HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))  
4084           HAZIC=MIN(0.95,HAZIC) 
4085         ENDIF   
4086       ENDIF 
4087     
4088 C...Construct kinematics for ordinary branching in shower.  

4089   340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN    
4090         IF(MOD(MSTJ(43),2).EQ.1) THEN   
4091           P(N+1,4)=PEM*V(IM,1)  
4092         ELSE    
4093           P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ 
4094      &    SQRT(PMLS)*ZM)/V(IM,5)    
4095         ENDIF   
4096         PHI=PARU(2)*RLU(0)  
4097         P(N+1,1)=PT*COS(PHI)    
4098         P(N+1,2)=PT*SIN(PHI)    
4099         IF(PZM.GT.0.) THEN  
4100           P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM  
4101         ELSE    
4102           P(N+1,3)=0.   
4103         ENDIF   
4104         P(N+2,1)=-P(N+1,1)  
4105         P(N+2,2)=-P(N+1,2)  
4106         P(N+2,3)=PZM-P(N+1,3)   
4107         P(N+2,4)=PEM-P(N+1,4)   
4108         IF(MSTJ(43).LE.2) THEN  
4109           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)  
4110           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)  
4111         ENDIF   
4112       ENDIF 
4113     
4114 C...Rotate and boost daughters. 

4115       IF(IGM.GT.0) THEN 
4116         IF(MSTJ(43).LE.2) THEN  
4117           BEX=P(IGM,1)/P(IGM,4) 
4118           BEY=P(IGM,2)/P(IGM,4) 
4119           BEZ=P(IGM,3)/P(IGM,4) 
4120           GA=P(IGM,4)/P(IGM,5)  
4121           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-   
4122      &    P(IM,4))  
4123         ELSE    
4124           BEX=0.    
4125           BEY=0.    
4126           BEZ=0.    
4127           GA=1. 
4128           GABEP=0.  
4129         ENDIF   
4130         THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+   
4131      &  (P(IM,2)+GABEP*BEY)**2))    
4132         PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) 
4133         DO 350 I=N+1,N+2    
4134         DP(1)=dble(COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ 
4135      &  SIN(THE)*COS(PHI)*P(I,3))
4136         DP(2)=dble(COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ 
4137      &  SIN(THE)*SIN(PHI)*P(I,3))
4138         DP(3)=dble(-SIN(THE)*P(I,1)+COS(THE)*P(I,3))
4139         DP(4)=dble(P(I,4))
4140         DBP=dble(BEX)*DP(1)+dble(BEY)*DP(2)+dble(BEZ)*DP(3)   
4141         DGABP=dble(GA)*(dble(GA)*DBP/(1D0+dble(GA))+DP(4))    
4142         P(I,1)=sngl(DP(1)+DGABP*dble(BEX))
4143         P(I,2)=sngl(DP(2)+DGABP*dble(BEY))
4144         P(I,3)=sngl(DP(3)+DGABP*dble(BEZ))
4145   350   P(I,4)=GA*sngl(DP(4)+DBP)   
4146       ENDIF 
4147     
4148 C...Weight with azimuthal distribution, if required.    

4149       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN 
4150         DO 360 J=1,3    
4151         DPT(1,J)=dble(P(IM,J))
4152         DPT(2,J)=dble(P(IAU,J))  
4153   360   DPT(3,J)=dble(P(N+1,J))
4154         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)  
4155         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)  
4156         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2    
4157         DO 370 J=1,3    
4158         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM    
4159   370   DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM    
4160         DPT(4,4)=DSQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)  
4161         DPT(5,4)=DSQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)  
4162 clin-5/2012:

4163 c        IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN 

4164         IF(sngl(MIN(DPT(4,4),DPT(5,4))).GT.(0.1*PARJ(82))) THEN 
4165            CAD=sngl((DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ 
4166      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)))
4167           IF(MAZIP.NE.0) THEN   
4168             IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))   
4169      &      GOTO 340    
4170           ENDIF 
4171           IF(MAZIC.NE.0) THEN   
4172             IF(MAZIC.EQ.N+2) CAD=-CAD   
4173             IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).    
4174      &      LT.RLU(0)) GOTO 340 
4175           ENDIF 
4176         ENDIF   
4177       ENDIF 
4178     
4179 C...Continue loop over partons that may branch, until none left.    

4180       IF(IGM.GE.0) K(IM,1)=14   
4181       N=N+NEP   
4182       NEP=2 
4183       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN  
4184         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')   
4185         IF(MSTU(21).GE.1) N=NS  
4186         IF(MSTU(21).GE.1) RETURN    
4187       ENDIF 
4188       GOTO 140  
4189     
4190 C...Set information on imagined shower initiator.   

4191   380 IF(NPA.GE.2) THEN 
4192         K(NS+1,1)=11    
4193         K(NS+1,2)=94    
4194         K(NS+1,3)=IP1   
4195         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2   
4196         K(NS+1,4)=NS+2  
4197         K(NS+1,5)=NS+1+NPA  
4198         IIM=1   
4199       ELSE  
4200         IIM=0   
4201       ENDIF 
4202     
4203 C...Reconstruct string drawing information. 

4204       DO 390 I=NS+1+IIM,N   
4205       IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN    
4206         K(I,1)=1    
4207       ELSEIF(K(I,1).LE.10) THEN 
4208         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) 
4209         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) 
4210       ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN 
4211         ID1=MOD(K(I,4),MSTU(5)) 
4212         IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1   
4213         ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 
4214         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 
4215         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 
4216         K(ID1,4)=K(ID1,4)+MSTU(5)*I 
4217         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2   
4218         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1   
4219         K(ID2,5)=K(ID2,5)+MSTU(5)*I 
4220       ELSE  
4221         ID1=MOD(K(I,4),MSTU(5)) 
4222         ID2=ID1+1   
4223         K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 
4224         K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 
4225         K(ID1,4)=K(ID1,4)+MSTU(5)*I 
4226         K(ID1,5)=K(ID1,5)+MSTU(5)*I 
4227         K(ID2,4)=0  
4228         K(ID2,5)=0  
4229       ENDIF 
4230   390 CONTINUE  
4231     
4232 C...Transformation from CM frame.   

4233       IF(NPA.GE.2) THEN 
4234         BEX=PS(1)/PS(4) 
4235         BEY=PS(2)/PS(4) 
4236         BEZ=PS(3)/PS(4) 
4237         GA=PS(4)/PS(5)  
4238         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))  
4239      &  /(1.+GA)-P(IPA(1),4))   
4240       ELSE  
4241         BEX=0.  
4242         BEY=0.  
4243         BEZ=0.  
4244         GABEP=0.    
4245       ENDIF 
4246       THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)    
4247      &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))   
4248       PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)   
4249       IF(NPA.EQ.3) THEN 
4250         CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*  
4251      &  SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*   
4252      &  BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+   
4253      &  GABEP*BEY)) 
4254         CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)  
4255       ENDIF 
4256       DBEX=DBLE(BEX)    
4257       DBEY=DBLE(BEY)    
4258       DBEZ=DBLE(BEZ)    
4259       CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)    
4260     
4261 C...Decay vertex of shower. 

4262       DO 400 I=NS+1,N   
4263       DO 400 J=1,5  
4264   400 V(I,J)=V(IP1,J)   
4265     
4266 C...Delete trivial shower, else connect initiators. 

4267       IF(N.EQ.NS+NPA+IIM) THEN  
4268         N=NS    
4269       ELSE  
4270         DO 410 IP=1,NPA 
4271         K(IPA(IP),1)=14 
4272         K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP 
4273         K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP 
4274         K(NS+IIM+IP,3)=IPA(IP)  
4275         IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1  
4276         K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)   
4277   410   K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)   
4278       ENDIF 
4279     
4280       RETURN    
4281       END   
4282     
4283 C*********************************************************************  

4284     
4285       SUBROUTINE LUBOEI(NSAV)   
4286     
4287 C...Purpose: to modify event so as to approximately take into account   

4288 C...Bose-Einstein effects according to a simple phenomenological    

4289 C...parametrization.    

4290       IMPLICIT DOUBLE PRECISION(D)  
4291       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4292       SAVE /LUJETS/ 
4293       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4294       SAVE /LUDAT1/ 
4295       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)    
4296       DATA KFBE/211,-211,111,321,-321,130,310,221,331/  
4297     
4298 C...Boost event to overall CM frame. Calculate CM energy.   

4299       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN   
4300       DO 100 J=1,4  
4301   100 DPS(J)=0.d0
4302       DO 120 I=1,N  
4303       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120  
4304       DO 110 J=1,4  
4305   110 DPS(J)=DPS(J)+dble(P(I,J))
4306   120 CONTINUE  
4307       CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),  
4308      &-DPS(3)/DPS(4))   
4309       PECM=0.   
4310       DO 130 I=1,N  
4311   130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4) 
4312     
4313 C...Reserve copy of particles by species at end of record.  

4314       NBE(0)=N+MSTU(3)  
4315       DO 160 IBE=1,MIN(9,MSTJ(51))  
4316       NBE(IBE)=NBE(IBE-1)   
4317       DO 150 I=NSAV+1,N 
4318       IF(K(I,2).NE.KFBE(IBE)) GOTO 150  
4319       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150  
4320       IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN   
4321         CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')   
4322         RETURN  
4323       ENDIF 
4324       NBE(IBE)=NBE(IBE)+1   
4325       K(NBE(IBE),1)=I   
4326       DO 140 J=1,3  
4327   140 P(NBE(IBE),J)=0.  
4328   150 CONTINUE  
4329   160 CONTINUE  
4330     
4331 C...Tabulate integral for subsequent momentum shift.    

4332 cms.. preinitialize for compiler

4333       NBIN=0
4334       BEEX=0.
4335       PMHQ=0.
4336       QDEL=0.
4337       DO 210 IBE=1,MIN(9,MSTJ(51))  
4338       IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180   
4339       IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).   
4340      &LE.1) GOTO 180    
4341       IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),    
4342      &NBE(7)-NBE(6)).LE.1) GOTO 180 
4343       IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180    
4344       IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)  
4345       IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)  
4346       IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)  
4347       IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)  
4348       QDEL=0.1*MIN(PMHQ,PARJ(93))   
4349       IF(MSTJ(51).EQ.1) THEN    
4350         NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))    
4351         BEEX=EXP(0.5*QDEL/PARJ(93)) 
4352         BERT=EXP(-QDEL/PARJ(93))    
4353       ELSE  
4354         NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))    
4355       ENDIF 
4356       DO 170 IBIN=1,NBIN    
4357       QBIN=QDEL*(IBIN-0.5)  
4358       BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)    
4359       IF(MSTJ(51).EQ.1) THEN    
4360         BEEX=BEEX*BERT  
4361         BEI(IBIN)=BEI(IBIN)*BEEX    
4362       ELSE  
4363         BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)    
4364       ENDIF 
4365   170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1) 
4366     
4367 C...Loop through particle pairs and find old relative momentum. 

4368   180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1    
4369       I1=K(I1M,1)   
4370       DO 200 I2M=I1M+1,NBE(IBE) 
4371       I2=K(I2M,1)   
4372       Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+  
4373      &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)    
4374       QOLD=SQRT(Q2OLD)  
4375     
4376 C...Calculate new relative momentum.    

4377       IF(QOLD.LT.0.5*QDEL) THEN 
4378         QMOV=QOLD/3.    
4379       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN  
4380         RBIN=QOLD/QDEL  
4381         IBIN=int(RBIN)
4382         RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)  
4383         QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*  
4384      &  SQRT(Q2OLD+PMHQ**2)/Q2OLD   
4385       ELSE  
4386         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD    
4387       ENDIF 
4388       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)   
4389     
4390 C...Calculate and save shift to be performed on three-momenta.  

4391       HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)    
4392       HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2    
4393       HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))   
4394       DO 190 J=1,3  
4395       PD=HA*(P(I2,J)-P(I1,J))   
4396       P(I1M,J)=P(I1M,J)+PD  
4397   190 P(I2M,J)=P(I2M,J)-PD  
4398   200 CONTINUE  
4399   210 CONTINUE  
4400     
4401 C...Shift momenta and recalculate energies. 

4402       DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))   
4403       I=K(IM,1) 
4404       DO 220 J=1,3  
4405   220 P(I,J)=P(I,J)+P(IM,J) 
4406   230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)  
4407     
4408 C...Rescale all momenta for energy conservation.    

4409       PES=0.    
4410       PQS=0.    
4411       DO 240 I=1,N  
4412       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240  
4413       PES=PES+P(I,4)    
4414       PQS=PQS+P(I,5)**2/P(I,4)  
4415   240 CONTINUE  
4416       FAC=(PECM-PQS)/(PES-PQS)  
4417       DO 260 I=1,N  
4418       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260  
4419       DO 250 J=1,3  
4420   250 P(I,J)=FAC*P(I,J) 
4421       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)  
4422   260 CONTINUE  
4423     
4424 C...Boost back to correct reference frame.  

4425       CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))  
4426     
4427       RETURN    
4428       END   
4429     
4430 C*********************************************************************  

4431     
4432       FUNCTION ULMASS(KF)   
4433     
4434 C...Purpose: to give the mass of a particle/parton. 

4435       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4436       SAVE /LUDAT1/ 
4437       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4438       SAVE /LUDAT2/ 
4439     
4440 C...Reset variables. Compressed code.   

4441       ULMASS=0. 
4442       KFA=IABS(KF)  
4443       KC=LUCOMP(KF) 
4444       IF(KC.EQ.0) RETURN    
4445       PARF(106)=PMAS(6,1)   
4446       PARF(107)=PMAS(7,1)   
4447       PARF(108)=PMAS(8,1)   
4448     
4449 C...Guarantee use of constituent masses for internal checks.    

4450       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN   
4451         ULMASS=PARF(100+KFA)    
4452         IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))   
4453     
4454 C...Masses that can be read directly off table. 

4455       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN  
4456         ULMASS=PMAS(KC,1)   
4457     
4458 C...Find constituent partons and their masses.  

4459       ELSE  
4460         KFLA=MOD(KFA/1000,10)   
4461         KFLB=MOD(KFA/100,10)    
4462         KFLC=MOD(KFA/10,10) 
4463         KFLS=MOD(KFA,10)    
4464         KFLR=MOD(KFA/10000,10)  
4465         PMA=PARF(100+KFLA)  
4466         PMB=PARF(100+KFLB)  
4467         PMC=PARF(100+KFLC)  
4468     
4469 C...Construct masses for various meson, diquark and baryon cases.   

4470         IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN  
4471 cms...... initialize to something at first to avoid compiler warning

4472           PMSPL=-3./(PMA*PMB)
4473           IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC) 
4474           IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)  
4475           ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL 
4476         ELSEIF(KFLA.EQ.0) THEN  
4477           KMUL=2    
4478           IF(KFLS.EQ.1) KMUL=3  
4479           IF(KFLR.EQ.2) KMUL=4  
4480           IF(KFLS.EQ.5) KMUL=5  
4481           ULMASS=PARF(113+KMUL)+PMB+PMC 
4482         ELSEIF(KFLC.EQ.0) THEN
4483 cms...... initialize to something at first to avoid compiler warning

4484           PMSPL=-3./(PMA*PMB)
4485           IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB) 
4486           IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)  
4487           ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL   
4488           IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB  
4489           IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)- 
4490      &    2.*PARF(112)/3.)  
4491         ELSE    
4492           IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN   
4493             PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)    
4494           ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN   
4495             PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)   
4496           ELSEIF(KFLS.EQ.2) THEN    
4497             PMSPL=-3./(PMB*PMC) 
4498           ELSE  
4499             PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)    
4500           ENDIF 
4501           ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL 
4502         ENDIF   
4503       ENDIF 
4504     
4505 C...Optional mass broadening according to truncated Breit-Wigner    

4506 C...(either in m or in m^2).    

4507       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN 
4508         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN    
4509           ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*  
4510      &    ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))   
4511         ELSE    
4512           PM0=ULMASS    
4513           PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/    
4514      &    (PM0*PMAS(KC,2))) 
4515           PMUPP=ATAN((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))   
4516           ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+   
4517      &    (PMUPP-PMLOW)*RLU(0))))   
4518         ENDIF   
4519       ENDIF 
4520       MSTJ(93)=0    
4521     
4522       RETURN    
4523       END   
4524     
4525 C*********************************************************************  

4526     
4527       SUBROUTINE LUNAME(KF,CHAU)    
4528     
4529 C...Purpose: to give the particle/parton name as a character string.    

4530       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4531       SAVE /LUDAT1/ 
4532       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4533       SAVE /LUDAT2/ 
4534       COMMON/LUDAT4/CHAF(500)   
4535       CHARACTER CHAF*8  
4536       SAVE /LUDAT4/ 
4537       CHARACTER CHAU*16 
4538     
4539 C...Initial values. Charge. Subdivide code. 

4540       CHAU=' '  
4541       KFA=IABS(KF)  
4542       KC=LUCOMP(KF) 
4543       IF(KC.EQ.0) RETURN    
4544       KQ=LUCHGE(KF) 
4545       KFLA=MOD(KFA/1000,10) 
4546       KFLB=MOD(KFA/100,10)  
4547       KFLC=MOD(KFA/10,10)   
4548       KFLS=MOD(KFA,10)  
4549       KFLR=MOD(KFA/10000,10)    
4550     
4551 C...Read out root name and spin for simple particle.    

4552       IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN 
4553         CHAU=CHAF(KC)   
4554         LEN=0   
4555         DO 100 LEM=1,8  
4556   100   IF(CHAU(LEM:LEM).NE.' ') LEN=LEM    
4557     
4558 C...Construct root name for diquark. Add on spin.   

4559       ELSEIF(KFLC.EQ.0) THEN    
4560         CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)  
4561         IF(KFLS.EQ.1) CHAU(3:4)='_0'    
4562         IF(KFLS.EQ.3) CHAU(3:4)='_1'    
4563         LEN=4   
4564     
4565 C...Construct root name for heavy meson. Add on spin and heavy flavour. 

4566       ELSEIF(KFLA.EQ.0) THEN    
4567         IF(KFLB.EQ.5) CHAU(1:1)='B' 
4568         IF(KFLB.EQ.6) CHAU(1:1)='T' 
4569         IF(KFLB.EQ.7) CHAU(1:1)='L' 
4570         IF(KFLB.EQ.8) CHAU(1:1)='H' 
4571         LEN=1   
4572         IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN    
4573         ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN    
4574           CHAU(2:2)='*' 
4575           LEN=2 
4576         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN    
4577           CHAU(2:3)='_1'    
4578           LEN=3 
4579         ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN    
4580           CHAU(2:4)='*_0'   
4581           LEN=4 
4582         ELSEIF(KFLR.EQ.2) THEN  
4583           CHAU(2:4)='*_1'   
4584           LEN=4 
4585         ELSEIF(KFLS.EQ.5) THEN  
4586           CHAU(2:4)='*_2'   
4587           LEN=4 
4588         ENDIF   
4589         IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN  
4590           CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)    
4591           LEN=LEN+2 
4592         ELSEIF(KFLC.GE.3) THEN  
4593           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1) 
4594           LEN=LEN+1 
4595         ENDIF   
4596     
4597 C...Construct root name and spin for heavy baryon.  

4598       ELSE  
4599         IF(KFLB.LE.2.AND.KFLC.LE.2) THEN    
4600           CHAU='Sigma ' 
4601           IF(KFLC.GT.KFLB) CHAU='Lambda'    
4602           IF(KFLS.EQ.4) CHAU='Sigma*'   
4603           LEN=5 
4604           IF(CHAU(6:6).NE.' ') LEN=6    
4605         ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN 
4606           CHAU='Xi '    
4607           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi''' 
4608           IF(KFLS.EQ.4) CHAU='Xi*'  
4609           LEN=2 
4610           IF(CHAU(3:3).NE.' ') LEN=3    
4611         ELSE    
4612           CHAU='Omega ' 
4613           IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''  
4614           IF(KFLS.EQ.4) CHAU='Omega*'   
4615           LEN=5 
4616           IF(CHAU(6:6).NE.' ') LEN=6    
4617         ENDIF   
4618     
4619 C...Add on heavy flavour content for heavy baryon.  

4620         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)  
4621         LEN=LEN+2   
4622         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN 
4623           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)    
4624           LEN=LEN+2 
4625         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN 
4626           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1) 
4627           LEN=LEN+1 
4628         ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN 
4629           CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)    
4630           LEN=LEN+2 
4631         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN 
4632           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1) 
4633           LEN=LEN+1 
4634         ENDIF   
4635       ENDIF 
4636     
4637 C...Add on bar sign for antiparticle (where necessary). 

4638       IF(KF.GT.0.OR.LEN.EQ.0) THEN  
4639       ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN  
4640       ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN   
4641       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN 
4642       ELSEIF(MSTU(15).LE.1) THEN    
4643         CHAU(LEN+1:LEN+1)='~'   
4644         LEN=LEN+1   
4645       ELSE  
4646         CHAU(LEN+1:LEN+3)='bar' 
4647         LEN=LEN+3   
4648       ENDIF 
4649     
4650 C...Add on charge where applicable (conventional cases skipped).    

4651       IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'    
4652       IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'   
4653       IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+' 
4654       IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'    
4655       IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN  
4656       ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN   
4657       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND. 
4658      &KFLB.NE.1) THEN   
4659       ELSEIF(KQ.EQ.0) THEN  
4660         CHAU(LEN+1:LEN+1)='0'   
4661       ENDIF 
4662     
4663       RETURN    
4664       END   
4665     
4666 C*********************************************************************  

4667     
4668       FUNCTION LUCHGE(KF)   
4669     
4670 C...Purpose: to give three times the charge for a particle/parton.  

4671       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4672       SAVE /LUDAT2/ 
4673     
4674 C...Initial values. Simple case of direct readout.  

4675       LUCHGE=0  
4676       KFA=IABS(KF)  
4677       KC=LUCOMP(KFA)    
4678       IF(KC.EQ.0) THEN  
4679       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN  
4680         LUCHGE=KCHG(KC,1)   
4681     
4682 C...Construction from quark content for heavy meson, diquark, baryon.   

4683       ELSEIF(MOD(KFA/1000,10).EQ.0) THEN    
4684         LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*    
4685      &  (-1)**MOD(KFA/100,10)   
4686       ELSEIF(MOD(KFA/10,10).EQ.0) THEN  
4687         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1) 
4688       ELSE  
4689         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+    
4690      &  KCHG(MOD(KFA/10,10),1)  
4691       ENDIF 
4692     
4693 C...Add on correct sign.    

4694       LUCHGE=LUCHGE*ISIGN(1,KF) 
4695     
4696       RETURN    
4697       END   
4698     
4699 C*********************************************************************  

4700     
4701       FUNCTION LUCOMP(KF)   
4702     
4703 C...Purpose: to compress the standard KF codes for use in mass and decay    

4704 C...arrays; also to check whether a given code actually is defined. 

4705       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4706       SAVE /LUDAT2/ 
4707     
4708 C...Subdivide KF code into constituent pieces.  

4709       LUCOMP=0  
4710       KFA=IABS(KF)  
4711       KFLA=MOD(KFA/1000,10) 
4712       KFLB=MOD(KFA/100,10)  
4713       KFLC=MOD(KFA/10,10)   
4714       KFLS=MOD(KFA,10)  
4715       KFLR=MOD(KFA/10000,10)    
4716     
4717 C...Simple cases: direct translation or special codes.  

4718       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN    
4719       ELSEIF(KFA.LE.100) THEN   
4720         LUCOMP=KFA  
4721         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0   
4722       ELSEIF(KFLS.EQ.0) THEN    
4723         IF(KF.EQ.130) LUCOMP=221    
4724         IF(KF.EQ.310) LUCOMP=222    
4725         IF(KFA.EQ.210) LUCOMP=281   
4726         IF(KFA.EQ.2110) LUCOMP=282  
4727         IF(KFA.EQ.2210) LUCOMP=283  
4728     
4729 C...Mesons. 

4730       ELSEIF(KFA-10000*KFLR.LT.1000) THEN   
4731         IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN   
4732         ELSEIF(KFLB.LT.KFLC) THEN   
4733         ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN   
4734         ELSEIF(KFLB.EQ.KFLC) THEN   
4735           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN  
4736             LUCOMP=110+KFLB 
4737           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN  
4738             LUCOMP=130+KFLB 
4739           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN  
4740             LUCOMP=150+KFLB 
4741           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN  
4742             LUCOMP=170+KFLB 
4743           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN  
4744             LUCOMP=190+KFLB 
4745           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN  
4746             LUCOMP=210+KFLB 
4747           ENDIF 
4748         ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN    
4749           IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN  
4750             LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC   
4751           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN  
4752             LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC   
4753           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN  
4754             LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC   
4755           ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN  
4756             LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC   
4757           ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN  
4758             LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC   
4759           ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN  
4760             LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC   
4761           ENDIF 
4762         ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).  
4763      &  OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN  
4764           LUCOMP=80+KFLB    
4765         ENDIF   
4766     
4767 C...Diquarks.   

4768       ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN   
4769         IF(KFLS.NE.1.AND.KFLS.NE.3) THEN    
4770         ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN    
4771         ELSEIF(KFLA.LT.KFLB) THEN   
4772         ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN 
4773         ELSE    
4774           LUCOMP=90 
4775         ENDIF   
4776     
4777 C...Spin 1/2 baryons.   

4778       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN  
4779         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN   
4780         ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN   
4781         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN    
4782           LUCOMP=80+KFLA    
4783         ELSEIF(KFLB.LT.KFLC) THEN   
4784           LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB  
4785         ELSE    
4786           LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC  
4787         ENDIF   
4788     
4789 C...Spin 3/2 baryons.   

4790       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN  
4791         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN   
4792         ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN   
4793         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN 
4794           LUCOMP=80+KFLA    
4795         ELSE    
4796           LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC  
4797         ENDIF   
4798       ENDIF 
4799     
4800       RETURN    
4801       END   
4802     
4803 C*********************************************************************  

4804     
4805       SUBROUTINE LUERRM(MERR,CHMESS)    
4806     
4807 C...Purpose: to inform user of errors in program execution. 

4808       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4809       SAVE /LUJETS/ 
4810       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4811       SAVE /LUDAT1/ 
4812       CHARACTER CHMESS*(*)  
4813 
4814       write (6,*) 'merr,chmess=',merr,chmess
4815     
4816 C...Write first few warnings, then be silent.   

4817       IF(MERR.LE.10) THEN   
4818         MSTU(27)=MSTU(27)+1 
4819         MSTU(28)=MERR   
4820         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000) 
4821      &  MERR,MSTU(31),CHMESS    
4822     
4823 C...Write first few errors, then be silent or stop program. 

4824       ELSEIF(MERR.LE.20) THEN   
4825         MSTU(23)=MSTU(23)+1 
4826         MSTU(24)=MERR-10    
4827         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100) 
4828      &  MERR-10,MSTU(31),CHMESS 
4829         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN 
4830           WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS  
4831           WRITE(MSTU(11),1200)  
4832           IF(MERR.NE.17) CALL LULIST(2) 
4833           STOP  
4834         ENDIF   
4835     
4836 C...Stop program in case of irreparable error.  

4837       ELSE  
4838         WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS    
4839         STOP    
4840       ENDIF 
4841     
4842 C...Formats for output. 

4843  1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,  
4844      &' LUEXEC calls:'/5X,A)    
4845  1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,   
4846      &' LUEXEC calls:'/5X,A)    
4847  1200 FORMAT(5X,'Execution will be stopped after listing of last ', 
4848      &'event!') 
4849  1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6, 
4850      &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')    
4851     
4852       RETURN    
4853       END   
4854     
4855 C*********************************************************************  

4856     
4857       FUNCTION ULALPS(Q2)   
4858     
4859 C...Purpose: to give the value of alpha_strong. 

4860       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4861       SAVE /LUDAT1/ 
4862       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4863       SAVE /LUDAT2/ 
4864     
4865 C...Constant alpha_strong trivial.  

4866       IF(MSTU(111).LE.0) THEN   
4867         ULALPS=PARU(111)    
4868         MSTU(118)=MSTU(112) 
4869         PARU(117)=0.    
4870         PARU(118)=PARU(111) 
4871         RETURN  
4872       ENDIF 
4873     
4874 C...Find effective Q2, number of flavours and Lambda.   

4875       Q2EFF=Q2  
4876       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))    
4877       NF=MSTU(112)  
4878       ALAM2=PARU(112)**2    
4879   100 IF(NF.GT.MAX(2,MSTU(113))) THEN   
4880         Q2THR=PARU(113)*PMAS(NF,1)**2   
4881         IF(Q2EFF.LT.Q2THR) THEN 
4882           NF=NF-1   
4883           ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))   
4884           GOTO 100  
4885         ENDIF   
4886       ENDIF 
4887   110 IF(NF.LT.MIN(8,MSTU(114))) THEN   
4888         Q2THR=PARU(113)*PMAS(NF+1,1)**2 
4889         IF(Q2EFF.GT.Q2THR) THEN 
4890           NF=NF+1   
4891           ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))   
4892           GOTO 110  
4893         ENDIF   
4894       ENDIF 
4895       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2  
4896       PARU(117)=SQRT(ALAM2) 
4897     
4898 C...Evaluate first or second order alpha_strong.    

4899       B0=(33.-2.*NF)/6. 
4900       ALGQ=LOG(Q2EFF/ALAM2) 
4901       IF(MSTU(111).EQ.1) THEN   
4902         ULALPS=PARU(2)/(B0*ALGQ)    
4903       ELSE  
4904         B1=(153.-19.*NF)/6. 
4905         ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ)) 
4906       ENDIF 
4907       MSTU(118)=NF  
4908       PARU(118)=ULALPS  
4909     
4910       RETURN    
4911       END   
4912     
4913 C*********************************************************************  

4914     
4915       FUNCTION ULANGL(X,Y)  
4916     
4917 C...Purpose: to reconstruct an angle from given x and y coordinates.    

4918       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4919       SAVE /LUDAT1/ 
4920     
4921       ULANGL=0. 
4922       R=SQRT(X**2+Y**2) 
4923       IF(R.LT.1E-20) RETURN 
4924       IF(ABS(X)/R.LT.0.8) THEN  
4925         ULANGL=SIGN(ACOS(X/R),Y)    
4926       ELSE  
4927         ULANGL=ASIN(Y/R)    
4928         IF(X.LT.0..AND.ULANGL.GE.0.) THEN   
4929           ULANGL=PARU(1)-ULANGL 
4930         ELSEIF(X.LT.0.) THEN    
4931           ULANGL=-PARU(1)-ULANGL    
4932         ENDIF   
4933       ENDIF 
4934     
4935       RETURN    
4936       END   
4937     
4938 C*********************************************************************  

4939     
4940       FUNCTION RLU(IDUM)    
4941     
4942 C...Purpose: to generate random numbers uniformly distributed between   

4943 C...0 and 1, excluding the endpoints.   

4944       COMMON/LUDATR/MRLU(6),RRLU(100)   
4945       SAVE /LUDATR/ 
4946       EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),  
4947      &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),  
4948      &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))    
4949     
4950 C...Initialize generation from given seed.  

4951       IF(MRLU2.EQ.0) THEN   
4952         IJ=MOD(MRLU1/30082,31329)   
4953         KL=MOD(MRLU1,30082) 
4954         I=MOD(IJ/177,177)+2 
4955         J=MOD(IJ,177)+2 
4956         K=MOD(KL/169,178)+1 
4957         L=MOD(KL,169)   
4958         DO 110 II=1,97  
4959         S=0.    
4960         T=0.5   
4961         DO 100 JJ=1,24  
4962         M=MOD(MOD(I*J,179)*K,179)   
4963         I=J 
4964         J=K 
4965         K=M 
4966         L=MOD(53*L+1,169)   
4967         IF(MOD(L*M,64).GE.32) S=S+T 
4968   100   T=0.5*T 
4969   110   RRLU(II)=S  
4970         TWOM24=1.   
4971         DO 120 I24=1,24 
4972   120   TWOM24=0.5*TWOM24   
4973         RRLU98=362436.*TWOM24   
4974         RRLU99=7654321.*TWOM24  
4975         RRLU00=16777213.*TWOM24 
4976         MRLU2=1 
4977         MRLU3=0 
4978         MRLU4=97    
4979         MRLU5=33    
4980       ENDIF 
4981     
4982 C...Generate next random number.    

4983   130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)  
4984       IF(RUNI.LT.0.) RUNI=RUNI+1.   
4985       RRLU(MRLU4)=RUNI  
4986       MRLU4=MRLU4-1 
4987       IF(MRLU4.EQ.0) MRLU4=97   
4988       MRLU5=MRLU5-1 
4989       IF(MRLU5.EQ.0) MRLU5=97   
4990       RRLU98=RRLU98-RRLU99  
4991       IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00 
4992       RUNI=RUNI-RRLU98  
4993       IF(RUNI.LT.0.) RUNI=RUNI+1.   
4994       IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130  
4995     
4996 C...Update counters. Random number to output.   

4997       MRLU3=MRLU3+1 
4998       IF(MRLU3.EQ.1000000000) THEN  
4999         MRLU2=MRLU2+1   
5000         MRLU3=0 
5001       ENDIF 
5002       RLU=RUNI  
5003     
5004       RETURN    
5005       END   
5006     
5007 C*********************************************************************  

5008     
5009       SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)    
5010     
5011 C...Purpose: to perform rotations and boosts.   

5012       IMPLICIT DOUBLE PRECISION(D)  
5013       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5014       SAVE /LUJETS/ 
5015       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5016       SAVE /LUDAT1/ 
5017       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)    
5018     
5019 C...Find range of rotation/boost. Convert boost to double precision.    

5020       IMIN=1    
5021       IF(MSTU(1).GT.0) IMIN=MSTU(1) 
5022       IMAX=N    
5023       IF(MSTU(2).GT.0) IMAX=MSTU(2) 
5024       DBX=dble(BEX)
5025       DBY=dble(BEY)
5026       DBZ=dble(BEZ)
5027       GOTO 100  
5028     
5029 C...Entry for specific range and double precision boost.    

5030       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)  
5031       IMIN=IMI  
5032       IF(IMIN.LE.0) IMIN=1  
5033       IMAX=IMA  
5034       IF(IMAX.LE.0) IMAX=N  
5035       DBX=DBEX  
5036       DBY=DBEY  
5037       DBZ=DBEZ  
5038     
5039 C...Check range of rotation/boost.  

5040   100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN   
5041         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory') 
5042         RETURN  
5043       ENDIF 
5044     
5045 C...Rotate, typically from z axis to direction (theta,phi). 

5046 clin-5/2012:

5047 c      IF(THE**2+PHI**2.GT.1E-20) THEN   

5048       IF((THE**2+PHI**2).GT.1E-20) THEN   
5049         ROT(1,1)=COS(THE)*COS(PHI)  
5050         ROT(1,2)=-SIN(PHI)  
5051         ROT(1,3)=SIN(THE)*COS(PHI)  
5052         ROT(2,1)=COS(THE)*SIN(PHI)  
5053         ROT(2,2)=COS(PHI)   
5054         ROT(2,3)=SIN(THE)*SIN(PHI)  
5055         ROT(3,1)=-SIN(THE)  
5056         ROT(3,2)=0. 
5057         ROT(3,3)=COS(THE)   
5058         DO 130 I=IMIN,IMAX  
5059         IF(K(I,1).LE.0) GOTO 130    
5060         DO 110 J=1,3    
5061         PR(J)=P(I,J)    
5062   110   VR(J)=V(I,J)    
5063         DO 120 J=1,3    
5064         P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) 
5065   120   V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3) 
5066   130   CONTINUE    
5067       ENDIF 
5068     
5069 C...Boost, typically from rest to momentum/energy=beta. 

5070 clin-5/2012:

5071 c      IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN    

5072       IF((DBX**2+DBY**2+DBZ**2).GT.1D-20) THEN    
5073         DB=SQRT(DBX**2+DBY**2+DBZ**2)   
5074         IF(DB.GT.0.99999999D0) THEN 
5075 C...Rescale boost vector if too close to unity. 

5076           CALL LUERRM(3,'(LUROBO:) boost vector too large') 
5077           DBX=DBX*(0.99999999D0/DB) 
5078           DBY=DBY*(0.99999999D0/DB) 
5079           DBZ=DBZ*(0.99999999D0/DB) 
5080           DB=0.99999999D0   
5081         ENDIF   
5082         DGA=1D0/SQRT(1D0-DB**2) 
5083         DO 150 I=IMIN,IMAX  
5084         IF(K(I,1).LE.0) GOTO 150    
5085         DO 140 J=1,4    
5086         DP(J)=dble(P(I,J))
5087   140   DV(J)=dble(V(I,J))
5088         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)   
5089         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) 
5090         P(I,1)=sngl(DP(1)+DGABP*DBX)
5091         P(I,2)=sngl(DP(2)+DGABP*DBY) 
5092         P(I,3)=sngl(DP(3)+DGABP*DBZ) 
5093         P(I,4)=sngl(DGA*(DP(4)+DBP)) 
5094         DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)   
5095         DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4)) 
5096         V(I,1)=sngl(DV(1)+DGABV*DBX) 
5097         V(I,2)=sngl(DV(2)+DGABV*DBY) 
5098         V(I,3)=sngl(DV(3)+DGABV*DBZ) 
5099         V(I,4)=sngl(DGA*(DV(4)+DBV))
5100   150   CONTINUE    
5101       ENDIF 
5102     
5103       RETURN    
5104       END   
5105     
5106 C*********************************************************************  

5107 C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST

5108 C        THE FOUR MOMENTUM ONLY

5109 C*********************************************************************

5110     
5111       SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)    
5112     
5113 C...Purpose: to perform rotations and boosts.   

5114       IMPLICIT DOUBLE PRECISION(D)  
5115       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5116       SAVE /LUJETS/ 
5117       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5118       SAVE /LUDAT1/ 
5119       DIMENSION ROT(3,3),PR(3),DP(4)
5120 cms      VR(3),DV(4)    

5121     
5122 C...Find range of rotation/boost. Convert boost to double precision.    

5123       IMIN=1    
5124       IF(MSTU(1).GT.0) IMIN=MSTU(1) 
5125       IMAX=N    
5126       IF(MSTU(2).GT.0) IMAX=MSTU(2) 
5127       DBX=dble(BEX)
5128       DBY=dble(BEY) 
5129       DBZ=dble(BEZ)  
5130     
5131 C...Check range of rotation/boost.  

5132       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN   
5133         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory') 
5134         RETURN  
5135       ENDIF 
5136     
5137 C...Rotate, typically from z axis to direction (theta,phi). 

5138 clin-5/2012:

5139 c      IF(THE**2+PHI**2.GT.1E-20) THEN   

5140       IF((THE**2+PHI**2).GT.1E-20) THEN   
5141         ROT(1,1)=COS(THE)*COS(PHI)  
5142         ROT(1,2)=-SIN(PHI)  
5143         ROT(1,3)=SIN(THE)*COS(PHI)  
5144         ROT(2,1)=COS(THE)*SIN(PHI)  
5145         ROT(2,2)=COS(PHI)   
5146         ROT(2,3)=SIN(THE)*SIN(PHI)  
5147         ROT(3,1)=-SIN(THE)  
5148         ROT(3,2)=0. 
5149         ROT(3,3)=COS(THE)   
5150         DO 130 I=IMIN,IMAX  
5151         IF(K(I,1).LE.0) GOTO 130    
5152         DO 110 J=1,3    
5153   110   PR(J)=P(I,J)   
5154         DO 120 J=1,3    
5155   120   P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) 
5156   130   CONTINUE    
5157       ENDIF 
5158     
5159 C...Boost, typically from rest to momentum/energy=beta. 

5160 clin-5/2012:

5161 c      IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN    

5162       IF((DBX**2+DBY**2+DBZ**2).GT.1D-20) THEN    
5163         DB=SQRT(DBX**2+DBY**2+DBZ**2)   
5164         IF(DB.GT.0.99999999D0) THEN 
5165 C...Rescale boost vector if too close to unity. 

5166           CALL LUERRM(3,'(LUROBO:) boost vector too large') 
5167           DBX=DBX*(0.99999999D0/DB) 
5168           DBY=DBY*(0.99999999D0/DB) 
5169           DBZ=DBZ*(0.99999999D0/DB) 
5170           DB=0.99999999D0   
5171         ENDIF   
5172         DGA=1D0/SQRT(1D0-DB**2) 
5173         DO 150 I=IMIN,IMAX  
5174         IF(K(I,1).LE.0) GOTO 150    
5175         DO 140 J=1,4    
5176   140   DP(J)=dble(P(I,J))
5177         DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)   
5178         DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) 
5179         P(I,1)=sngl(DP(1)+DGABP*DBX)
5180         P(I,2)=sngl(DP(2)+DGABP*DBY) 
5181         P(I,3)=sngl(DP(3)+DGABP*DBZ) 
5182         P(I,4)=sngl(DGA*(DP(4)+DBP)) 
5183   150   CONTINUE    
5184       ENDIF 
5185     
5186       RETURN    
5187       END   
5188     
5189 C*********************************************************************  

5190     
5191       SUBROUTINE LUEDIT(MEDIT)  
5192     
5193 C...Purpose: to perform global manipulations on the event record,   

5194 C...in particular to exclude unstable or undetectable partons/particles.    

5195       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5196       SAVE /LUJETS/ 
5197       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5198       SAVE /LUDAT1/ 
5199       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5200       SAVE /LUDAT2/ 
5201       DIMENSION NS(2),PTS(2),PLS(2) 
5202     
5203 C...Remove unwanted partons/particles.  

5204       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN    
5205         IMAX=N  
5206         IF(MSTU(2).GT.0) IMAX=MSTU(2)   
5207         I1=MAX(1,MSTU(1))-1 
5208         DO 110 I=MAX(1,MSTU(1)),IMAX    
5209         IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110    
5210         IF(MEDIT.EQ.1) THEN 
5211           IF(K(I,1).GT.10) GOTO 110 
5212         ELSEIF(MEDIT.EQ.2) THEN 
5213           IF(K(I,1).GT.10) GOTO 110 
5214           KC=LUCOMP(K(I,2)) 
5215           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)   
5216      &    GOTO 110  
5217         ELSEIF(MEDIT.EQ.3) THEN 
5218           IF(K(I,1).GT.10) GOTO 110 
5219           KC=LUCOMP(K(I,2)) 
5220           IF(KC.EQ.0) GOTO 110  
5221           IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110  
5222         ELSEIF(MEDIT.EQ.5) THEN 
5223           IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110 
5224           KC=LUCOMP(K(I,2)) 
5225           IF(KC.EQ.0) GOTO 110  
5226           IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110 
5227         ENDIF   
5228     
5229 C...Pack remaining partons/particles. Origin no longer known.   

5230         I1=I1+1 
5231         DO 100 J=1,5    
5232         K(I1,J)=K(I,J)  
5233         P(I1,J)=P(I,J)  
5234   100   V(I1,J)=V(I,J)  
5235         K(I1,3)=0   
5236   110   CONTINUE    
5237         N=I1    
5238     
5239 C...Selective removal of class of entries. New position of retained.    

5240       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN  
5241         I1=0    
5242         DO 120 I=1,N    
5243         K(I,3)=MOD(K(I,3),MSTU(5))  
5244         IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120    
5245         IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120    
5246         IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.    
5247      &  K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120    
5248         IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.    
5249      &  K(I,2).EQ.94)) GOTO 120 
5250         IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120   
5251         I1=I1+1 
5252         K(I,3)=K(I,3)+MSTU(5)*I1    
5253   120   CONTINUE    
5254     
5255 C...Find new event history information and replace old. 

5256         DO 140 I=1,N    
5257         IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140 
5258         ID=I    
5259   130   IM=MOD(K(ID,3),MSTU(5)) 
5260         IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN    
5261           IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND. 
5262      &    K(IM,2).NE.94) THEN   
5263             ID=IM   
5264             GOTO 130    
5265           ENDIF 
5266         ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN    
5267           IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN  
5268             ID=IM   
5269             GOTO 130    
5270           ENDIF 
5271         ENDIF   
5272         K(I,3)=MSTU(5)*(K(I,3)/MSTU(5)) 
5273         IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)   
5274         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN  
5275           IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)= 
5276      &    K(K(I,4),3)/MSTU(5)   
5277           IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)= 
5278      &    K(K(I,5),3)/MSTU(5)   
5279         ELSE    
5280           KCM=MOD(K(I,4)/MSTU(5),MSTU(5))   
5281           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)  
5282           KCD=MOD(K(I,4),MSTU(5))   
5283           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)  
5284           K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD 
5285           KCM=MOD(K(I,5)/MSTU(5),MSTU(5))   
5286           IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)  
5287           KCD=MOD(K(I,5),MSTU(5))   
5288           IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)  
5289           K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD 
5290         ENDIF   
5291   140   CONTINUE    
5292     
5293 C...Pack remaining entries. 

5294         I1=0    
5295         DO 160 I=1,N    
5296         IF(K(I,3)/MSTU(5).EQ.0) GOTO 160    
5297         I1=I1+1 
5298         DO 150 J=1,5    
5299         K(I1,J)=K(I,J)  
5300         P(I1,J)=P(I,J)  
5301   150   V(I1,J)=V(I,J)  
5302         K(I1,3)=MOD(K(I1,3),MSTU(5))    
5303   160   CONTINUE    
5304         N=I1    
5305     
5306 C...Save top entries at bottom of LUJETS commonblock.   

5307       ELSEIF(MEDIT.EQ.21) THEN  
5308         IF(2*N.GE.MSTU(4)) THEN 
5309           CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS') 
5310           RETURN    
5311         ENDIF   
5312         DO 170 I=1,N    
5313         DO 170 J=1,5    
5314         K(MSTU(4)-I,J)=K(I,J)   
5315         P(MSTU(4)-I,J)=P(I,J)   
5316   170   V(MSTU(4)-I,J)=V(I,J)   
5317         MSTU(32)=N  
5318     
5319 C...Restore bottom entries of commonblock LUJETS to top.    

5320       ELSEIF(MEDIT.EQ.22) THEN  
5321         DO 180 I=1,MSTU(32) 
5322         DO 180 J=1,5    
5323         K(I,J)=K(MSTU(4)-I,J)   
5324         P(I,J)=P(MSTU(4)-I,J)   
5325   180   V(I,J)=V(MSTU(4)-I,J)   
5326         N=MSTU(32)  
5327     
5328 C...Mark primary entries at top of commonblock LUJETS as untreated. 

5329       ELSEIF(MEDIT.EQ.23) THEN  
5330         I1=0    
5331         DO 190 I=1,N    
5332         KH=K(I,3)   
5333         IF(KH.GE.1) THEN    
5334           IF(K(KH,1).GT.20) KH=0    
5335         ENDIF   
5336         IF(KH.NE.0) GOTO 200    
5337         I1=I1+1 
5338   190   IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10  
5339   200   N=I1    
5340     
5341 C...Place largest axis along z axis and second largest in xy plane. 

5342       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN   
5343         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),   
5344      &  P(MSTU(61),2)),0D0,0D0,0D0) 
5345         CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),  
5346      &  P(MSTU(61),1)),0.,0D0,0D0,0D0)  
5347         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1), 
5348      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)   
5349         IF(MEDIT.EQ.31) RETURN  
5350     
5351 C...Rotate to put slim jet along +z axis.   

5352         DO 210 IS=1,2   
5353         NS(IS)=0    
5354         PTS(IS)=0.  
5355   210   PLS(IS)=0.  
5356         DO 220 I=1,N    
5357         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 220    
5358         IF(MSTU(41).GE.2) THEN  
5359           KC=LUCOMP(K(I,2)) 
5360           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.    
5361      &    KC.EQ.18) GOTO 220    
5362           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) 
5363      &    GOTO 220  
5364         ENDIF   
5365         IS=int(2.-SIGN(0.5,P(I,3)))
5366         NS(IS)=NS(IS)+1 
5367         PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)   
5368   220   CONTINUE    
5369         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)  
5370      &  CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0) 
5371     
5372 C...Rotate to put second largest jet into -z,+x quadrant.   

5373         DO 230 I=1,N    
5374         IF(P(I,3).GE.0.) GOTO 230   
5375         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230    
5376         IF(MSTU(41).GE.2) THEN  
5377           KC=LUCOMP(K(I,2)) 
5378           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.    
5379      &    KC.EQ.18) GOTO 230    
5380           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) 
5381      &    GOTO 230  
5382         ENDIF   
5383         IS=int(2.-SIGN(0.5,P(I,1)))
5384         PLS(IS)=PLS(IS)-P(I,3)  
5385   230   CONTINUE    
5386         IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),    
5387      &  0D0,0D0,0D0)    
5388       ENDIF 
5389     
5390       RETURN    
5391       END   
5392     
5393 C*********************************************************************  

5394     
5395       SUBROUTINE LULIST(MLIST)  
5396     
5397 C...Purpose: to give program heading, or list an event, or particle 

5398 C...data, or current parameter values.  

5399       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5400       SAVE /LUJETS/ 
5401       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5402       SAVE /LUDAT1/ 
5403       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5404       SAVE /LUDAT2/ 
5405       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
5406       SAVE /LUDAT3/ 
5407       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4 
5408       DIMENSION PS(6)   
5409       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
5410      &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/    
5411     
5412 C...Initialization printout: version number and date of last change.    

5413 C      IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN  

5414 C        WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185), 

5415 C     &  CHMO(MSTU(184)),MSTU(183)   

5416 C        MSTU(12)=0  

5417 C        IF(MLIST.EQ.0) RETURN   

5418 C      ENDIF 

5419     
5420 C...List event data, including additional lines after N.    

5421       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN    
5422         IF(MLIST.EQ.1) WRITE(MSTU(11),1100) 
5423         IF(MLIST.EQ.2) WRITE(MSTU(11),1200) 
5424         IF(MLIST.EQ.3) WRITE(MSTU(11),1300) 
5425         LMX=12  
5426         IF(MLIST.GE.2) LMX=16   
5427         ISTR=0  
5428         IMAX=N  
5429         IF(MSTU(2).GT.0) IMAX=MSTU(2)   
5430         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))  
5431         IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120  
5432     
5433 C...Get particle name, pad it and check it is not too long. 

5434         CALL LUNAME(K(I,2),CHAP)    
5435         LEN=0   
5436         DO 100 LEM=1,16 
5437   100   IF(CHAP(LEM:LEM).NE.' ') LEN=LEM    
5438         MDL=(K(I,1)+19)/10  
5439         LDL=0   
5440         IF(MDL.EQ.2.OR.MDL.GE.8) THEN   
5441           CHAC=CHAP 
5442           IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'  
5443         ELSE    
5444           LDL=1 
5445           IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2    
5446           IF(LEN.EQ.0) THEN 
5447             CHAC=CHDL(MDL)(1:2*LDL)//' '    
5448           ELSE  
5449             CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))// 
5450      &      CHDL(MDL)(LDL+1:2*LDL)//' ' 
5451             IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'  
5452           ENDIF 
5453         ENDIF   
5454     
5455 C...Add information on string connection.   

5456         IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)  
5457      &  THEN    
5458           KC=LUCOMP(K(I,2)) 
5459           KCC=0 
5460           IF(KC.NE.0) KCC=KCHG(KC,2)    
5461           IF(KCC.NE.0.AND.ISTR.EQ.0) THEN   
5462             ISTR=1  
5463             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'    
5464           ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN   
5465             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'    
5466           ELSEIF(KCC.NE.0) THEN 
5467             ISTR=0  
5468             IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'    
5469           ENDIF 
5470         ENDIF   
5471     
5472 C...Write data for particle/jet.    

5473         IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN    
5474           WRITE(MSTU(11),1400) I,CHAC(1:12),(K(I,J1),J1=1,3),   
5475      &    (P(I,J2),J2=1,5)  
5476         ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN   
5477           WRITE(MSTU(11),1500) I,CHAC(1:12),(K(I,J1),J1=1,3),   
5478      &    (P(I,J2),J2=1,5)  
5479         ELSEIF(MLIST.EQ.1) THEN 
5480           WRITE(MSTU(11),1600) I,CHAC(1:12),(K(I,J1),J1=1,3),   
5481      &    (P(I,J2),J2=1,5)  
5482         ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.    
5483      &  K(I,1).EQ.14)) THEN 
5484           WRITE(MSTU(11),1700) I,CHAC,(K(I,J1),J1=1,3), 
5485      &    K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),   
5486      &    K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),   
5487      &    (P(I,J2),J2=1,5)  
5488         ELSE    
5489           WRITE(MSTU(11),1800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5) 
5490         ENDIF   
5491         IF(MLIST.EQ.3) WRITE(MSTU(11),1900) (V(I,J),J=1,5)  
5492     
5493 C...Insert extra separator lines specified by user. 

5494         IF(MSTU(70).GE.1) THEN  
5495           ISEP=0    
5496           DO 110 J=1,MIN(10,MSTU(70))   
5497   110     IF(I.EQ.MSTU(70+J)) ISEP=1    
5498           IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000) 
5499           IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100) 
5500         ENDIF   
5501   120   CONTINUE    
5502     
5503 C...Sum of charges and momenta. 

5504         DO 130 J=1,6    
5505   130   PS(J)=PLU(0,J)  
5506         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN 
5507           WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)  
5508         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN    
5509           WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)  
5510         ELSEIF(MLIST.EQ.1) THEN 
5511           WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)  
5512         ELSE    
5513           WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)  
5514         ENDIF   
5515     
5516 C...Give simple list of KF codes defined in program.    

5517       ELSEIF(MLIST.EQ.11) THEN  
5518         WRITE(MSTU(11),2600)    
5519         DO 140 KF=1,40  
5520         CALL LUNAME(KF,CHAP)    
5521         CALL LUNAME(-KF,CHAN)   
5522         IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),2700) KF,CHAP    
5523   140   IF(CHAN.NE.' ') WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5524         DO 150 KFLS=1,3,2   
5525         DO 150 KFLA=1,8 
5526         DO 150 KFLB=1,KFLA-(3-KFLS)/2   
5527         KF=1000*KFLA+100*KFLB+KFLS  
5528         CALL LUNAME(KF,CHAP)    
5529         CALL LUNAME(-KF,CHAN)   
5530   150   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5531         DO 170 KMUL=0,5 
5532         KFLS=3  
5533         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1   
5534         IF(KMUL.EQ.5) KFLS=5    
5535         KFLR=0  
5536         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1   
5537         IF(KMUL.EQ.4) KFLR=2    
5538         DO 170 KFLB=1,8 
5539         DO 160 KFLC=1,KFLB-1    
5540         KF=10000*KFLR+100*KFLB+10*KFLC+KFLS 
5541         CALL LUNAME(KF,CHAP)    
5542         CALL LUNAME(-KF,CHAN)   
5543   160   WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5544         KF=10000*KFLR+110*KFLB+KFLS 
5545         CALL LUNAME(KF,CHAP)    
5546   170   WRITE(MSTU(11),2700) KF,CHAP    
5547         KF=130  
5548         CALL LUNAME(KF,CHAP)    
5549         WRITE(MSTU(11),2700) KF,CHAP    
5550         KF=310  
5551         CALL LUNAME(KF,CHAP)    
5552         WRITE(MSTU(11),2700) KF,CHAP    
5553         DO 190 KFLSP=1,3    
5554         KFLS=2+2*(KFLSP/3)  
5555         DO 190 KFLA=1,8 
5556         DO 190 KFLB=1,KFLA  
5557         DO 180 KFLC=1,KFLB  
5558         IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180  
5559         IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180    
5560         IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS   
5561         IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS   
5562         CALL LUNAME(KF,CHAP)    
5563         CALL LUNAME(-KF,CHAN)   
5564         WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN   
5565   180   CONTINUE    
5566   190   CONTINUE    
5567     
5568 C...List parton/particle data table. Check whether to be listed.    

5569       ELSEIF(MLIST.EQ.12) THEN  
5570         WRITE(MSTU(11),2800)    
5571         MSTJ24=MSTJ(24) 
5572         MSTJ(24)=0  
5573         KFMAX=20883 
5574         IF(MSTU(2).NE.0) KFMAX=MSTU(2)  
5575         DO 220 KF=MAX(1,MSTU(1)),KFMAX  
5576         KC=LUCOMP(KF)   
5577         IF(KC.EQ.0) GOTO 220    
5578         IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220  
5579         IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10), 
5580      &  MOD(KF/100,10)).GT.MSTU(14)) GOTO 220   
5581     
5582 C...Find particle name and mass. Print information. 

5583         CALL LUNAME(KF,CHAP)    
5584         IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220  
5585         CALL LUNAME(-KF,CHAN)   
5586         PM=ULMASS(KF)   
5587         WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2), 
5588      &  KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)   
5589     
5590 C...Particle decay: channel number, branching ration, matrix element,   

5591 C...decay products. 

5592         IF(KF.GT.100.AND.KC.LE.100) GOTO 220    
5593         DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1   
5594         DO 200 J=1,5    
5595   200   CALL LUNAME(KFDP(IDC,J),CHAD(J))    
5596   210   WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC), 
5597      &  (CHAD(J),J=1,5) 
5598   220   CONTINUE    
5599         MSTJ(24)=MSTJ24 
5600     
5601 C...List parameter value table. 

5602       ELSEIF(MLIST.EQ.13) THEN  
5603         WRITE(MSTU(11),3100)    
5604         DO 230 I=1,200  
5605   230   WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)  
5606       ENDIF 
5607     
5608 C...Format statements for output on unit MSTU(11) (by default 6).   

5609 clin 1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/ 

5610 clin     &20X,'**  Last date of change:  ',I2,1X,A3,1X,I4,'  **'/)  

5611  1100 FORMAT(///28X,'Event listing (summary)'//4X,'I  particle/jet KS', 
5612      &5X,'KF orig    p_x      p_y      p_z       E        m'/)  
5613  1200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',   
5614      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',   
5615      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)  
5616  1300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',    
5617      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)', 
5618      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,   
5619      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)    
5620  1400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)  
5621  1500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)  
5622  1600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)  
5623  1700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)    
5624  1800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)    
5625  1900 FORMAT(66X,5(1X,F12.3))   
5626  2000 FORMAT(1X,78('='))    
5627  2100 FORMAT(1X,130('='))   
5628  2200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)  
5629  2300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)  
5630  2400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)  
5631  2500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',   
5632      &5F13.5)   
5633  2600 FORMAT(///20X,'List of KF codes in program'/) 
5634  2700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16) 
5635  2800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,   
5636      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,    
5637      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',    
5638      &1X,'ME',3X,'Br.rat.',4X,'decay products') 
5639  2900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),  
5640      &2X,F12.5,3X,I2)   
5641  3000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)    
5642  3100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',   
5643      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')  
5644  3200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)  
5645     
5646       RETURN    
5647       END   
5648     
5649 C*********************************************************************  

5650     
5651       FUNCTION PLU(I,J) 
5652     
5653 C...Purpose: to provide various real-valued event related data. 

5654       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5655       SAVE /LUJETS/ 
5656       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5657       SAVE /LUDAT1/ 
5658       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5659       SAVE /LUDAT2/ 
5660       DIMENSION PSUM(4) 
5661     
5662 C...Set default value. For I = 0 sum of momenta or charges, 

5663 C...or invariant mass of system.    

5664       PLU=0.    
5665       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN 
5666       ELSEIF(I.EQ.0.AND.J.LE.4) THEN    
5667         DO 100 I1=1,N   
5668   100   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)  
5669       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN    
5670         DO 110 J1=1,4   
5671         PSUM(J1)=0. 
5672         DO 110 I1=1,N   
5673   110   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)   
5674         PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))   
5675       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN    
5676         DO 120 I1=1,N   
5677   120   IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.   
5678       ELSEIF(I.EQ.0) THEN   
5679     
5680 C...Direct readout of P matrix. 

5681       ELSEIF(J.LE.5) THEN   
5682         PLU=P(I,J)  
5683     
5684 C...Charge, total momentum, transverse momentum, transverse mass.   

5685       ELSEIF(J.LE.12) THEN  
5686         IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.    
5687         IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2  
5688         IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2   
5689         IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2    
5690         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)  
5691     
5692 C...Theta and phi angle in radians or degrees.  

5693       ELSEIF(J.LE.16) THEN  
5694         IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))    
5695         IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))   
5696         IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1) 
5697     
5698 C...True rapidity, rapidity with pion mass, pseudorapidity. 

5699       ELSEIF(J.LE.19) THEN  
5700         PMR=0.  
5701         IF(J.EQ.17) PMR=P(I,5)  
5702         IF(J.EQ.18) PMR=ULMASS(211) 
5703         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)    
5704         PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), 
5705      &  1E20)),P(I,3))  
5706     
5707 C...Energy and momentum fractions (only to be used in CM frame).    

5708       ELSEIF(J.LE.25) THEN  
5709         IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) 
5710         IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)  
5711         IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)   
5712         IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)  
5713         IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)    
5714         IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)    
5715       ENDIF 
5716     
5717       RETURN    
5718       END   
5719     
5720 C*********************************************************************  

5721     
5722       BLOCK DATA LUDATA 
5723     
5724 C...Purpose: to give default values to parameters and particle and  

5725 C...decay data. 

5726       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5727       SAVE /LUDAT1/ 
5728       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5729       SAVE /LUDAT2/ 
5730       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
5731       SAVE /LUDAT3/ 
5732       COMMON/LUDAT4/CHAF(500)   
5733       CHARACTER CHAF*8  
5734       SAVE /LUDAT4/ 
5735       COMMON/LUDATR/MRLU(6),RRLU(100)   
5736       SAVE /LUDATR/ 
5737     
5738 C...LUDAT1, containing status codes and most parameters.    

5739       DATA MSTU/    
5740      &    0,    0,    0, 9000,10000,  500, 2000,    0,    0,    2,  
5741      1    6,    1,    1,    0,    1,    1,    0,    0,    0,    0,  
5742      2    2,   10,    0,    0,    1,   10,    0,    0,    0,    0,  
5743      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
5744      4    2,    2,    1,    4,    2,    1,    1,    0,    0,    0,  
5745      5   25,   24,    0,    1,    0,    0,    0,    0,    0,    0,  
5746      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
5747      7  40*0,   
5748      1    1,    5,    3,    5,    0,    0,    0,    0,    0,    0,  
5749      2  60*0,   
5750      8    7,    2, 1989,   11,   25,    0,    0,    0,    0,    0,  
5751      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
5752       DATA PARU/    
5753      & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568,   4*0.,  
5754      1 0.001, 0.09, 0.01,  0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5755      2   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5756      3   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5757      4  2.0,  1.0, 0.25,  2.5, 0.05,   0.,   0., 0.0001, 0.,   0.,  
5758      5  2.5,  1.5,  7.0,  1.0,  0.5,  2.0,  3.2,   0.,   0.,   0.,  
5759      6  40*0.,  
5760      & 0.0072974, 0.230, 0., 0., 0.,   0.,   0.,   0.,   0.,   0.,  
5761      1 0.20, 0.25,  1.0,  4.0,   0.,   0.,   0.,   0.,   0.,   0.,  
5762      2  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5763      3  70*0./  
5764       DATA MSTJ/    
5765      &    1,    3,    0,    0,    0,    0,    0,    0,    0,    0,  
5766      1    1,    2,    0,    1,    0,    0,    0,    0,    0,    0,  
5767      2    2,    1,    1,    2,    1,    0,    0,    0,    0,    0,  
5768      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
5769      4    1,    2,    4,    2,    5,    0,    1,    0,    0,    0,  
5770      5    0,    3,    0,    0,    0,    0,    0,    0,    0,    0,  
5771      6  40*0,   
5772      &    5,    2,    7,    5,    1,    1,    0,    2,    0,    1,  
5773      1    0,    0,    0,    0,    1,    1,    0,    0,    0,    0,  
5774      2  80*0/   
5775       DATA PARJ/    
5776      & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50,   0.,   0.,   0.,  
5777      1 0.50, 0.60, 0.75,   0.,   0.,   0.,   0.,  1.0,  1.0,   0.,  
5778      2 0.35,  1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5779      3 0.10,  1.0,  0.8,  1.5,  0.8,  2.0,  0.2,  2.5,  0.6,  2.5,  
5780      4  0.5,  0.9,  0.5,  0.9,  0.5,   0.,   0.,   0.,   0.,   0.,  
5781      5 0.77, 0.77, 0.77,   0.,   0.,   0.,   0.,   0.,  1.0,   0.,  
5782      6  4.5,  0.7,  0., 0.003,  0.5,  0.5,   0.,   0.,   0.,   0.,  
5783      7  10., 1000., 100., 1000., 0.,   0.,   0.,   0.,   0.,   0.,  
5784      8  0.4,  1.0,  1.0,   0.,  10.,  10.,   0.,   0.,   0.,   0.,  
5785      9 0.02,  1.0,  0.2,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5786      &   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5787      1   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5788      2  1.5,  0.5, 91.2, 2.40, 0.02,  2.0,  1.0, 0.25,0.002,   0.,  
5789      3   0.,   0.,   0.,   0., 0.01, 0.99,   0.,   0.,  0.2,   0.,  
5790      4  60*0./  
5791     
5792 C...LUDAT2, with particle data and flavour treatment parameters.    

5793       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,   
5794      &-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,    
5795      &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, 
5796      &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,  
5797      &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,  
5798      &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/   
5799       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,68*0,-1,410*0/    
5800       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, 
5801      &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,    
5802      &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,   
5803      &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/ 
5804       DATA (PMAS(I,1),I=   1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,   
5805      &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15., 
5806      &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,  
5807      &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,   
5808      &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921, 
5809      &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,   
5810      &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,  
5811      &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,  
5812      &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,  
5813      &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,   
5814      &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,   
5815      &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274, 
5816      &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,    
5817      &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,  
5818      &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,   
5819      &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,  
5820      &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5, 
5821      &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./    
5822       DATA (PMAS(I,2),I=   1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,  
5823      &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06, 
5824      &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,   
5825      &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,    
5826      &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,  
5827      &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./ 
5828       DATA (PMAS(I,3),I=   1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4, 
5829      &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2, 
5830      &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,   
5831      &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,  
5832      &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./   
5833       DATA (PMAS(I,4),I=   1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,  
5834      &15*0.,7803.,0.,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,   
5835      &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,  
5836      &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./  
5837       DATA PARF/    
5838      &  0.5, 0.25,  0.5, 0.25,   1.,  0.5,   0.,   0.,   0.,   0.,  
5839      1  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
5840      2  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
5841      3  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
5842      4  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
5843      5  0.5,   0.,  0.5,   0.,   1.,   1.,   0.,   0.,   0.,   0.,  
5844      6 0.75,  0.5,   0., 0.1667, 0.0833, 0.1667, 0., 0., 0.,   0.,  
5845      7   0.,   0.,   1., 0.3333, 0.6667, 0.3333, 0., 0., 0.,   0.,  
5846      8   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5847      9   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5848      & 0.325, 0.325, 0.5, 1.6,  5.0,   0.,   0.,   0.,   0.,   0.,  
5849      1   0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60,  0.,   0.,  
5850      2  0.2,  0.1,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,  
5851      3  1870*0./    
5852       DATA ((VCKM(I,J),J=1,4),I=1,4)/   
5853      1  0.95150,  0.04847,  0.00003,  0.00000,  
5854      2  0.04847,  0.94936,  0.00217,  0.00000,  
5855      3  0.00003,  0.00217,  0.99780,  0.00000,  
5856      4  0.00000,  0.00000,  0.00000,  1.00000/  
5857     
5858 C...LUDAT3, with particle decay parameters and data.    

5859       DATA (MDCY(I,1),I=   1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,  
5860      &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,    
5861      &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,   
5862      &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/ 
5863       DATA (MDCY(I,2),I=   1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,  
5864      &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,    
5865      &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,    
5866      &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,    
5867      &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,    
5868      &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,    
5869      &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,    
5870      &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,  
5871      &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,    
5872      &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,   
5873      &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,  
5874      &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023, 
5875      &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,  
5876      &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,  
5877      &1065,114*0/   
5878       DATA (MDCY(I,3),I=   1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,   
5879      &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, 
5880      &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,  
5881      &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,  
5882      &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,    
5883      &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,  
5884      &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/    
5885       DATA (MDME(I,1),I=   1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,  
5886      &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,  
5887      &-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, 
5888      &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/  
5889       DATA (MDME(I,2),I=   1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,   
5890      &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,    
5891      &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, 
5892      &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,  
5893      &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, 
5894      &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,    
5895      &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,   
5896      &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,  
5897      &974*0/    
5898       DATA (BRAT(I)  ,I=   1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003, 
5899      &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,  
5900      &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,    
5901      &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01, 
5902      &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,  
5903      &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,    
5904      &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,    
5905      &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,    
5906      &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032, 
5907      &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,   
5908      &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001, 
5909      &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037, 
5910      &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,  
5911      &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004, 
5912      &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004, 
5913      &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021, 
5914      &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,    
5915      &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,   
5916      &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007, 
5917      &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/   
5918       DATA (BRAT(I)  ,I= 526, 893)/.019,2*.003,.002,.005,.004,.008, 
5919      &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001, 
5920      &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04, 
5921      &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012, 
5922      &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,  
5923      &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,  
5924      &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,   
5925      &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,    
5926      &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,  
5927      &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,   
5928      &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033, 
5929      &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,   
5930      &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333, 
5931      &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35, 
5932      &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,   
5933      &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084, 
5934      &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,  
5935      &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,  
5936      &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,  
5937      &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/ 
5938       DATA (BRAT(I)  ,I= 894,2000)/.003,.573,.287,.063,.028,2*.021, 
5939      &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,   
5940      &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003, 
5941      &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006, 
5942      &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,    
5943      &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001, 
5944      &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,   
5945      &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,    
5946      &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676, 
5947      &.234,.085,.005,3*1.,4*.5,7*1.,935*0./ 
5948       DATA (KFDP(I,1),I=   1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,  
5949      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,    
5950      &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,    
5951      &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,   
5952      &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,   
5953      &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5, 
5954      &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1, 
5955      &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,    
5956      &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2, 
5957      &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,   
5958      &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,  
5959      &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,   
5960      &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,  
5961      &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,    
5962      &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311, 
5963      &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311, 
5964      &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,    
5965      &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,  
5966      &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321, 
5967      &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/ 
5968       DATA (KFDP(I,1),I= 500, 873)/-323,2*-321,-311,2*333,211,213,  
5969      &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,  
5970      &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313, 
5971      &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15, 
5972      &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,  
5973      &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111, 
5974      &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,    
5975      &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13, 
5976      &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, 
5977      &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,  
5978      &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,   
5979      &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413, 
5980      &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,  
5981      &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,    
5982      &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,    
5983      &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213, 
5984      &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,   
5985      &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,    
5986      &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,  
5987      &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/  
5988       DATA (KFDP(I,1),I= 874,2000)/2*511,521,513,523,513,523,511,2*521, 
5989      &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130, 
5990      &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,   
5991      &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214, 
5992      &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212, 
5993      &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,    
5994      &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,    
5995      &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122, 
5996      &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122, 
5997      &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,    
5998      &935*0/    
5999       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, 
6000      &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,    
6001      &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211, 
6002      &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,   
6003      &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,  
6004      &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2, 
6005      &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,    
6006      &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,  
6007      &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,    
6008      &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18, 
6009      &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,   
6010      &-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,  
6011      &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,  
6012      &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,    
6013      &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223, 
6014      &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113, 
6015      &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1, 
6016      &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,  
6017      &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,  
6018      &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/  
6019       DATA (KFDP(I,2),I= 497, 863)/323,321,2*311,313,2*311,111,211, 
6020      &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,   
6021      &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,  
6022      &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,   
6023      &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,    
6024      &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,   
6025      &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,   
6026      &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82, 
6027      &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4, 
6028      &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,    
6029      &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,   
6030      &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,  
6031      &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,    
6032      &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321, 
6033      &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211, 
6034      &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111, 
6035      &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22, 
6036      &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211, 
6037      &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211, 
6038      &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/    
6039       DATA (KFDP(I,2),I= 864,2000)/2*111,211,-211,111,-211,111,-211,    
6040      &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,    
6041      &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22, 
6042      &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111, 
6043      &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,   
6044      &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,  
6045      &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,    
6046      &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,  
6047      &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211, 
6048      &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,  
6049      &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,  
6050      &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/ 
6051       DATA (KFDP(I,3),I=   1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,  
6052      &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,  
6053      &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,  
6054      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111, 
6055      &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111, 
6056      &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211, 
6057      &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,  
6058      &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211, 
6059      &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,  
6060      &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,   
6061      &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,  
6062      &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,    
6063      &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,  
6064      &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,    
6065      &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,  
6066      &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,  
6067      &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,  
6068      &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111, 
6069      &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,    
6070      &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/   
6071       DATA (KFDP(I,3),I= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,   
6072      &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0, 
6073      &2112,43*0,3322,949*0/ 
6074       DATA (KFDP(I,4),I=   1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,  
6075      &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111, 
6076      &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,   
6077      &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,   
6078      &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,   
6079      &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,   
6080      &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211, 
6081      &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,    
6082      &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,    
6083      &1006*0/   
6084       DATA (KFDP(I,5),I=   1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,   
6085      &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111, 
6086      &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/   
6087     
6088 C...LUDAT4, with character strings. 

6089       DATA (CHAF(I)  ,I=   1, 331)/'d','u','s','c','b','t','l','h', 
6090      &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',  
6091      &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',  
6092      &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron', 
6093      &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',    
6094      &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis', 
6095      &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B', 
6096      &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l', 
6097      &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho', 
6098      &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',  
6099      &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',  
6100      &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0', 
6101      &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',   
6102      &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1', 
6103      &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',   
6104      &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2', 
6105      &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',   
6106      &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L', 
6107      &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',    
6108      &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/  
6109       DATA (CHAF(I)  ,I= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',    
6110      &3*'Sigma_c',2*'Xi''_c','Omega_c', 
6111      &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',   
6112      &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c', 
6113      &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/  
6114     
6115 C...LUDATR, with initial values for the random number generator.    

6116       DATA MRLU/19780503,0,0,97,33,0/   
6117     
6118       END   
6119       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)