Back to home page

Project CMSSW displayed by LXR
 
 

    

File indexing completed on 2024-06-06 04:26:54 

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 101 J=1,5
0504   101 DPC(J)=0
0505       DO 130 MQGST=1,2  
0506       DO 120 I=MAX(1,IP),N  
0507       IF(K(I,1).NE.3) GOTO 120  
0508       KC=LUCOMP(K(I,2)) 
0509       IF(KC.EQ.0) GOTO 120  
0510       KQ=KCHG(KC,2) 
0511       IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120  
0512     
0513 C...Pick up loose string end.   

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

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

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

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

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

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

0670 clin-5/2012:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

0971 C...this is usually the case!   

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1254       DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)  
1255 clin-5/2012:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

2330 clin  110 NOPE=0    

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

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

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

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

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

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

2451 cms.. preinitialize

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

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

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

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

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

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

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

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

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

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

2603       NM=0  
2604       MSGN=0    
2605 cms..preinitialize

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

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

2631       PV(ND,5)=P(N+ND,5)    
2632 cms .. preinitialize...

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

2645 cms.. preinitialize..

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

3354         MMAX=2
3355 cms .. redefine variables to avoid compiler warning

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

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

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

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

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

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

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

3471       M3JC=0    
3472 cms..pre-initialization

3473       NPA=0
3474 cms..pre-initialization

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

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

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

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

3561 C...Origin and flavour of daughters.    

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

3589       DO 170 IP=1,NEP   
3590       K(N+IP,1)=3   
3591       K(N+IP,4)=0   
3592       K(N+IP,5)=0   
3593       KFLD(IP)=IABS(K(N+IP,2))  
3594       ITRY(IP)=0    
3595       ISL(IP)=0 
3596       ISI(IP)=0 
3597   170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1 
3598       ISLM=0    
3599     
3600 C...Maximum virtuality of daughters.    

3601 cms..pre-initialization

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

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

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

3665 cms.. pre-initialization for compiler

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

3694       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN   
3695         FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)    
3696       ELSEIF(MSTJ(49).EQ.0) THEN    
3697         FBR=(8./3.)*LOG((1.-ZC)/ZC) 
3698     
3699 C...Integral of Altarelli-Parisi z kernel for scalar gluon. 

3700       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN   
3701         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC) 
3702       ELSEIF(MSTJ(49).EQ.1) THEN    
3703         FBR=(1.-2.*ZC)/3.   
3704         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR   
3705     
3706 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. 

3707       ELSEIF(KFL(1).EQ.21) THEN 
3708         FBR=6.*MSTJ(45)*(0.5-ZC)    
3709       ELSE  
3710         FBR=2.*LOG((1.-ZC)/ZC)  
3711       ENDIF 
3712     
3713 C...Integral of Altarelli-Parisi kernel for photon emission.    

3714       FBRE=0.
3715       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) 
3716      &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)  
3717     
3718 C...Inner veto algorithm starts. Find maximum mass for evolution.   

3719 cms.. pre-initialization

3720       PM2=0.
3721   260 PMS=V(IEP(1),5)   
3722       IF(IGM.GE.0) THEN 
3723         PM2=0.  
3724         DO 270 I=2,NEP  
3725         PM=P(IEP(I),5)  
3726         IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=   
3727      &  PMTH(2,KFL(I))  
3728   270   PM2=PM2+PM  
3729         PMS=MIN(PMS,(P(IM,5)-PM2)**2)   
3730       ENDIF 
3731     
3732 C...Select mass for daughter in QCD evolution.  

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

3749       IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN    
3750         PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE))) 
3751         IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=  
3752      &  PMTH(2,KFL(1))**2   
3753         IF(PMSQED.GT.PMSQCD) THEN   
3754           V(IEP(1),5)=PMSQED    
3755           MCE=2 
3756         ENDIF   
3757       ENDIF 
3758     
3759 C...Check whether daughter mass below cutoff.   

3760       P(IEP(1),5)=SQRT(V(IEP(1),5)) 
3761       IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN    
3762         P(IEP(1),5)=PMTH(1,KFL(1))  
3763         V(IEP(1),5)=P(IEP(1),5)**2  
3764         GOTO 300    
3765       ENDIF 
3766     
3767 C...Select z value of branching: q -> qgamma.   

3768       IF(MCE.EQ.2) THEN 
3769         Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)    
3770         IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260   
3771         K(IEP(1),5)=22  
3772     
3773 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.  

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

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

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

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

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

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

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

3920 cms.. pre-initialization

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

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

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

4001   330 MAZIP=0   
4002       MAZIC=0
4003 cms.. pre-initialization for compiler

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

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

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

4076 C...interference.   

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

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

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

4156       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN 
4157         DO 360 J=1,3    
4158         DPT(1,J)=dble(P(IM,J))
4159         DPT(2,J)=dble(P(IAU,J))  
4160   360   DPT(3,J)=dble(P(N+1,J))
4161         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)  
4162         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)  
4163         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2    
4164         DO 370 J=1,3    
4165         DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM    
4166   370   DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM    
4167         DPT(4,4)=DSQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)  
4168         DPT(5,4)=DSQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)  
4169 clin-5/2012:

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

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

4187       IF(IGM.GE.0) K(IM,1)=14   
4188       N=N+NEP   
4189       NEP=2 
4190       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN  
4191         CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')   
4192         IF(MSTU(21).GE.1) N=NS  
4193         IF(MSTU(21).GE.1) RETURN    
4194       ENDIF 
4195       GOTO 140  
4196     
4197 C...Set information on imagined shower initiator.   

4198   380 IF(NPA.GE.2) THEN 
4199         K(NS+1,1)=11    
4200         K(NS+1,2)=94    
4201         K(NS+1,3)=IP1   
4202         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2   
4203         K(NS+1,4)=NS+2  
4204         K(NS+1,5)=NS+1+NPA  
4205         IIM=1   
4206       ELSE  
4207         IIM=0   
4208       ENDIF 
4209     
4210 C...Reconstruct string drawing information. 

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

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

4269       DO 400 I=NS+1,N   
4270       DO 400 J=1,5  
4271   400 V(I,J)=V(IP1,J)   
4272     
4273 C...Delete trivial shower, else connect initiators. 

4274       IF(N.EQ.NS+NPA+IIM) THEN  
4275         N=NS    
4276       ELSE  
4277         DO 410 IP=1,NPA 
4278         K(IPA(IP),1)=14 
4279         K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP 
4280         K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP 
4281         K(NS+IIM+IP,3)=IPA(IP)  
4282         IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1  
4283         K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)   
4284   410   K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)   
4285       ENDIF 
4286     
4287       RETURN    
4288       END   
4289     
4290 C*********************************************************************  

4291     
4292       SUBROUTINE LUBOEI(NSAV)   
4293     
4294 C...Purpose: to modify event so as to approximately take into account   

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

4296 C...parametrization.    

4297       IMPLICIT DOUBLE PRECISION(D)  
4298       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4299       SAVE /LUJETS/ 
4300       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4301       SAVE /LUDAT1/ 
4302       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)    
4303       DATA KFBE/211,-211,111,321,-321,130,310,221,331/  
4304     
4305 C...Boost event to overall CM frame. Calculate CM energy.   

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

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

4339 cms.. preinitialize for compiler

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

4375   180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1    
4376       I1=K(I1M,1)   
4377       DO 200 I2M=I1M+1,NBE(IBE) 
4378       I2=K(I2M,1)   
4379       Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+  
4380      &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)    
4381       QOLD=SQRT(Q2OLD)  
4382     
4383 C...Calculate new relative momentum.    

4384       IF(QOLD.LT.0.5*QDEL) THEN 
4385         QMOV=QOLD/3.    
4386       ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN  
4387         RBIN=QOLD/QDEL  
4388         IBIN=int(RBIN)
4389         RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)  
4390         QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*  
4391      &  SQRT(Q2OLD+PMHQ**2)/Q2OLD   
4392       ELSE  
4393         QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD    
4394       ENDIF 
4395       Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)   
4396     
4397 C...Calculate and save shift to be performed on three-momenta.  

4398       HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)    
4399       HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2    
4400       HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))   
4401       DO 190 J=1,3  
4402       PD=HA*(P(I2,J)-P(I1,J))   
4403       P(I1M,J)=P(I1M,J)+PD  
4404   190 P(I2M,J)=P(I2M,J)-PD  
4405   200 CONTINUE  
4406   210 CONTINUE  
4407     
4408 C...Shift momenta and recalculate energies. 

4409       DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))   
4410       I=K(IM,1) 
4411       DO 220 J=1,3  
4412   220 P(I,J)=P(I,J)+P(IM,J) 
4413   230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)  
4414     
4415 C...Rescale all momenta for energy conservation.    

4416       PES=0.    
4417       PQS=0.    
4418       DO 240 I=1,N  
4419       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240  
4420       PES=PES+P(I,4)    
4421       PQS=PQS+P(I,5)**2/P(I,4)  
4422   240 CONTINUE  
4423       FAC=(PECM-PQS)/(PES-PQS)  
4424       DO 260 I=1,N  
4425       IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260  
4426       DO 250 J=1,3  
4427   250 P(I,J)=FAC*P(I,J) 
4428       P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)  
4429   260 CONTINUE  
4430     
4431 C...Boost back to correct reference frame.  

4432       CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))  
4433     
4434       RETURN    
4435       END   
4436     
4437 C*********************************************************************  

4438     
4439       FUNCTION ULMASS(KF)   
4440     
4441 C...Purpose: to give the mass of a particle/parton. 

4442       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4443       SAVE /LUDAT1/ 
4444       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4445       SAVE /LUDAT2/ 
4446     
4447 C...Reset variables. Compressed code.   

4448       ULMASS=0. 
4449       KFA=IABS(KF)  
4450       KC=LUCOMP(KF) 
4451       IF(KC.EQ.0) RETURN    
4452       PARF(106)=PMAS(6,1)   
4453       PARF(107)=PMAS(7,1)   
4454       PARF(108)=PMAS(8,1)   
4455     
4456 C...Guarantee use of constituent masses for internal checks.    

4457       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN   
4458         ULMASS=PARF(100+KFA)    
4459         IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))   
4460     
4461 C...Masses that can be read directly off table. 

4462       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN  
4463         ULMASS=PMAS(KC,1)   
4464     
4465 C...Find constituent partons and their masses.  

4466       ELSE  
4467         KFLA=MOD(KFA/1000,10)   
4468         KFLB=MOD(KFA/100,10)    
4469         KFLC=MOD(KFA/10,10) 
4470         KFLS=MOD(KFA,10)    
4471         KFLR=MOD(KFA/10000,10)  
4472         PMA=PARF(100+KFLA)  
4473         PMB=PARF(100+KFLB)  
4474         PMC=PARF(100+KFLC)  
4475     
4476 C...Construct masses for various meson, diquark and baryon cases.   

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

4479           PMSPL=-3./(PMA*PMB)
4480           IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC) 
4481           IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)  
4482           ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL 
4483         ELSEIF(KFLA.EQ.0) THEN  
4484           KMUL=2    
4485           IF(KFLS.EQ.1) KMUL=3  
4486           IF(KFLR.EQ.2) KMUL=4  
4487           IF(KFLS.EQ.5) KMUL=5  
4488           ULMASS=PARF(113+KMUL)+PMB+PMC 
4489         ELSEIF(KFLC.EQ.0) THEN
4490 cms...... initialize to something at first to avoid compiler warning

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

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

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

4533     
4534       SUBROUTINE LUNAME(KF,CHAU)    
4535     
4536 C...Purpose: to give the particle/parton name as a character string.    

4537       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4538       SAVE /LUDAT1/ 
4539       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4540       SAVE /LUDAT2/ 
4541       COMMON/LUDAT4/CHAF(500)   
4542       CHARACTER CHAF*8  
4543       SAVE /LUDAT4/ 
4544       CHARACTER CHAU*16 
4545     
4546 C...Initial values. Charge. Subdivide code. 

4547       CHAU=' '  
4548       KFA=IABS(KF)  
4549       KC=LUCOMP(KF) 
4550       IF(KC.EQ.0) RETURN    
4551       KQ=LUCHGE(KF) 
4552       KFLA=MOD(KFA/1000,10) 
4553       KFLB=MOD(KFA/100,10)  
4554       KFLC=MOD(KFA/10,10)   
4555       KFLS=MOD(KFA,10)  
4556       KFLR=MOD(KFA/10000,10)    
4557     
4558 C...Read out root name and spin for simple particle.    

4559       IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN 
4560         CHAU=CHAF(KC)   
4561         LEN=0   
4562         DO 100 LEM=1,8  
4563   100   IF(CHAU(LEM:LEM).NE.' ') LEN=LEM    
4564     
4565 C...Construct root name for diquark. Add on spin.   

4566       ELSEIF(KFLC.EQ.0) THEN    
4567         CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)  
4568         IF(KFLS.EQ.1) CHAU(3:4)='_0'    
4569         IF(KFLS.EQ.3) CHAU(3:4)='_1'    
4570         LEN=4   
4571     
4572 C...Construct root name for heavy meson. Add on spin and heavy flavour. 

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

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

4627         CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)  
4628         LEN=LEN+2   
4629         IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN 
4630           CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)    
4631           LEN=LEN+2 
4632         ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN 
4633           CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1) 
4634           LEN=LEN+1 
4635         ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN 
4636           CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)    
4637           LEN=LEN+2 
4638         ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN 
4639           CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1) 
4640           LEN=LEN+1 
4641         ENDIF   
4642       ENDIF 
4643     
4644 C...Add on bar sign for antiparticle (where necessary). 

4645       IF(KF.GT.0.OR.LEN.EQ.0) THEN  
4646       ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN  
4647       ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN   
4648       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN 
4649       ELSEIF(MSTU(15).LE.1) THEN    
4650         CHAU(LEN+1:LEN+1)='~'   
4651         LEN=LEN+1   
4652       ELSE  
4653         CHAU(LEN+1:LEN+3)='bar' 
4654         LEN=LEN+3   
4655       ENDIF 
4656     
4657 C...Add on charge where applicable (conventional cases skipped).    

4658       IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'    
4659       IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'   
4660       IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+' 
4661       IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'    
4662       IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN  
4663       ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN   
4664       ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND. 
4665      &KFLB.NE.1) THEN   
4666       ELSEIF(KQ.EQ.0) THEN  
4667         CHAU(LEN+1:LEN+1)='0'   
4668       ENDIF 
4669     
4670       RETURN    
4671       END   
4672     
4673 C*********************************************************************  

4674     
4675       FUNCTION LUCHGE(KF)   
4676     
4677 C...Purpose: to give three times the charge for a particle/parton.  

4678       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4679       SAVE /LUDAT2/ 
4680     
4681 C...Initial values. Simple case of direct readout.  

4682       LUCHGE=0  
4683       KFA=IABS(KF)  
4684       KC=LUCOMP(KFA)    
4685       IF(KC.EQ.0) THEN  
4686       ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN  
4687         LUCHGE=KCHG(KC,1)   
4688     
4689 C...Construction from quark content for heavy meson, diquark, baryon.   

4690       ELSEIF(MOD(KFA/1000,10).EQ.0) THEN    
4691         LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*    
4692      &  (-1)**MOD(KFA/100,10)   
4693       ELSEIF(MOD(KFA/10,10).EQ.0) THEN  
4694         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1) 
4695       ELSE  
4696         LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+    
4697      &  KCHG(MOD(KFA/10,10),1)  
4698       ENDIF 
4699     
4700 C...Add on correct sign.    

4701       LUCHGE=LUCHGE*ISIGN(1,KF) 
4702     
4703       RETURN    
4704       END   
4705     
4706 C*********************************************************************  

4707     
4708       FUNCTION LUCOMP(KF)   
4709     
4710 C...Purpose: to compress the standard KF codes for use in mass and decay    

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

4712       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4713       SAVE /LUDAT2/ 
4714     
4715 C...Subdivide KF code into constituent pieces.  

4716       LUCOMP=0  
4717       KFA=IABS(KF)  
4718       KFLA=MOD(KFA/1000,10) 
4719       KFLB=MOD(KFA/100,10)  
4720       KFLC=MOD(KFA/10,10)   
4721       KFLS=MOD(KFA,10)  
4722       KFLR=MOD(KFA/10000,10)    
4723     
4724 C...Simple cases: direct translation or special codes.  

4725       IF(KFA.EQ.0.OR.KFA.GE.100000) THEN    
4726       ELSEIF(KFA.LE.100) THEN   
4727         LUCOMP=KFA  
4728         IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0   
4729       ELSEIF(KFLS.EQ.0) THEN    
4730         IF(KF.EQ.130) LUCOMP=221    
4731         IF(KF.EQ.310) LUCOMP=222    
4732         IF(KFA.EQ.210) LUCOMP=281   
4733         IF(KFA.EQ.2110) LUCOMP=282  
4734         IF(KFA.EQ.2210) LUCOMP=283  
4735     
4736 C...Mesons. 

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

4775       ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN   
4776         IF(KFLS.NE.1.AND.KFLS.NE.3) THEN    
4777         ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN    
4778         ELSEIF(KFLA.LT.KFLB) THEN   
4779         ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN 
4780         ELSE    
4781           LUCOMP=90 
4782         ENDIF   
4783     
4784 C...Spin 1/2 baryons.   

4785       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN  
4786         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN   
4787         ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN   
4788         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN    
4789           LUCOMP=80+KFLA    
4790         ELSEIF(KFLB.LT.KFLC) THEN   
4791           LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB  
4792         ELSE    
4793           LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC  
4794         ENDIF   
4795     
4796 C...Spin 3/2 baryons.   

4797       ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN  
4798         IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN   
4799         ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN   
4800         ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN 
4801           LUCOMP=80+KFLA    
4802         ELSE    
4803           LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC  
4804         ENDIF   
4805       ENDIF 
4806     
4807       RETURN    
4808       END   
4809     
4810 C*********************************************************************  

4811     
4812       SUBROUTINE LUERRM(MERR,CHMESS)    
4813     
4814 C...Purpose: to inform user of errors in program execution. 

4815       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
4816       SAVE /LUJETS/ 
4817       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4818       SAVE /LUDAT1/ 
4819       CHARACTER CHMESS*(*)  
4820 
4821       write (6,*) 'merr,chmess=',merr,chmess
4822     
4823 C...Write first few warnings, then be silent.   

4824       IF(MERR.LE.10) THEN   
4825         MSTU(27)=MSTU(27)+1 
4826         MSTU(28)=MERR   
4827         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000) 
4828      &  MERR,MSTU(31),CHMESS    
4829     
4830 C...Write first few errors, then be silent or stop program. 

4831       ELSEIF(MERR.LE.20) THEN   
4832         MSTU(23)=MSTU(23)+1 
4833         MSTU(24)=MERR-10    
4834         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100) 
4835      &  MERR-10,MSTU(31),CHMESS 
4836         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN 
4837           WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS  
4838           WRITE(MSTU(11),1200)  
4839           IF(MERR.NE.17) CALL LULIST(2) 
4840           STOP  
4841         ENDIF   
4842     
4843 C...Stop program in case of irreparable error.  

4844       ELSE  
4845         WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS    
4846         STOP    
4847       ENDIF 
4848     
4849 C...Formats for output. 

4850  1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,  
4851      &' LUEXEC calls:'/5X,A)    
4852  1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,   
4853      &' LUEXEC calls:'/5X,A)    
4854  1200 FORMAT(5X,'Execution will be stopped after listing of last ', 
4855      &'event!') 
4856  1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6, 
4857      &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')    
4858     
4859       RETURN    
4860       END   
4861     
4862 C*********************************************************************  

4863     
4864       FUNCTION ULALPS(Q2)   
4865     
4866 C...Purpose: to give the value of alpha_strong. 

4867       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
4868       SAVE /LUDAT1/ 
4869       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
4870       SAVE /LUDAT2/ 
4871     
4872 C...Constant alpha_strong trivial.  

4873       IF(MSTU(111).LE.0) THEN   
4874         ULALPS=PARU(111)    
4875         MSTU(118)=MSTU(112) 
4876         PARU(117)=0.    
4877         PARU(118)=PARU(111) 
4878         RETURN  
4879       ENDIF 
4880     
4881 C...Find effective Q2, number of flavours and Lambda.   

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

4906       B0=(33.-2.*NF)/6. 
4907       ALGQ=LOG(Q2EFF/ALAM2) 
4908       IF(MSTU(111).EQ.1) THEN   
4909         ULALPS=PARU(2)/(B0*ALGQ)    
4910       ELSE  
4911         B1=(153.-19.*NF)/6. 
4912         ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ)) 
4913       ENDIF 
4914       MSTU(118)=NF  
4915       PARU(118)=ULALPS  
4916     
4917       RETURN    
4918       END   
4919     
4920 C*********************************************************************  

4921     
4922       FUNCTION ULANGL(X,Y)  
4923     
4924 C...Purpose: to reconstruct an angle from given x and y coordinates.    

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

4946     
4947       FUNCTION RLU(IDUM)    
4948     
4949 C...Purpose: to generate random numbers uniformly distributed between   

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

4951       COMMON/LUDATR/MRLU(6),RRLU(100)   
4952       SAVE /LUDATR/ 
4953       EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),  
4954      &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),  
4955      &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))    
4956     
4957 C...Initialize generation from given seed.  

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

4990   130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)  
4991       IF(RUNI.LT.0.) RUNI=RUNI+1.   
4992       RRLU(MRLU4)=RUNI  
4993       MRLU4=MRLU4-1 
4994       IF(MRLU4.EQ.0) MRLU4=97   
4995       MRLU5=MRLU5-1 
4996       IF(MRLU5.EQ.0) MRLU5=97   
4997       RRLU98=RRLU98-RRLU99  
4998       IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00 
4999       RUNI=RUNI-RRLU98  
5000       IF(RUNI.LT.0.) RUNI=RUNI+1.   
5001       IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130  
5002     
5003 C...Update counters. Random number to output.   

5004       MRLU3=MRLU3+1 
5005       IF(MRLU3.EQ.1000000000) THEN  
5006         MRLU2=MRLU2+1   
5007         MRLU3=0 
5008       ENDIF 
5009       RLU=RUNI  
5010     
5011       RETURN    
5012       END   
5013     
5014 C*********************************************************************  

5015     
5016       SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)    
5017     
5018 C...Purpose: to perform rotations and boosts.   

5019       IMPLICIT DOUBLE PRECISION(D)  
5020       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5021       SAVE /LUJETS/ 
5022       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5023       SAVE /LUDAT1/ 
5024       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)    
5025     
5026 C...Find range of rotation/boost. Convert boost to double precision.    

5027       IMIN=1    
5028       IF(MSTU(1).GT.0) IMIN=MSTU(1) 
5029       IMAX=N    
5030       IF(MSTU(2).GT.0) IMAX=MSTU(2) 
5031       DBX=dble(BEX)
5032       DBY=dble(BEY)
5033       DBZ=dble(BEZ)
5034       GOTO 100  
5035     
5036 C...Entry for specific range and double precision boost.    

5037       ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)  
5038       IMIN=IMI  
5039       IF(IMIN.LE.0) IMIN=1  
5040       IMAX=IMA  
5041       IF(IMAX.LE.0) IMAX=N  
5042       DBX=DBEX  
5043       DBY=DBEY  
5044       DBZ=DBEZ  
5045     
5046 C...Check range of rotation/boost.  

5047   100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN   
5048         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory') 
5049         RETURN  
5050       ENDIF 
5051     
5052 C...Rotate, typically from z axis to direction (theta,phi). 

5053 clin-5/2012:

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

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

5077 clin-5/2012:

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

5079       IF((DBX**2+DBY**2+DBZ**2).GT.1D-20) THEN    
5080         DB=SQRT(DBX**2+DBY**2+DBZ**2)   
5081         IF(DB.GT.0.99999999D0) THEN 
5082 C...Rescale boost vector if too close to unity. 

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

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

5115 C        THE FOUR MOMENTUM ONLY

5116 C*********************************************************************

5117     
5118       SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)    
5119     
5120 C...Purpose: to perform rotations and boosts.   

5121       IMPLICIT DOUBLE PRECISION(D)  
5122       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5123       SAVE /LUJETS/ 
5124       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5125       SAVE /LUDAT1/ 
5126       DIMENSION ROT(3,3),PR(3),DP(4)
5127 cms      VR(3),DV(4)    

5128     
5129 C...Find range of rotation/boost. Convert boost to double precision.    

5130       IMIN=1    
5131       IF(MSTU(1).GT.0) IMIN=MSTU(1) 
5132       IMAX=N    
5133       IF(MSTU(2).GT.0) IMAX=MSTU(2) 
5134       DBX=dble(BEX)
5135       DBY=dble(BEY) 
5136       DBZ=dble(BEZ)  
5137     
5138 C...Check range of rotation/boost.  

5139       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN   
5140         CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory') 
5141         RETURN  
5142       ENDIF 
5143     
5144 C...Rotate, typically from z axis to direction (theta,phi). 

5145 clin-5/2012:

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

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

5167 clin-5/2012:

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

5169       IF((DBX**2+DBY**2+DBZ**2).GT.1D-20) THEN    
5170         DB=SQRT(DBX**2+DBY**2+DBZ**2)   
5171         IF(DB.GT.0.99999999D0) THEN 
5172 C...Rescale boost vector if too close to unity. 

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

5197     
5198       SUBROUTINE LUEDIT(MEDIT)  
5199     
5200 C...Purpose: to perform global manipulations on the event record,   

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

5202       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5203       SAVE /LUJETS/ 
5204       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5205       SAVE /LUDAT1/ 
5206       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5207       SAVE /LUDAT2/ 
5208       DIMENSION NS(2),PTS(2),PLS(2) 
5209     
5210 C...Remove unwanted partons/particles.  

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

5237         I1=I1+1 
5238         DO 100 J=1,5    
5239         K(I1,J)=K(I,J)  
5240         P(I1,J)=P(I,J)  
5241   100   V(I1,J)=V(I,J)  
5242         K(I1,3)=0   
5243   110   CONTINUE    
5244         N=I1    
5245     
5246 C...Selective removal of class of entries. New position of retained.    

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

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

5301         I1=0    
5302         DO 160 I=1,N    
5303         IF(K(I,3)/MSTU(5).EQ.0) GOTO 160    
5304         I1=I1+1 
5305         DO 150 J=1,5    
5306         K(I1,J)=K(I,J)  
5307         P(I1,J)=P(I,J)  
5308   150   V(I1,J)=V(I,J)  
5309         K(I1,3)=MOD(K(I1,3),MSTU(5))    
5310   160   CONTINUE    
5311         N=I1    
5312     
5313 C...Save top entries at bottom of LUJETS commonblock.   

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

5327       ELSEIF(MEDIT.EQ.22) THEN  
5328         DO 180 I=1,MSTU(32) 
5329         DO 180 J=1,5    
5330         K(I,J)=K(MSTU(4)-I,J)   
5331         P(I,J)=P(MSTU(4)-I,J)   
5332   180   V(I,J)=V(MSTU(4)-I,J)   
5333         N=MSTU(32)  
5334     
5335 C...Mark primary entries at top of commonblock LUJETS as untreated. 

5336       ELSEIF(MEDIT.EQ.23) THEN  
5337         I1=0    
5338         DO 190 I=1,N    
5339         KH=K(I,3)   
5340         IF(KH.GE.1) THEN    
5341           IF(K(KH,1).GT.20) KH=0    
5342         ENDIF   
5343         IF(KH.NE.0) GOTO 200    
5344         I1=I1+1 
5345   190   IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10  
5346   200   N=I1    
5347     
5348 C...Place largest axis along z axis and second largest in xy plane. 

5349       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN   
5350         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),   
5351      &  P(MSTU(61),2)),0D0,0D0,0D0) 
5352         CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),  
5353      &  P(MSTU(61),1)),0.,0D0,0D0,0D0)  
5354         CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1), 
5355      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)   
5356         IF(MEDIT.EQ.31) RETURN  
5357     
5358 C...Rotate to put slim jet along +z axis.   

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

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

5401     
5402       SUBROUTINE LULIST(MLIST)  
5403     
5404 C...Purpose: to give program heading, or list an event, or particle 

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

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

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

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

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

5423 C        MSTU(12)=0  

5424 C        IF(MLIST.EQ.0) RETURN   

5425 C      ENDIF 

5426     
5427 C...List event data, including additional lines after N.    

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

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

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

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

5501         IF(MSTU(70).GE.1) THEN  
5502           ISEP=0    
5503           DO 110 J=1,MIN(10,MSTU(70))   
5504   110     IF(I.EQ.MSTU(70+J)) ISEP=1    
5505           IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000) 
5506           IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100) 
5507         ENDIF   
5508   120   CONTINUE    
5509     
5510 C...Sum of charges and momenta. 

5511         DO 130 J=1,6    
5512   130   PS(J)=PLU(0,J)  
5513         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN 
5514           WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)  
5515         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN    
5516           WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)  
5517         ELSEIF(MLIST.EQ.1) THEN 
5518           WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)  
5519         ELSE    
5520           WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)  
5521         ENDIF   
5522     
5523 C...Give simple list of KF codes defined in program.    

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

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

5590         CALL LUNAME(KF,CHAP)    
5591         IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220  
5592         CALL LUNAME(-KF,CHAN)   
5593         PM=ULMASS(KF)   
5594         WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2), 
5595      &  KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)   
5596     
5597 C...Particle decay: channel number, branching ration, matrix element,   

5598 C...decay products. 

5599         IF(KF.GT.100.AND.KC.LE.100) GOTO 220    
5600         DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1   
5601         DO 200 J=1,5    
5602   200   CALL LUNAME(KFDP(IDC,J),CHAD(J))    
5603   210   WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC), 
5604      &  (CHAD(J),J=1,5) 
5605   220   CONTINUE    
5606         MSTJ(24)=MSTJ24 
5607     
5608 C...List parameter value table. 

5609       ELSEIF(MLIST.EQ.13) THEN  
5610         WRITE(MSTU(11),3100)    
5611         DO 230 I=1,200  
5612   230   WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)  
5613       ENDIF 
5614     
5615 C...Format statements for output on unit MSTU(11) (by default 6).   

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

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

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

5657     
5658       FUNCTION PLU(I,J) 
5659     
5660 C...Purpose: to provide various real-valued event related data. 

5661       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
5662       SAVE /LUJETS/ 
5663       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5664       SAVE /LUDAT1/ 
5665       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5666       SAVE /LUDAT2/ 
5667       DIMENSION PSUM(4) 
5668     
5669 C...Set default value. For I = 0 sum of momenta or charges, 

5670 C...or invariant mass of system.    

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

5688       ELSEIF(J.LE.5) THEN   
5689         PLU=P(I,J)  
5690     
5691 C...Charge, total momentum, transverse momentum, transverse mass.   

5692       ELSEIF(J.LE.12) THEN  
5693         IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.    
5694         IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2  
5695         IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2   
5696         IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2    
5697         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)  
5698     
5699 C...Theta and phi angle in radians or degrees.  

5700       ELSEIF(J.LE.16) THEN  
5701         IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))    
5702         IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))   
5703         IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1) 
5704     
5705 C...True rapidity, rapidity with pion mass, pseudorapidity. 

5706       ELSEIF(J.LE.19) THEN  
5707         PMR=0.  
5708         IF(J.EQ.17) PMR=P(I,5)  
5709         IF(J.EQ.18) PMR=ULMASS(211) 
5710         PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)    
5711         PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), 
5712      &  1E20)),P(I,3))  
5713     
5714 C...Energy and momentum fractions (only to be used in CM frame).    

5715       ELSEIF(J.LE.25) THEN  
5716         IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) 
5717         IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)  
5718         IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)   
5719         IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)  
5720         IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)    
5721         IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)    
5722       ENDIF 
5723     
5724       RETURN    
5725       END   
5726     
5727 C*********************************************************************  

5728     
5729       BLOCK DATA LUDATA 
5730     
5731 C...Purpose: to give default values to parameters and particle and  

5732 C...decay data. 

5733       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
5734       SAVE /LUDAT1/ 
5735       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
5736       SAVE /LUDAT2/ 
5737       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
5738       SAVE /LUDAT3/ 
5739       COMMON/LUDAT4/CHAF(500)   
5740       CHARACTER CHAF*8  
5741       SAVE /LUDAT4/ 
5742       COMMON/LUDATR/MRLU(6),RRLU(100)   
5743       SAVE /LUDATR/ 
5744     
5745 C...LUDAT1, containing status codes and most parameters.    

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

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

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

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

6123       DATA MRLU/19780503,0,0,97,33,0/   
6124     
6125       END   
6126       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)  
6127     
6128 C...Initializes the generation procedure; finds maxima of the   

6129 C...differential cross-sections to be used for weighting.   

6130       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6131       SAVE /LUDAT1/ 
6132       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6133       SAVE /LUDAT2/ 
6134       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
6135       SAVE /LUDAT3/ 
6136       COMMON/LUDAT4/CHAF(500)   
6137       CHARACTER CHAF*8  
6138       SAVE /LUDAT4/ 
6139       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
6140       SAVE /PYSUBS/ 
6141       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
6142       SAVE /PYPARS/ 
6143       COMMON/PYINT1/MINT(400),VINT(400) 
6144       SAVE /PYINT1/ 
6145       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
6146       SAVE /PYINT2/ 
6147       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
6148       SAVE /PYINT5/ 
6149       CHARACTER*(*) FRAME,BEAM,TARGET   
6150       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHMO(12)*3,CHLH(2)*6 
6151       DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
6152      &'Oct','Nov','Dec'/, CHLH/'lepton','hadron'/   
6153     
6154 clin-12/2012 correct NN differential cross section in HIJING:

6155       WRITE(MSTU(11),*) 'In PYINIT: BEAM,TARGET= ',BEAM,TARGET
6156 
6157 C...Write headers.  

6158 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),  

6159 C     &MSTP(185),CHMO(MSTP(184)),MSTP(183)   

6160       CALL LULIST(0)
6161 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)  

6162     
6163 C...Identify beam and target particles and initialize kinematics.   

6164       CHFRAM=FRAME//' ' 
6165       CHBEAM=BEAM//' '  
6166       CHTARG=TARGET//' '    
6167       CALL PYINKI(CHFRAM,CHBEAM,CHTARG,WIN) 
6168     
6169 C...Select partonic subprocesses to be included in the simulation.  

6170       IF(MSEL.NE.0) THEN    
6171         DO 100 I=1,200  
6172   100   MSUB(I)=0   
6173       ENDIF 
6174       IF(MINT(43).EQ.1.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN   
6175 C...Lepton+lepton -> gamma/Z0 or W. 

6176         IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1    
6177         IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1    
6178       ELSEIF(MSEL.EQ.1) THEN    
6179 C...High-pT QCD processes:  

6180         MSUB(11)=1  
6181         MSUB(12)=1  
6182         MSUB(13)=1  
6183         MSUB(28)=1  
6184         MSUB(53)=1  
6185         MSUB(68)=1  
6186         IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1    
6187         IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1    
6188       ELSEIF(MSEL.EQ.2) THEN    
6189 C...All QCD processes:  

6190         MSUB(11)=1  
6191         MSUB(12)=1  
6192         MSUB(13)=1  
6193         MSUB(28)=1  
6194         MSUB(53)=1  
6195         MSUB(68)=1  
6196         MSUB(91)=1  
6197         MSUB(92)=1  
6198         MSUB(93)=1  
6199         MSUB(95)=1  
6200       ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN  
6201 C...Heavy quark production. 

6202         MSUB(81)=1  
6203         MSUB(82)=1  
6204         DO 110 J=1,MIN(8,MDCY(21,3))    
6205   110   MDME(MDCY(21,2)+J-1,1)=0    
6206         MDME(MDCY(21,2)+MSEL-1,1)=1 
6207       ELSEIF(MSEL.EQ.10) THEN   
6208 C...Prompt photon production:   

6209         MSUB(14)=1  
6210         MSUB(18)=1  
6211         MSUB(29)=1  
6212       ELSEIF(MSEL.EQ.11) THEN   
6213 C...Z0/gamma* production:   

6214         MSUB(1)=1   
6215       ELSEIF(MSEL.EQ.12) THEN   
6216 C...W+/- production:    

6217         MSUB(2)=1   
6218       ELSEIF(MSEL.EQ.13) THEN   
6219 C...Z0 + jet:   

6220         MSUB(15)=1  
6221         MSUB(30)=1  
6222       ELSEIF(MSEL.EQ.14) THEN   
6223 C...W+/- + jet: 

6224         MSUB(16)=1  
6225         MSUB(31)=1  
6226       ELSEIF(MSEL.EQ.15) THEN   
6227 C...Z0 & W+/- pair production:  

6228         MSUB(19)=1  
6229         MSUB(20)=1  
6230         MSUB(22)=1  
6231         MSUB(23)=1  
6232         MSUB(25)=1  
6233       ELSEIF(MSEL.EQ.16) THEN   
6234 C...H0 production:  

6235         MSUB(3)=1   
6236         MSUB(5)=1   
6237         MSUB(8)=1   
6238         MSUB(102)=1 
6239       ELSEIF(MSEL.EQ.17) THEN   
6240 C...H0 & Z0 or W+/- pair production:    

6241         MSUB(24)=1  
6242         MSUB(26)=1  
6243       ELSEIF(MSEL.EQ.21) THEN   
6244 C...Z'0 production: 

6245         MSUB(141)=1 
6246       ELSEIF(MSEL.EQ.22) THEN   
6247 C...H+/- production:    

6248         MSUB(142)=1 
6249       ELSEIF(MSEL.EQ.23) THEN   
6250 C...R production:   

6251         MSUB(143)=1 
6252       ENDIF 
6253     
6254 C...Count number of subprocesses on.    

6255       MINT(44)=0    
6256       DO 120 ISUB=1,200 
6257       IF(MINT(43).LT.4.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.   
6258      &MSUB(ISUB).EQ.1) THEN 
6259         WRITE(MSTU(11),1200) ISUB,CHLH(MINT(41)),CHLH(MINT(42)) 
6260         STOP    
6261       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN 
6262         WRITE(MSTU(11),1300) ISUB   
6263         STOP    
6264       ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN 
6265         WRITE(MSTU(11),1400) ISUB   
6266         STOP    
6267       ELSEIF(MSUB(ISUB).EQ.1) THEN  
6268         MINT(44)=MINT(44)+1 
6269       ENDIF 
6270   120 CONTINUE  
6271       IF(MINT(44).EQ.0) THEN    
6272         WRITE(MSTU(11),1500)    
6273         STOP    
6274       ENDIF 
6275       MINT(45)=MINT(44)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) 
6276     
6277 C...Maximum 4 generations; set maximum number of allowed flavours.  

6278       MSTP(1)=MIN(4,MSTP(1))    
6279       MSTU(114)=MIN(MSTU(114),2*MSTP(1))    
6280       MSTP(54)=MIN(MSTP(54),2*MSTP(1))  
6281     
6282 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. 

6283       DO 140 I=-20,20   
6284       VINT(180+I)=0.    
6285       IA=IABS(I)    
6286       IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN  
6287         DO 130 J=1,MSTP(1)  
6288         IB=2*J-1+MOD(IA,2)  
6289         IPM=(5-ISIGN(1,I))/2    
6290         IDC=J+MDCY(IA,2)+2  
6291   130   IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)= 
6292      &  VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2) 
6293       ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN  
6294         VINT(180+I)=1.  
6295       ENDIF 
6296   140 CONTINUE  
6297     
6298 C...Choose Lambda value to use in alpha-strong. 

6299       MSTU(111)=MSTP(2) 
6300       IF(MSTP(3).GE.1) THEN 
6301         ALAM=PARP(1)    
6302         IF(MSTP(51).EQ.1) ALAM=0.2  
6303         IF(MSTP(51).EQ.2) ALAM=0.29 
6304         IF(MSTP(51).EQ.3) ALAM=0.2  
6305         IF(MSTP(51).EQ.4) ALAM=0.4  
6306         IF(MSTP(51).EQ.11) ALAM=0.16    
6307         IF(MSTP(51).EQ.12) ALAM=0.26    
6308         IF(MSTP(51).EQ.13) ALAM=0.36    
6309         PARP(1)=ALAM    
6310         PARP(61)=ALAM   
6311         PARU(112)=ALAM  
6312         PARJ(81)=ALAM   
6313       ENDIF 
6314     
6315 C...Initialize widths and partial widths for resonances.    

6316       CALL PYINRE   
6317     
6318 C...Reset variables for cross-section calculation.  

6319       DO 150 I=0,200    
6320       DO 150 J=1,3  
6321       NGEN(I,J)=0   
6322   150 XSEC(I,J)=0.  
6323       VINT(108)=0.  
6324     
6325 C...Find parametrized total cross-sections. 

6326       IF(MINT(43).EQ.4) CALL PYXTOT 
6327     
6328 C...Maxima of differential cross-sections.  

6329       IF(MSTP(121).LE.0) CALL PYMAXI    
6330     
6331 C...Initialize possibility of overlayed events. 

6332       IF(MSTP(131).NE.0) CALL PYOVLY(1) 
6333     
6334 C...Initialize multiple interactions with variable impact parameter.    

6335       IF(MINT(43).EQ.4.AND.(MINT(45).NE.0.OR.MSTP(131).NE.0).AND.   
6336      &MSTP(82).GE.2) CALL PYMULT(1) 
6337 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)  

6338     
6339 C...Formats for initialization information. 

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

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

6342 clin 1100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',    

6343 clin     &'routines',1X,17('*'))    

6344  1200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,  
6345      &'-',A6,' interactions.'/1X,'Execution stopped!')  
6346  1300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/   
6347      &1X,'Execution stopped!')  
6348  1400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/  
6349      &1X,'Execution stopped!')  
6350  1500 FORMAT(1X,'Error: no subprocess switched on.'/    
6351      &1X,'Execution stopped.')  
6352 clin 1600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,  

6353 clin     &22('*'))  

6354     
6355       RETURN    
6356       END   
6357     
6358 C*********************************************************************  

6359     
6360       SUBROUTINE PYTHIA 
6361     
6362 C...Administers the generation of a high-pt event via calls to a number 

6363 C...of subroutines; also computes cross-sections.   

6364       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6365       SAVE /LUJETS/ 
6366       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6367       SAVE /LUDAT1/ 
6368       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6369       SAVE /LUDAT2/ 
6370       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
6371       SAVE /PYSUBS/ 
6372       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
6373       SAVE /PYPARS/ 
6374       COMMON/PYINT1/MINT(400),VINT(400) 
6375       SAVE /PYINT1/ 
6376       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
6377       SAVE /PYINT2/ 
6378       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
6379       SAVE /PYINT5/ 
6380     
6381 C...Loop over desired number of overlayed events (normally 1).  

6382       MINT(7)=0 
6383       MINT(8)=0 
6384       NOVL=1    
6385       IF(MSTP(131).NE.0) CALL PYOVLY(2) 
6386       IF(MSTP(131).NE.0) NOVL=MINT(81)  
6387       MINT(83)=0    
6388       MINT(84)=MSTP(126)    
6389       MSTU(70)=0    
6390       DO 190 IOVL=1,NOVL    
6391       IF(MINT(84)+100.GE.MSTU(4)) THEN  
6392         CALL LUERRM(11, 
6393      &  '(PYTHIA:) no more space in LUJETS for overlayed events')   
6394         IF(MSTU(21).GE.1) GOTO 200  
6395       ENDIF 
6396       MINT(82)=IOVL 
6397     
6398 C...Generate variables of hard scattering.  

6399   100 CONTINUE  
6400       IF(IOVL.EQ.1) NGEN(0,2)=NGEN(0,2)+1   
6401       MINT(31)=0    
6402       MINT(51)=0    
6403       CALL PYRAND   
6404       ISUB=MINT(1)  
6405       IF(IOVL.EQ.1) THEN    
6406         NGEN(ISUB,2)=NGEN(ISUB,2)+1 
6407     
6408 C...Store information on hard interaction.  

6409         DO 110 J=1,200  
6410         MSTI(J)=0   
6411   110   PARI(J)=0.  
6412         MSTI(1)=MINT(1) 
6413         MSTI(2)=MINT(2) 
6414         MSTI(11)=MINT(11)   
6415         MSTI(12)=MINT(12)   
6416         MSTI(15)=MINT(15)   
6417         MSTI(16)=MINT(16)   
6418         MSTI(17)=MINT(17)   
6419         MSTI(18)=MINT(18)   
6420         PARI(11)=VINT(1)    
6421         PARI(12)=VINT(2)    
6422         IF(ISUB.NE.95) THEN 
6423           DO 120 J=13,22    
6424   120     PARI(J)=VINT(30+J)    
6425           PARI(33)=VINT(41) 
6426           PARI(34)=VINT(42) 
6427           PARI(35)=PARI(33)-PARI(34)    
6428           PARI(36)=VINT(21) 
6429           PARI(37)=VINT(22) 
6430           PARI(38)=VINT(26) 
6431           PARI(41)=VINT(23) 
6432         ENDIF   
6433       ENDIF 
6434     
6435       IF(MSTP(111).EQ.-1) GOTO 160  
6436       IF(ISUB.LE.90.OR.ISUB.GE.95) THEN 
6437 C...Hard scattering (including low-pT): 

6438 C...reconstruct kinematics and colour flow of hard scattering.  

6439         CALL PYSCAT 
6440         IF(MINT(51).EQ.1) GOTO 100  
6441     
6442 C...Showering of initial state partons (optional).  

6443         IPU1=MINT(84)+1 
6444         IPU2=MINT(84)+2 
6445         IF(MSTP(61).GE.1.AND.MINT(43).NE.1.AND.ISUB.NE.95)  
6446      &  CALL PYSSPA(IPU1,IPU2)  
6447         NSAV1=N 
6448     
6449 C...Multiple interactions.  

6450         IF(MSTP(81).GE.1.AND.MINT(43).EQ.4.AND.ISUB.NE.95)  
6451      &  CALL PYMULT(6)  
6452         MINT(1)=ISUB    
6453         NSAV2=N 
6454     
6455 C...Hadron remnants and primordial kT.  

6456         CALL PYREMN(IPU1,IPU2)  
6457         IF(MINT(51).EQ.1) GOTO 100  
6458         NSAV3=N 
6459     
6460 C...Showering of final state partons (optional).    

6461         IPU3=MINT(84)+3 
6462         IPU4=MINT(84)+4 
6463         IF(MSTP(71).GE.1.AND.ISUB.NE.95.AND.K(IPU3,1).GT.0.AND. 
6464      &  K(IPU3,1).LE.10.AND.K(IPU4,1).GT.0.AND.K(IPU4,1).LE.10) THEN    
6465           QMAX=SQRT(PARP(71)*VINT(52))  
6466           IF(ISUB.EQ.5) QMAX=SQRT(PMAS(23,1)**2)    
6467           IF(ISUB.EQ.8) QMAX=SQRT(PMAS(24,1)**2)    
6468           CALL LUSHOW(IPU3,IPU4,QMAX)   
6469         ENDIF   
6470     
6471 C...Sum up transverse and longitudinal momenta. 

6472         IF(IOVL.EQ.1) THEN  
6473           PARI(65)=2.*PARI(17)  
6474           DO 130 I=MSTP(126)+1,N    
6475           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130  
6476           PT=SQRT(P(I,1)**2+P(I,2)**2)  
6477           PARI(69)=PARI(69)+PT  
6478           IF(I.LE.NSAV1.OR.I.GT.NSAV3) PARI(66)=PARI(66)+PT 
6479           IF(I.GT.NSAV1.AND.I.LE.NSAV2) PARI(68)=PARI(68)+PT    
6480   130     CONTINUE  
6481           PARI(67)=PARI(68) 
6482           PARI(71)=VINT(151)    
6483           PARI(72)=VINT(152)    
6484           PARI(73)=VINT(151)    
6485           PARI(74)=VINT(152)    
6486         ENDIF   
6487     
6488 C...Decay of final state resonances.    

6489         IF(MSTP(41).GE.1.AND.ISUB.NE.95) CALL PYRESD    
6490     
6491       ELSE  
6492 C...Diffractive and elastic scattering. 

6493         CALL PYDIFF 
6494         IF(IOVL.EQ.1) THEN  
6495           PARI(65)=2.*PARI(17)  
6496           PARI(66)=PARI(65) 
6497           PARI(69)=PARI(65) 
6498         ENDIF   
6499       ENDIF 
6500     
6501 C...Recalculate energies from momenta and masses (if desired).  

6502       IF(MSTP(113).GE.1) THEN   
6503         DO 140 I=MINT(83)+1,N   
6504   140   IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ 
6505      &  P(I,2)**2+P(I,3)**2+P(I,5)**2)  
6506       ENDIF 
6507     
6508 C...Rearrange partons along strings, check invariant mass cuts. 

6509       MSTU(28)=0    
6510       CALL LUPREP(MINT(84)+1)   
6511       IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 
6512       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN 
6513         DO 150 I=MINT(84)+1,N   
6514         IF(K(I,2).NE.94) GOTO 150   
6515         K(I+1,3)=MOD(K(I+1,4)/MSTU(5),MSTU(5))  
6516         K(I+2,3)=MOD(K(I+2,4)/MSTU(5),MSTU(5))  
6517   150   CONTINUE    
6518         CALL LUEDIT(12) 
6519         CALL LUEDIT(14) 
6520         IF(MSTP(125).EQ.0) CALL LUEDIT(15)  
6521         IF(MSTP(125).EQ.0) MINT(4)=0    
6522       ENDIF 
6523     
6524 C...Introduce separators between sections in LULIST event listing.  

6525       IF(IOVL.EQ.1.AND.MSTP(125).LE.0) THEN 
6526         MSTU(70)=1  
6527         MSTU(71)=N  
6528       ELSEIF(IOVL.EQ.1) THEN    
6529         MSTU(70)=3  
6530         MSTU(71)=2  
6531         MSTU(72)=MINT(4)    
6532         MSTU(73)=N  
6533       ENDIF 
6534     
6535 C...Perform hadronization (if desired). 

6536       IF(MSTP(111).GE.1) CALL LUEXEC    
6537       IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL LUEDIT(14)  
6538     
6539 C...Calculate Monte Carlo estimates of cross-sections.  

6540   160 IF(IOVL.EQ.1) THEN    
6541         IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1 
6542         NGEN(0,3)=NGEN(0,3)+1   
6543         XSEC(0,3)=0.    
6544         DO 170 I=1,200  
6545         IF(I.EQ.96) THEN    
6546           XSEC(I,3)=0.  
6547         ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR. 
6548      &  I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN    
6549           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1.,FLOAT(NGEN(96,1))*  
6550      &    FLOAT(NGEN(96,2)))    
6551         ELSEIF(NGEN(I,1).EQ.0) THEN 
6552           XSEC(I,3)=0.  
6553         ELSEIF(NGEN(I,2).EQ.0) THEN 
6554           XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(FLOAT(NGEN(I,1))*  
6555      &    FLOAT(NGEN(0,2))) 
6556         ELSE    
6557           XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(FLOAT(NGEN(I,1))*  
6558      &    FLOAT(NGEN(I,2))) 
6559         ENDIF   
6560   170   XSEC(0,3)=XSEC(0,3)+XSEC(I,3)   
6561         IF(MSUB(95).EQ.1) THEN  
6562           NGENS=NGEN(91,3)+NGEN(92,3)+NGEN(93,3)+NGEN(94,3)+NGEN(95,3)  
6563           XSECS=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+XSEC(95,3)  
6564           XMAXS=XSEC(95,1)  
6565           IF(MSUB(91).EQ.1) XMAXS=XMAXS+XSEC(91,1)  
6566           IF(MSUB(92).EQ.1) XMAXS=XMAXS+XSEC(92,1)  
6567           IF(MSUB(93).EQ.1) XMAXS=XMAXS+XSEC(93,1)  
6568           IF(MSUB(94).EQ.1) XMAXS=XMAXS+XSEC(94,1)  
6569           FAC=1.    
6570           IF(NGENS.LT.NGEN(0,3)) FAC=(XMAXS-XSECS)/(XSEC(0,3)-XSECS)    
6571           XSEC(11,3)=FAC*XSEC(11,3) 
6572           XSEC(12,3)=FAC*XSEC(12,3) 
6573           XSEC(13,3)=FAC*XSEC(13,3) 
6574           XSEC(28,3)=FAC*XSEC(28,3) 
6575           XSEC(53,3)=FAC*XSEC(53,3) 
6576           XSEC(68,3)=FAC*XSEC(68,3) 
6577           XSEC(0,3)=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+    
6578      &    XSEC(95,1)    
6579         ENDIF   
6580     
6581 C...Store final information.    

6582         MINT(5)=MINT(5)+1   
6583         MSTI(3)=MINT(3) 
6584         MSTI(4)=MINT(4) 
6585         MSTI(5)=MINT(5) 
6586         MSTI(6)=MINT(6) 
6587         MSTI(7)=MINT(7) 
6588         MSTI(8)=MINT(8) 
6589         MSTI(13)=MINT(13)   
6590         MSTI(14)=MINT(14)   
6591         MSTI(21)=MINT(21)   
6592         MSTI(22)=MINT(22)   
6593         MSTI(23)=MINT(23)   
6594         MSTI(24)=MINT(24)   
6595         MSTI(25)=MINT(25)   
6596         MSTI(26)=MINT(26)   
6597         MSTI(31)=MINT(31)   
6598         PARI(1)=XSEC(0,3)   
6599         PARI(2)=XSEC(0,3)/MINT(5)   
6600         PARI(31)=VINT(141)  
6601         PARI(32)=VINT(142)  
6602         IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN    
6603           PARI(42)=2.*VINT(47)/VINT(1)  
6604           DO 180 IS=7,8 
6605           PARI(36+IS)=P(MINT(IS),3)/VINT(1) 
6606           PARI(38+IS)=P(MINT(IS),4)/VINT(1) 
6607           I=MINT(IS)    
6608           PR=MAX(1E-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)   
6609           PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/    
6610      &    SQRT(PR),1E20)),P(I,3))   
6611           PR=MAX(1E-20,P(I,1)**2+P(I,2)**2) 
6612           PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/    
6613      &    SQRT(PR),1E20)),P(I,3))   
6614           PARI(44+IS)=P(I,3)/SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)    
6615           PARI(46+IS)=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))  
6616           PARI(48+IS)=ULANGL(P(I,1),P(I,2)) 
6617   180     CONTINUE  
6618         ENDIF   
6619         PARI(61)=VINT(148)  
6620         IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN 
6621           MSTU(161)=MINT(21)    
6622           MSTU(162)=0   
6623         ELSE    
6624           MSTU(161)=MINT(21)    
6625           MSTU(162)=MINT(22)    
6626         ENDIF   
6627       ENDIF 
6628     
6629 C...Prepare to go to next overlayed event.  

6630       MSTI(41)=IOVL 
6631       IF(IOVL.GE.2.AND.IOVL.LE.10) MSTI(40+IOVL)=ISUB   
6632       IF(MSTU(70).LT.10) THEN   
6633         MSTU(70)=MSTU(70)+1 
6634         MSTU(70+MSTU(70))=N 
6635       ENDIF 
6636       MINT(83)=N    
6637       MINT(84)=N+MSTP(126)  
6638   190 CONTINUE  
6639     
6640 C...Information on overlayed events.    

6641       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN    
6642         PARI(91)=VINT(132)  
6643         PARI(92)=VINT(133)  
6644         PARI(93)=VINT(134)  
6645         IF(MSTP(133).EQ.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)    
6646       ENDIF 
6647     
6648 C...Transform to the desired coordinate frame.  

6649   200 CALL PYFRAM(MSTP(124))    
6650     
6651       RETURN    
6652       END   
6653     
6654 C*********************************************************************  

6655     
6656       SUBROUTINE PYINKI(CHFRAM,CHBEAM,CHTARG,WIN)   
6657     
6658 C...Identifies the two incoming particles and sets up kinematics,   

6659 C...including rotations and boosts to/from CM frame.    

6660       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
6661       SAVE /LUJETS/ 
6662       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6663       SAVE /LUDAT1/ 
6664       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
6665       SAVE /PYSUBS/ 
6666       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
6667       SAVE /PYPARS/ 
6668       COMMON/PYINT1/MINT(400),VINT(400) 
6669       SAVE /PYINT1/ 
6670       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,  
6671      &CHIDNT(3)*8,CHTEMP*8,CHCDE(18)*8,CHINIT*76    
6672       DIMENSION LEN(3),KCDE(18) 
6673       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',  
6674      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
6675       DATA CHCDE/'e-      ','e+      ','nue     ','nue~    ',   
6676      &'mu-     ','mu+     ','numu    ','numu~   ','tau-    ',   
6677      &'tau+    ','nutau   ','nutau~  ','pi+     ','pi-     ',   
6678      &'n       ','n~      ','p       ','p~      '/  
6679       DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,  
6680      &211,-211,2112,-2112,2212,-2212/   
6681     
6682 C...Convert character variables to lowercase and find their length. 

6683       CHCOM(1)=CHFRAM   
6684       CHCOM(2)=CHBEAM   
6685       CHCOM(3)=CHTARG   
6686       DO 120 I=1,3  
6687       LEN(I)=8  
6688       DO 100 LL=8,1,-1  
6689       IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1   
6690       DO 100 LA=1,26    
6691   100 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=   
6692      &CHALP(1)(LA:LA)   
6693       CHIDNT(I)=CHCOM(I)    
6694       DO 110 LL=1,6 
6695       IF(CHIDNT(I)(LL:LL+2).EQ.'bar') THEN  
6696         CHTEMP=CHIDNT(I)    
6697         CHIDNT(I)=CHTEMP(1:LL-1)//'~'//CHTEMP(LL+3:8)//'  ' 
6698       ENDIF 
6699   110 CONTINUE  
6700       DO 120 LL=1,8 
6701       IF(CHIDNT(I)(LL:LL).EQ.'_') THEN  
6702         CHTEMP=CHIDNT(I)    
6703         CHIDNT(I)=CHTEMP(1:LL-1)//CHTEMP(LL+1:8)//' '   
6704       ENDIF 
6705   120 CONTINUE  
6706     
6707 C...Set initial state. Error for unknown codes. Reset variables.    

6708       N=2   
6709       DO 140 I=1,2  
6710       K(I,2)=0  
6711       DO 130 J=1,18 
6712   130 IF(CHIDNT(I+1).EQ.CHCDE(J)) K(I,2)=KCDE(J)    
6713       P(I,5)=ULMASS(K(I,2)) 
6714       MINT(40+I)=1  
6715       IF(IABS(K(I,2)).GT.100) MINT(40+I)=2  
6716       DO 140 J=1,5  
6717   140 V(I,J)=0. 
6718       IF(K(1,2).EQ.0) WRITE(MSTU(11),1000) CHBEAM(1:LEN(2)) 
6719       IF(K(2,2).EQ.0) WRITE(MSTU(11),1100) CHTARG(1:LEN(3)) 
6720       IF(K(1,2).EQ.0.OR.K(2,2).EQ.0) STOP   
6721       DO 150 J=6,10 
6722   150 VINT(J)=0.    
6723       CHINIT=' '    
6724     
6725 C...Set up kinematics for events defined in CM frame.   

6726       IF(CHCOM(1)(1:2).EQ.'cm') THEN    
6727         IF(CHCOM(2)(1:1).NE.'e') THEN   
6728           LOFFS=(34-(LEN(2)+LEN(3)))/2  
6729           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//  
6730      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' ' 
6731         ELSE    
6732           LOFFS=(33-(LEN(2)+LEN(3)))/2  
6733           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '// 
6734      &    CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' ' 
6735         ENDIF   
6736 C        WRITE(MSTU(11),1200) CHINIT 

6737 C        WRITE(MSTU(11),1300) WIN    

6738         S=WIN**2    
6739         P(1,1)=0.   
6740         P(1,2)=0.   
6741         P(2,1)=0.   
6742         P(2,2)=0.   
6743         P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2.*P(1,5)*P(2,5))**2)/ 
6744      &  (4.*S)) 
6745         P(2,3)=-P(1,3)  
6746         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)    
6747         P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)    
6748     
6749 C...Set up kinematics for fixed target events.  

6750       ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN   
6751         LOFFS=(29-(LEN(2)+LEN(3)))/2    
6752         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//  
6753      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//    
6754      &  ' fixed target'//' '    
6755 C        WRITE(MSTU(11),1200) CHINIT 

6756 C        WRITE(MSTU(11),1400) WIN    

6757         P(1,1)=0.   
6758         P(1,2)=0.   
6759         P(2,1)=0.   
6760         P(2,2)=0.   
6761         P(1,3)=WIN  
6762         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)    
6763         P(2,3)=0.   
6764         P(2,4)=P(2,5)   
6765         S=P(1,5)**2+P(2,5)**2+2.*P(2,4)*P(1,4)  
6766         VINT(10)=P(1,3)/(P(1,4)+P(2,4)) 
6767         CALL LUROBO(0.,0.,0.,0.,-VINT(10))  
6768 C        WRITE(MSTU(11),1500) SQRT(S)    

6769     
6770 C...Set up kinematics for events in user-defined frame. 

6771       ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN   
6772         LOFFS=(13-(LEN(1)+LEN(2)))/2    
6773         CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//  
6774      &  CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//    
6775      &  'user-specified configuration'//' ' 
6776 C        WRITE(MSTU(11),1200) CHINIT 

6777 C        WRITE(MSTU(11),1600)    

6778 C        WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)  

6779 C        WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)  

6780         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)    
6781         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)    
6782         DO 160 J=1,3    
6783   160   VINT(7+J)=sngl((DBLE(P(1,J))+DBLE(P(2,J)))
6784      &          /DBLE(P(1,4)+P(2,4)))
6785         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))  
6786         VINT(7)=ULANGL(P(1,1),P(1,2))   
6787         CALL LUROBO(0.,-VINT(7),0.,0.,0.)   
6788         VINT(6)=ULANGL(P(1,3),P(1,1))   
6789         CALL LUROBO(-VINT(6),0.,0.,0.,0.)   
6790         S=P(1,5)**2+P(2,5)**2+2.*(P(1,4)*P(2,4)-P(1,3)*P(2,3))  
6791 C        WRITE(MSTU(11),1500) SQRT(S)    

6792     
6793 C...Unknown frame. Error for too low CM energy. 

6794       ELSE  
6795         WRITE(MSTU(11),1800) CHFRAM(1:LEN(1))   
6796         STOP    
6797       ENDIF 
6798       IF(S.LT.PARP(2)**2) THEN  
6799         WRITE(MSTU(11),1900) SQRT(S)    
6800         STOP    
6801       ENDIF 
6802     
6803 C...Save information on incoming particles. 

6804       MINT(11)=K(1,2)   
6805       MINT(12)=K(2,2)   
6806       MINT(43)=2*MINT(41)+MINT(42)-2    
6807       VINT(1)=SQRT(S)   
6808       VINT(2)=S 
6809       VINT(3)=P(1,5)    
6810       VINT(4)=P(2,5)    
6811       VINT(5)=P(1,3)    
6812     
6813 C...Store constants to be used in generation.   

6814       IF(MSTP(82).LE.1) VINT(149)=4.*PARP(81)**2/S  
6815       IF(MSTP(82).GE.2) VINT(149)=4.*PARP(82)**2/S  
6816     
6817 C...Formats for initialization and error information.   

6818  1000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''.'/ 
6819      &1X,'Execution stopped!')  
6820  1100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''.'/   
6821      &1X,'Execution stopped!')  
6822 clin 1200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') 

6823 c 1300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',   

6824 c     &19X,'I'/1X,'I',76X,'I'/1X,78('='))    

6825 c 1400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')  

6826 c 1500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,  

6827 c     &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))    

6828 c 1600 FORMAT(1X,'I',76X,'I'/1X,'I',24X,'px (GeV/c)',3X,'py (GeV/c)',3X, 

6829 c     &'pz (GeV/c)',16X,'I') 

6830 clin 1700 FORMAT(1X,'I',15X,A8,3(2X,F10.3,1X),15X,'I')  

6831  1800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''.'/  
6832      &1X,'Execution stopped!')  
6833  1900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ', 
6834      &'generation.'/1X,'Execution stopped!')    
6835     
6836       RETURN    
6837       END   
6838     
6839 C*********************************************************************  

6840     
6841       SUBROUTINE PYINRE 
6842     
6843 C...Calculates full and effective widths of guage bosons, stores masses 

6844 C...and widths, rescales coefficients to be used for resonance  

6845 C...production generation.  

6846       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
6847       SAVE /LUDAT1/ 
6848       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
6849       SAVE /LUDAT2/ 
6850       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
6851       SAVE /LUDAT3/ 
6852       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
6853       SAVE /PYSUBS/ 
6854       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
6855       SAVE /PYPARS/ 
6856       COMMON/PYINT1/MINT(400),VINT(400) 
6857       SAVE /PYINT1/ 
6858       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
6859       SAVE /PYINT2/ 
6860       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
6861       SAVE /AMPTPYINT4/ 
6862       COMMON/PYINT6/PROC(0:200) 
6863       CHARACTER PROC*28 
6864       SAVE /PYINT6/ 
6865       DIMENSION WDTP(0:40),WDTE(0:40,0:5)   
6866     
6867 C...Calculate full and effective widths of gauge bosons.    

6868       AEM=PARU(101) 
6869       XW=PARU(102)  
6870       DO 100 I=21,40    
6871       DO 100 J=0,40 
6872       WIDP(I,J)=0.  
6873   100 WIDE(I,J)=0.  
6874     
6875 C...W+/-:   

6876       WMAS=PMAS(24,1)   
6877       WFAC=AEM/(24.*XW)*WMAS    
6878       CALL PYWIDT(24,WMAS,WDTP,WDTE)    
6879       WIDS(24,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+  
6880      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+  
6881      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
6882       WIDS(24,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
6883       WIDS(24,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)    
6884       DO 110 I=0,40 
6885       WIDP(24,I)=WFAC*WDTP(I)   
6886   110 WIDE(24,I)=WFAC*WDTE(I,0) 
6887     
6888 C...H+/-:   

6889       HCMAS=PMAS(37,1)  
6890       HCFAC=AEM/(8.*XW)*(HCMAS/WMAS)**2*HCMAS   
6891       CALL PYWIDT(37,HCMAS,WDTP,WDTE)   
6892       WIDS(37,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+  
6893      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+  
6894      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
6895       WIDS(37,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
6896       WIDS(37,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)    
6897       DO 120 I=0,40 
6898       WIDP(37,I)=HCFAC*WDTP(I)  
6899   120 WIDE(37,I)=HCFAC*WDTE(I,0)    
6900     
6901 C...Z0: 

6902       ZMAS=PMAS(23,1)   
6903       ZFAC=AEM/(48.*XW*(1.-XW))*ZMAS    
6904       CALL PYWIDT(23,ZMAS,WDTP,WDTE)    
6905       WIDS(23,1)=((WDTE(0,1)+WDTE(0,2))**2+ 
6906      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+   
6907      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
6908       WIDS(23,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
6909       WIDS(23,3)=0. 
6910       DO 130 I=0,40 
6911       WIDP(23,I)=ZFAC*WDTP(I)   
6912   130 WIDE(23,I)=ZFAC*WDTE(I,0) 
6913     
6914 C...H0: 

6915       HMAS=PMAS(25,1)   
6916       HFAC=AEM/(8.*XW)*(HMAS/WMAS)**2*HMAS  
6917       CALL PYWIDT(25,HMAS,WDTP,WDTE)    
6918       WIDS(25,1)=((WDTE(0,1)+WDTE(0,2))**2+ 
6919      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+   
6920      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
6921       WIDS(25,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
6922       WIDS(25,3)=0. 
6923       DO 140 I=0,40 
6924       WIDP(25,I)=HFAC*WDTP(I)   
6925   140 WIDE(25,I)=HFAC*WDTE(I,0) 
6926     
6927 C...Z'0:    

6928       ZPMAS=PMAS(32,1)  
6929       ZPFAC=AEM/(48.*XW*(1.-XW))*ZPMAS  
6930       CALL PYWIDT(32,ZPMAS,WDTP,WDTE)   
6931       WIDS(32,1)=((WDTE(0,1)+WDTE(0,2)+WDTE(0,3))**2+   
6932      &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+   
6933      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
6934       WIDS(32,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
6935       WIDS(32,3)=0. 
6936       DO 150 I=0,40 
6937       WIDP(32,I)=ZPFAC*WDTP(I)  
6938   150 WIDE(32,I)=ZPFAC*WDTE(I,0)    
6939     
6940 C...R:  

6941       RMAS=PMAS(40,1)   
6942       RFAC=0.08*RMAS/((MSTP(1)-1)*(1.+6.*(1.+ULALPS(RMAS**2)/PARU(1)))) 
6943       CALL PYWIDT(40,RMAS,WDTP,WDTE)    
6944       WIDS(40,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+  
6945      &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+  
6946      &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2    
6947       WIDS(40,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)    
6948       WIDS(40,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)    
6949       DO 160 I=0,40 
6950       WIDP(40,I)=WFAC*WDTP(I)   
6951   160 WIDE(40,I)=WFAC*WDTE(I,0) 
6952     
6953 C...Q:  

6954       KFLQM=1   
6955       DO 170 I=1,MIN(8,MDCY(21,3))  
6956       IDC=I+MDCY(21,2)-1    
6957       IF(MDME(IDC,1).LE.0) GOTO 170 
6958       KFLQM=I   
6959   170 CONTINUE  
6960       MINT(46)=KFLQM    
6961       KFPR(81,1)=KFLQM  
6962       KFPR(81,2)=KFLQM  
6963       KFPR(82,1)=KFLQM  
6964       KFPR(82,2)=KFLQM  
6965     
6966 C...Set resonance widths and branching ratios in JETSET.    

6967       DO 180 I=1,6  
6968       IF(I.LE.3) KC=I+22    
6969       IF(I.EQ.4) KC=32  
6970       IF(I.EQ.5) KC=37  
6971       IF(I.EQ.6) KC=40  
6972       PMAS(KC,2)=WIDP(KC,0) 
6973       PMAS(KC,3)=MIN(0.9*PMAS(KC,1),10.*PMAS(KC,2)) 
6974       DO 180 J=1,MDCY(KC,3) 
6975       IDC=J+MDCY(KC,2)-1    
6976       BRAT(IDC)=WIDE(KC,J)/WIDE(KC,0)   
6977   180 CONTINUE  
6978     
6979 C...Special cases in treatment of gamma*/Z0: redefine process name. 

6980       IF(MSTP(43).EQ.1) THEN    
6981         PROC(1)='f + fb -> gamma*'  
6982       ELSEIF(MSTP(43).EQ.2) THEN    
6983         PROC(1)='f + fb -> Z0'  
6984       ELSEIF(MSTP(43).EQ.3) THEN    
6985         PROC(1)='f + fb -> gamma*/Z0'   
6986       ENDIF 
6987     
6988 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. 

6989       IF(MSTP(44).EQ.1) THEN    
6990         PROC(141)='f + fb -> gamma*'    
6991       ELSEIF(MSTP(44).EQ.2) THEN    
6992         PROC(141)='f + fb -> Z0'    
6993       ELSEIF(MSTP(44).EQ.3) THEN    
6994         PROC(141)='f + fb -> Z''0'  
6995       ELSEIF(MSTP(44).EQ.4) THEN    
6996         PROC(141)='f + fb -> gamma*/Z0' 
6997       ELSEIF(MSTP(44).EQ.5) THEN    
6998         PROC(141)='f + fb -> gamma*/Z''0'   
6999       ELSEIF(MSTP(44).EQ.6) THEN    
7000         PROC(141)='f + fb -> Z0/Z''0'   
7001       ELSEIF(MSTP(44).EQ.7) THEN    
7002         PROC(141)='f + fb -> gamma*/Z0/Z''0'    
7003       ENDIF 
7004     
7005       RETURN    
7006       END   
7007     
7008 C*********************************************************************  

7009     
7010       SUBROUTINE PYXTOT 
7011     
7012 C...Parametrizes total, double diffractive, single diffractive and  

7013 C...elastic cross-sections for different energies and beams.    

7014       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
7015       SAVE /LUDAT1/ 
7016       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
7017       SAVE /PYPARS/ 
7018       COMMON/PYINT1/MINT(400),VINT(400) 
7019       SAVE /PYINT1/ 
7020       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
7021       SAVE /PYINT5/ 
7022       DIMENSION BCS(5,8),BCB(2,5),BCC(3)    
7023     
7024 C...The following data lines are coefficients needed in the 

7025 C...Block, Cahn parametrization of total cross-section and nuclear  

7026 C...slope parameter; see below. 

7027       DATA ((BCS(I,J),J=1,8),I=1,5)/    
7028      1 41.74, 0.66, 0.0000, 337.,  0.0, 0.0, -39.3, 0.48,   
7029      2 41.66, 0.60, 0.0000, 306.,  0.0, 0.0, -34.6, 0.51,   
7030      3 41.36, 0.63, 0.0000, 299.,  7.3, 0.5, -40.4, 0.47,   
7031      4 41.68, 0.63, 0.0083, 330.,  0.0, 0.0, -39.0, 0.48,   
7032      5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/   
7033       DATA ((BCB(I,J),J=1,5),I=1,2)/    
7034      1 10.79, -0.049, 0.040, 21.5, 1.23,    
7035      2  9.92, -0.027, 0.013, 18.9, 1.07/    
7036       DATA BCC/2.0164346,-0.5590311,0.0376279/  
7037     
7038 C...Total cross-section and nuclear slope parameter for pp and p-pbar   

7039       NFIT=MIN(5,MAX(1,MSTP(31)))   
7040       SIGP=BCS(NFIT,1)+BCS(NFIT,2)*(-0.25*PARU(1)**2*   
7041      &(1.-0.25*BCS(NFIT,3)*PARU(1)**2)+(1.+0.5*BCS(NFIT,3)*PARU(1)**2)* 
7042      &(LOG(VINT(2)/BCS(NFIT,4)))**2+BCS(NFIT,3)*    
7043      &(LOG(VINT(2)/BCS(NFIT,4)))**4)/   
7044      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*  
7045      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)*(LOG(VINT(2)/BCS(NFIT,4)))**2+   
7046      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)+BCS(NFIT,5)*    
7047      &VINT(2)**(BCS(NFIT,6)-1.)*SIN(0.5*PARU(1)*BCS(NFIT,6))    
7048       SIGM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*  
7049      &COS(0.5*PARU(1)*BCS(NFIT,8))  
7050       REFP=BCS(NFIT,2)*PARU(1)*LOG(VINT(2)/BCS(NFIT,4))/    
7051      &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*  
7052      &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)+(LOG(VINT(2)/BCS(NFIT,4)))**2+   
7053      &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)-BCS(NFIT,5)*    
7054      &VINT(2)**(BCS(NFIT,6)-1.)*COS(0.5*PARU(1)*BCS(NFIT,6))    
7055       REFM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*  
7056      &SIN(0.5*PARU(1)*BCS(NFIT,8))  
7057       SIGMA=SIGP-ISIGN(1,MINT(11)*MINT(12))*SIGM    
7058       RHO=(REFP-ISIGN(1,MINT(11)*MINT(12))*REFM)/SIGMA  
7059     
7060 C...Nuclear slope parameter B, curvature C: 

7061       NFIT=1    
7062       IF(MSTP(31).GE.4) NFIT=2  
7063       BP=BCB(NFIT,1)+BCB(NFIT,2)*LOG(VINT(2))+  
7064      &BCB(NFIT,3)*(LOG(VINT(2)))**2 
7065       BM=BCB(NFIT,4)+BCB(NFIT,5)*LOG(VINT(2))   
7066       B=BP-ISIGN(1,MINT(11)*MINT(12))*SIGM/SIGP*(BM-BP) 
7067       VINT(121)=B   
7068       C=-0.5*BCC(2)/BCC(3)*(1.-SQRT(MAX(0.,1.+4.*BCC(3)/BCC(2)**2*  
7069      &(1.E-03*VINT(1)-BCC(1)))))    
7070       VINT(122)=C   
7071     
7072 C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).   

7073       SIGEL=SIGMA**2*(1.+RHO**2)/(16.*PARU(1)*PARU(5)*B)    
7074     
7075 C...Single diffractive scattering cross-section from Goulianos: 

7076       SIGSD=2.*0.68*(1.+36./VINT(2))*LOG(0.6+0.1*VINT(2))   
7077     
7078 C...Double diffractive scattering cross-section (essentially fixed by   

7079 C...sigma-sd and sigma-el). 

7080       SIGDD=SIGSD**2/(3.*SIGEL) 
7081     
7082 C...Total non-elastic, non-diffractive cross-section.   

7083       SIGND=SIGMA-SIGDD-SIGSD-SIGEL 
7084     
7085 C...Rescale for pions.  

7086       IF(IABS(MINT(11)).EQ.211.AND.IABS(MINT(12)).EQ.211) THEN  
7087         SIGMA=4./9.*SIGMA   
7088         SIGDD=4./9.*SIGDD   
7089         SIGSD=4./9.*SIGSD   
7090         SIGEL=4./9.*SIGEL   
7091         SIGND=4./9.*SIGND   
7092       ELSEIF(IABS(MINT(11)).EQ.211.OR.IABS(MINT(12)).EQ.211) THEN   
7093         SIGMA=2./3.*SIGMA   
7094         SIGDD=2./3.*SIGDD   
7095         SIGSD=2./3.*SIGSD   
7096         SIGEL=2./3.*SIGEL   
7097         SIGND=2./3.*SIGND   
7098       ENDIF 
7099     
7100 C...Save cross-sections in common block PYPARA. 

7101       VINT(101)=SIGMA   
7102       VINT(102)=SIGEL   
7103       VINT(103)=SIGSD   
7104       VINT(104)=SIGDD   
7105       VINT(106)=SIGND   
7106       XSEC(95,1)=SIGND  
7107     
7108       RETURN    
7109       END   
7110     
7111 C*********************************************************************  

7112     
7113       SUBROUTINE PYMAXI 
7114     
7115 C...Finds optimal set of coefficients for kinematical variable selection    

7116 C...and the maximum of the part of the differential cross-section used  

7117 C...in the event weighting. 

7118       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
7119       SAVE /LUDAT1/ 
7120       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
7121       SAVE /LUDAT2/ 
7122       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
7123       SAVE /PYSUBS/ 
7124       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
7125       SAVE /PYPARS/ 
7126       COMMON/PYINT1/MINT(400),VINT(400) 
7127       SAVE /PYINT1/ 
7128       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
7129       SAVE /PYINT2/ 
7130       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
7131       SAVE /PYINT3/ 
7132       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
7133       SAVE /AMPTPYINT4/ 
7134       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
7135       SAVE /PYINT5/ 
7136       COMMON/PYINT6/PROC(0:200) 
7137       CHARACTER PROC*28 
7138       SAVE /PYINT6/ 
7139       CHARACTER CVAR(4)*4   
7140       DIMENSION NPTS(4),MVARPT(200,4),VINTPT(200,30),SIGSPT(200),   
7141      &NAREL(6),WTREL(6),WTMAT(6,6),COEFU(6),IACCMX(4),SIGSMX(4),    
7142      &SIGSSM(3) 
7143       DATA CVAR/'tau ','tau''','y*  ','cth '/   
7144       INTEGER :: IOFF=0
7145 C...Select subprocess to study: skip cases not applicable.  

7146       VINT(143)=1.  
7147       VINT(144)=1.  
7148       XSEC(0,1)=0.  
7149       DO 350 ISUB=1,200 
7150       IF(ISUB.GE.91.AND.ISUB.LE.95) THEN    
7151         XSEC(ISUB,1)=VINT(ISUB+11)  
7152         IF(MSUB(ISUB).NE.1) GOTO 350    
7153         GOTO 340    
7154       ELSEIF(ISUB.EQ.96) THEN   
7155         IF(MINT(43).NE.4) GOTO 350  
7156         IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0) GOTO 350 
7157       ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.   
7158      &ISUB.EQ.53.OR.ISUB.EQ.68) THEN    
7159         IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 350   
7160       ELSE  
7161         IF(MSUB(ISUB).NE.1) GOTO 350    
7162       ENDIF 
7163       MINT(1)=ISUB  
7164       ISTSB=ISET(ISUB)  
7165       IF(ISUB.EQ.96) ISTSB=2    
7166       IF(MSTP(122).GE.2) WRITE(MSTU(11),1000) ISUB  
7167     
7168 C...Find resonances (explicit or implicit in cross-section).    

7169       MINT(72)=0    
7170       KFR1=0    
7171 cms.. reinitializing to avoid compiler warning

7172       TAUR2=PMAS(KFR2,1)**2/VINT(2)
7173       GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
7174       TAUR1=0.
7175       GAMR1=0.
7176       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3) THEN 
7177         KFR1=KFPR(ISUB,1)   
7178       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN    
7179         KFR1=25 
7180       ENDIF 
7181       IF(KFR1.NE.0) THEN    
7182         TAUR1=PMAS(KFR1,1)**2/VINT(2)   
7183         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2) 
7184         MINT(72)=1  
7185         MINT(73)=KFR1   
7186         VINT(73)=TAUR1  
7187         VINT(74)=GAMR1  
7188       ENDIF 
7189       IF(ISUB.EQ.141) THEN  
7190         KFR2=23 
7191         TAUR2=PMAS(KFR2,1)**2/VINT(2)   
7192         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2) 
7193         MINT(72)=2  
7194         MINT(74)=KFR2   
7195         VINT(75)=TAUR2  
7196         VINT(76)=GAMR2  
7197       ENDIF 
7198     
7199 C...Find product masses and minimum pT of process.  

7200       SQM3=0.   
7201       SQM4=0.   
7202       MINT(71)=0    
7203       VINT(71)=CKIN(3)  
7204       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
7205         IF(KFPR(ISUB,1).NE.0) SQM3=PMAS(KFPR(ISUB,1),1)**2  
7206         IF(KFPR(ISUB,2).NE.0) SQM4=PMAS(KFPR(ISUB,2),1)**2  
7207         IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1 
7208         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) 
7209         IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)  
7210         IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08*PARP(82) 
7211       ENDIF 
7212       VINT(63)=SQM3 
7213       VINT(64)=SQM4 
7214     
7215 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).  

7216       NPTS(1)=2+2*MINT(72)  
7217       IF(MINT(43).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) NPTS(1)=1    
7218       NPTS(2)=1 
7219       IF(MINT(43).GE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) NPTS(2)=2    
7220       NPTS(3)=1 
7221       IF(MINT(43).EQ.4) NPTS(3)=3   
7222       NPTS(4)=1 
7223       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5    
7224       NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)  
7225     
7226 C...Reset coefficients of cross-section weighting.  

7227       DO 100 J=1,20 
7228   100 COEF(ISUB,J)=0.   
7229       COEF(ISUB,1)=1.   
7230       COEF(ISUB,7)=0.5  
7231       COEF(ISUB,8)=0.5  
7232       COEF(ISUB,10)=1.  
7233       COEF(ISUB,15)=1.  
7234       MCTH=0    
7235       MTAUP=0   
7236       CTH=0.    
7237       TAUP=0.   
7238       SIGSAM=0. 
7239     
7240 C...Find limits and select tau, y*, cos(theta-hat) and tau' values, 

7241 C...in grid of phase space points.  

7242       CALL PYKLIM(1)    
7243       NACC=0    
7244       DO 120 ITRY=1,NTRY    
7245       IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN 
7246         MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))   
7247         CALL PYKMAP(1,MTAU,0.5) 
7248         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4) 
7249       ENDIF 
7250       IF((ISTSB.EQ.3.OR.ISTSB.EQ.4).AND.MOD(ITRY-1,NPTS(3)*NPTS(4)).    
7251      &EQ.0) THEN    
7252         MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2)) 
7253         CALL PYKMAP(4,MTAUP,0.5)    
7254       ENDIF 
7255       IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) CALL PYKLIM(2)   
7256       IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN 
7257         MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))    
7258         CALL PYKMAP(2,MYST,0.5) 
7259         CALL PYKLIM(3)  
7260       ENDIF 
7261       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
7262         MCTH=1+MOD(ITRY-1,NPTS(4))  
7263         CALL PYKMAP(3,MCTH,0.5) 
7264       ENDIF 
7265       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2) 
7266     
7267 C...Calculate and store cross-section.  

7268       MINT(51)=0    
7269       CALL PYKLIM(0)    
7270       IF(MINT(51).EQ.1) GOTO 120    
7271       NACC=NACC+1   
7272       MVARPT(NACC,1)=MTAU   
7273       MVARPT(NACC,2)=MTAUP  
7274       MVARPT(NACC,3)=MYST   
7275       MVARPT(NACC,4)=MCTH   
7276       DO 110 J=1,30 
7277   110 VINTPT(NACC,J)=VINT(10+J) 
7278       CALL PYSIGH(NCHN,SIGS)    
7279       SIGSPT(NACC)=SIGS 
7280       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS    
7281       IF(MSTP(122).GE.2) WRITE(MSTU(11),1100) MTAU,MTAUP,MYST,MCTH, 
7282      &VINT(21),VINT(22),VINT(23),VINT(26),SIGS  
7283   120 CONTINUE  
7284       IF(SIGSAM.EQ.0.) THEN 
7285         WRITE(MSTU(11),1200) ISUB   
7286         STOP    
7287       ENDIF 
7288     
7289 C...Calculate integrals in tau and y* over maximal phase space limits.  

7290       TAUMIN=VINT(11)   
7291       TAUMAX=VINT(31)   
7292       ATAU1=LOG(TAUMAX/TAUMIN)  
7293       ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7294 cms.. declare ataus outside to avoid compiler warning

7295       ATAU3=0.
7296       ATAU4=0.
7297       ATAU5=0.
7298       ATAU6=0.
7299       IF(NPTS(1).GE.3) THEN 
7300         ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1    
7301         ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/  
7302      &  GAMR1   
7303       ENDIF 
7304       IF(NPTS(1).GE.5) THEN 
7305         ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2    
7306         ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/  
7307      &  GAMR2   
7308       ENDIF 
7309       YSTMIN=0.5*LOG(TAUMIN)    
7310       YSTMAX=-YSTMIN    
7311       AYST0=YSTMAX-YSTMIN   
7312       AYST1=0.5*(YSTMAX-YSTMIN)**2  
7313       AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))    
7314     
7315 C...Reset. Sum up cross-sections in points calculated.  

7316       DO 230 IVAR=1,4   
7317       IF(NPTS(IVAR).EQ.1) GOTO 230  
7318       IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 230 
7319       NBIN=NPTS(IVAR)   
7320       DO 130 J1=1,NBIN  
7321       NAREL(J1)=0   
7322       WTREL(J1)=0.  
7323       COEFU(J1)=0.  
7324       DO 130 J2=1,NBIN  
7325   130 WTMAT(J1,J2)=0.   
7326       DO 140 IACC=1,NACC    
7327       IBIN=MVARPT(IACC,IVAR)    
7328       NAREL(IBIN)=NAREL(IBIN)+1 
7329       WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)  
7330     
7331 C...Sum up tau cross-section pieces in points used. 

7332       IF(IVAR.EQ.1) THEN    
7333         TAU=VINTPT(IACC,11) 
7334         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.  
7335         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU   
7336         IF(NBIN.GE.3) THEN  
7337           WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1) 
7338           WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/    
7339      &    ((TAU-TAUR1)**2+GAMR1**2) 
7340         ENDIF   
7341         IF(NBIN.GE.5) THEN  
7342           WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2) 
7343           WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/    
7344      &    ((TAU-TAUR2)**2+GAMR2**2) 
7345         ENDIF   
7346     
7347 C...Sum up tau' cross-section pieces in points used.    

7348       ELSEIF(IVAR.EQ.2) THEN    
7349         TAU=VINTPT(IACC,11) 
7350         TAUP=VINTPT(IACC,16)    
7351         TAUPMN=VINTPT(IACC,6)   
7352         TAUPMX=VINTPT(IACC,26)  
7353         ATAUP1=LOG(TAUPMX/TAUPMN)   
7354         ATAUP2=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU) 
7355         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.  
7356         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*(1.-TAU/TAUP)**3/   
7357      &  TAUP    
7358     
7359 C...Sum up y* and cos(theta-hat) cross-section pieces in points used.   

7360       ELSEIF(IVAR.EQ.3) THEN    
7361         YST=VINTPT(IACC,12) 
7362         WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)  
7363         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST1)*(YSTMAX-YST)  
7364         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST) 
7365       ELSE  
7366         RM34=2.*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2  
7367         RSQM=1.+RM34    
7368         CTHMAX=SQRT(1.-4.*VINT(71)**2/(TAUMAX*VINT(2))) 
7369         CTHMIN=-CTHMAX  
7370         IF(CTHMAX.GT.0.9999) RM34=MAX(RM34,2.*VINT(71)**2/  
7371      &  (TAUMAX*VINT(2)))   
7372         ACTH1=CTHMAX-CTHMIN 
7373         ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))  
7374         ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))  
7375         ACTH4=1./MAX(RM34,RSQM-CTHMAX)-1./MAX(RM34,RSQM-CTHMIN) 
7376         ACTH5=1./MAX(RM34,RSQM+CTHMIN)-1./MAX(RM34,RSQM+CTHMAX) 
7377         CTH=VINTPT(IACC,13) 
7378         WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.  
7379         WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/MAX(RM34,RSQM-CTH)    
7380         WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/MAX(RM34,RSQM+CTH)    
7381         WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/MAX(RM34,RSQM-CTH)**2 
7382         WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/MAX(RM34,RSQM+CTH)**2 
7383       ENDIF 
7384   140 CONTINUE  
7385     
7386 C...Check that equation system solvable; else trivial way out.  

7387       IF(MSTP(122).GE.2) WRITE(MSTU(11),1300) CVAR(IVAR)    
7388       MSOLV=1   
7389       DO 150 IBIN=1,NBIN    
7390       IF(MSTP(122).GE.2) WRITE(MSTU(11),1400) (WTMAT(IBIN,IRED),    
7391      &IRED=1,NBIN),WTREL(IBIN)  
7392   150 IF(NAREL(IBIN).EQ.0) MSOLV=0  
7393       IF(MSOLV.EQ.0) THEN   
7394         DO 160 IBIN=1,NBIN  
7395   160   COEFU(IBIN)=1.  
7396     
7397 C...Solve to find relative importance of cross-section pieces.  

7398       ELSE  
7399         DO 170 IRED=1,NBIN-1    
7400         DO 170 IBIN=IRED+1,NBIN 
7401         RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)   
7402         WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED) 
7403         DO 170 ICOE=IRED,NBIN   
7404   170   WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)  
7405         DO 190 IRED=NBIN,1,-1   
7406         DO 180 ICOE=IRED+1,NBIN 
7407   180   WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)    
7408   190   COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)    
7409       ENDIF 
7410     
7411 C...Normalize coefficients, with piece shared democratically.   

7412       COEFSU=0. 
7413       DO 200 IBIN=1,NBIN    
7414       COEFU(IBIN)=MAX(0.,COEFU(IBIN))   
7415   200 COEFSU=COEFSU+COEFU(IBIN) 
7416       IF(IVAR.EQ.1) IOFF=0  
7417       IF(IVAR.EQ.2) IOFF=14 
7418       IF(IVAR.EQ.3) IOFF=6  
7419       IF(IVAR.EQ.4) IOFF=9  
7420       IF(COEFSU.GT.0.) THEN 
7421         DO 210 IBIN=1,NBIN  
7422   210   COEF(ISUB,IOFF+IBIN)=PARP(121)/NBIN+(1.-PARP(121))*COEFU(IBIN)/ 
7423      &  COEFSU  
7424       ELSE  
7425         DO 220 IBIN=1,NBIN  
7426   220   COEF(ISUB,IOFF+IBIN)=1./NBIN    
7427       ENDIF 
7428       IF(MSTP(122).GE.2) WRITE(MSTU(11),1500) CVAR(IVAR),   
7429      &(COEF(ISUB,IOFF+IBIN),IBIN=1,NBIN)    
7430   230 CONTINUE  
7431     
7432 C...Find two most promising maxima among points previously determined.  

7433       DO 240 J=1,4  
7434       IACCMX(J)=0   
7435   240 SIGSMX(J)=0.  
7436       NMAX=0    
7437       DO 290 IACC=1,NACC    
7438       DO 250 J=1,30 
7439   250 VINT(10+J)=VINTPT(IACC,J) 
7440       CALL PYSIGH(NCHN,SIGS)    
7441       IEQ=0 
7442       DO 260 IMV=1,NMAX 
7443   260 IF(ABS(SIGS-SIGSMX(IMV)).LT.1E-4*(SIGS+SIGSMX(IMV))) IEQ=IMV  
7444       IF(IEQ.EQ.0) THEN 
7445         DO 270 IMV=NMAX,1,-1    
7446         IIN=IMV+1   
7447         IF(SIGS.LE.SIGSMX(IMV)) GOTO 280    
7448         IACCMX(IMV+1)=IACCMX(IMV)   
7449   270   SIGSMX(IMV+1)=SIGSMX(IMV)   
7450         IIN=1   
7451   280   IACCMX(IIN)=IACC    
7452         SIGSMX(IIN)=SIGS    
7453         IF(NMAX.LE.1) NMAX=NMAX+1   
7454       ENDIF 
7455   290 CONTINUE  
7456     
7457 C...Read out starting position for search.  

7458       IF(MSTP(122).GE.2) WRITE(MSTU(11),1600)   
7459       SIGSAM=SIGSMX(1)  
7460       DO 330 IMAX=1,NMAX    
7461       IACC=IACCMX(IMAX) 
7462       MTAU=MVARPT(IACC,1)   
7463       MTAUP=MVARPT(IACC,2)  
7464       MYST=MVARPT(IACC,3)   
7465       MCTH=MVARPT(IACC,4)   
7466       VTAU=0.5  
7467       VYST=0.5  
7468       VCTH=0.5  
7469       VTAUP=0.5 
7470     
7471 C...Starting point and step size in parameter space.    

7472       DO 320 IRPT=1,2   
7473       DO 310 IVAR=1,4   
7474       IF(NPTS(IVAR).EQ.1) GOTO 310  
7475       IF(IVAR.EQ.1) VVAR=VTAU   
7476       IF(IVAR.EQ.2) VVAR=VTAUP  
7477       IF(IVAR.EQ.3) VVAR=VYST   
7478       IF(IVAR.EQ.4) VVAR=VCTH   
7479       IF(IVAR.EQ.1) MVAR=MTAU   
7480       IF(IVAR.EQ.2) MVAR=MTAUP  
7481       IF(IVAR.EQ.3) MVAR=MYST   
7482       IF(IVAR.EQ.4) MVAR=MCTH   
7483       IF(IRPT.EQ.1) VDEL=0.1    
7484       IF(IRPT.EQ.2) VDEL=MAX(0.01,MIN(0.05,VVAR-0.02,0.98-VVAR))    
7485       IF(IRPT.EQ.1) VMAR=0.02   
7486       IF(IRPT.EQ.2) VMAR=0.002  
7487       IMOV0=1   
7488       IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0   
7489       DO 300 IMOV=IMOV0,8   
7490     
7491 C...Define new point in parameter space.    

7492       IF(IMOV.EQ.0) THEN    
7493         INEW=2  
7494         VNEW=VVAR   
7495       ELSEIF(IMOV.EQ.1) THEN    
7496         INEW=3  
7497         VNEW=VVAR+VDEL  
7498       ELSEIF(IMOV.EQ.2) THEN    
7499         INEW=1  
7500         VNEW=VVAR-VDEL  
7501       ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND. 
7502      &VVAR+2.*VDEL.LT.1.-VMAR) THEN 
7503         VVAR=VVAR+VDEL  
7504         SIGSSM(1)=SIGSSM(2) 
7505         SIGSSM(2)=SIGSSM(3) 
7506         INEW=3  
7507         VNEW=VVAR+VDEL  
7508       ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND. 
7509      &VVAR-2.*VDEL.GT.VMAR) THEN    
7510         VVAR=VVAR-VDEL  
7511         SIGSSM(3)=SIGSSM(2) 
7512         SIGSSM(2)=SIGSSM(1) 
7513         INEW=1  
7514         VNEW=VVAR-VDEL  
7515       ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN   
7516         VDEL=0.5*VDEL   
7517         VVAR=VVAR+VDEL  
7518         SIGSSM(1)=SIGSSM(2) 
7519         INEW=2  
7520         VNEW=VVAR   
7521       ELSE  
7522         VDEL=0.5*VDEL   
7523         VVAR=VVAR-VDEL  
7524         SIGSSM(3)=SIGSSM(2) 
7525         INEW=2  
7526         VNEW=VVAR   
7527       ENDIF 
7528     
7529 C...Convert to relevant variables and find derived new limits.  

7530       IF(IVAR.EQ.1) THEN    
7531         VTAU=VNEW   
7532         CALL PYKMAP(1,MTAU,VTAU)    
7533         IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIM(4) 
7534       ENDIF 
7535       IF(IVAR.LE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) THEN 
7536         IF(IVAR.EQ.2) VTAUP=VNEW    
7537         CALL PYKMAP(4,MTAUP,VTAUP)  
7538       ENDIF 
7539       IF(IVAR.LE.2) CALL PYKLIM(2)  
7540       IF(IVAR.LE.3) THEN    
7541         IF(IVAR.EQ.3) VYST=VNEW 
7542         CALL PYKMAP(2,MYST,VYST)    
7543         CALL PYKLIM(3)  
7544       ENDIF 
7545       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN 
7546         IF(IVAR.EQ.4) VCTH=VNEW 
7547         CALL PYKMAP(3,MCTH,VCTH)    
7548       ENDIF 
7549       IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2) 
7550     
7551 C...Evaluate cross-section. Save new maximum. Final maximum.    

7552       CALL PYSIGH(NCHN,SIGS)    
7553       SIGSSM(INEW)=SIGS 
7554       IF(SIGS.GT.SIGSAM) SIGSAM=SIGS    
7555       IF(MSTP(122).GE.2) WRITE(MSTU(11),1700) IMAX,IVAR,MVAR,IMOV,  
7556      &VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS 
7557   300 CONTINUE  
7558   310 CONTINUE  
7559   320 CONTINUE  
7560       IF(IMAX.EQ.1) SIGS11=SIGSAM   
7561   330 CONTINUE  
7562       XSEC(ISUB,1)=1.05*SIGSAM  
7563   340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)   
7564   350 CONTINUE  
7565     
7566 C...Print summary table.    

7567       IF(MSTP(122).GE.1) THEN   
7568         WRITE(MSTU(11),1800)    
7569         WRITE(MSTU(11),1900)    
7570         DO 360 ISUB=1,200   
7571         IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 360 
7572         IF(ISUB.EQ.96.AND.MINT(43).NE.4) GOTO 360   
7573         IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 360 
7574         IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.    
7575      &  ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 360   
7576         WRITE(MSTU(11),2000) ISUB,PROC(ISUB),XSEC(ISUB,1)   
7577   360   CONTINUE    
7578         WRITE(MSTU(11),2100)    
7579       ENDIF 
7580     
7581 C...Format statements for maximization results. 

7582  1000 FORMAT(/1X,'Coefficient optimization and maximum search for ',    
7583      &'subprocess no',I4/1X,'Coefficient modes     tau',10X,'y*',9X,    
7584      &'cth',9X,'tau''',7X,'sigma')  
7585  1100 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,E12.4)   
7586  1200 FORMAT(1X,'Error: requested subprocess ',I3,' has vanishing ',    
7587      &'cross-section.'/1X,'Execution stopped!')
7588  1300 FORMAT(1X,'Coefficients of equation system to be solved for ',A4) 
7589  1400 FORMAT(1X,1P,7E11.3)  
7590  1500 FORMAT(1X,'Result for ',A4,':',6F9.4) 
7591  1600 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',  
7592      &'MOD MOV   VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma') 
7593  1700 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,E12.4)   
7594  1800 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',  
7595      &'cross-section maximum search',1X,8('*')) 
7596  1900 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I  ISUB  ',  
7597      &'Subprocess name',15X,'I  Maximum value  I'/11X,'I',38X,'I',  
7598      &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')  
7599  2000 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,E12.4,3X,'I')    
7600  2100 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))   
7601     
7602       RETURN    
7603       END   
7604     
7605 C*********************************************************************  

7606     
7607       SUBROUTINE PYOVLY(MOVLY)  
7608     
7609 C...Initializes multiplicity distribution and selects mutliplicity  

7610 C...of overlayed events, i.e. several events occuring at the same   

7611 C...beam crossing.  

7612       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
7613       SAVE /LUDAT1/ 
7614       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
7615       SAVE /PYPARS/ 
7616       COMMON/PYINT1/MINT(400),VINT(400) 
7617       SAVE /PYINT1/ 
7618       DIMENSION WTI(0:100)  
7619       SAVE IMAX,WTI,WTS 
7620     
7621 C...Sum of allowed cross-sections for overlayed events. 

7622       IF(MOVLY.EQ.1) THEN   
7623         VINT(131)=VINT(106) 
7624         IF(MSTP(132).GE.2) VINT(131)=VINT(131)+VINT(104)    
7625         IF(MSTP(132).GE.3) VINT(131)=VINT(131)+VINT(103)    
7626         IF(MSTP(132).GE.4) VINT(131)=VINT(131)+VINT(102)    
7627     
7628 C...Initialize multiplicity distribution for unbiased events.   

7629         IF(MSTP(133).EQ.1) THEN 
7630           XNAVE=VINT(131)*PARP(131) 
7631           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE   
7632           WTI(0)=EXP(-MIN(50.,XNAVE))   
7633           WTS=0.    
7634           WTN=0.    
7635           DO 100 I=1,100    
7636           WTI(I)=WTI(I-1)*XNAVE/I   
7637           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 110    
7638           WTS=WTS+WTI(I)    
7639           WTN=WTN+WTI(I)*I  
7640   100     IMAX=I    
7641   110     VINT(132)=XNAVE   
7642           VINT(133)=WTN/WTS 
7643           VINT(134)=WTS 
7644     
7645 C...Initialize mutiplicity distribution for biased events.  

7646         ELSEIF(MSTP(133).EQ.2) THEN 
7647           XNAVE=VINT(131)*PARP(131) 
7648           IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE   
7649           WTI(1)=EXP(-MIN(50.,XNAVE))*XNAVE 
7650           WTS=WTI(1)    
7651           WTN=WTI(1)    
7652           DO 120 I=2,100    
7653           WTI(I)=WTI(I-1)*XNAVE/(I-1)   
7654           IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 130    
7655           WTS=WTS+WTI(I)    
7656           WTN=WTN+WTI(I)*I  
7657   120     IMAX=I    
7658   130     VINT(132)=XNAVE   
7659           VINT(133)=WTN/WTS 
7660           VINT(134)=WTS 
7661         ENDIF   
7662     
7663 C...Pick multiplicity of overlayed events.  

7664       ELSE  
7665         IF(MSTP(133).EQ.0) THEN 
7666           MINT(81)=MAX(1,MSTP(134)) 
7667         ELSE    
7668           WTR=WTS*RLU(0)    
7669           DO 140 I=1,IMAX   
7670           MINT(81)=I    
7671           WTR=WTR-WTI(I)    
7672           IF(WTR.LE.0.) GOTO 150    
7673   140     CONTINUE  
7674   150     CONTINUE  
7675         ENDIF   
7676       ENDIF 
7677     
7678 C...Format statement for error message. 

7679  1000 FORMAT(1X,'Warning: requested average number of events per bunch',    
7680      &'crossing too large, ',1P,E12.4)  
7681     
7682       RETURN    
7683       END   
7684     
7685 C*********************************************************************  

7686     
7687       SUBROUTINE PYRAND 
7688     
7689 C...Generates quantities characterizing the high-pT scattering at the   

7690 C...parton level according to the matrix elements. Chooses incoming,    

7691 C...reacting partons, their momentum fractions and one of the possible  

7692 C...subprocesses.   

7693       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
7694       SAVE /LUDAT1/ 
7695       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
7696       SAVE /LUDAT2/ 
7697       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
7698       SAVE /PYSUBS/ 
7699       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
7700       SAVE /PYPARS/ 
7701       COMMON/PYINT1/MINT(400),VINT(400) 
7702       SAVE /PYINT1/ 
7703       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
7704       SAVE /PYINT2/ 
7705       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
7706       SAVE /PYINT3/ 
7707       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
7708       SAVE /AMPTPYINT4/ 
7709       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
7710       SAVE /PYINT5/ 
7711     
7712 C...Initial values, specifically for (first) semihard interaction.  

7713       MINT(17)=0    
7714       MINT(18)=0    
7715       VINT(143)=1.  
7716       VINT(144)=1.  
7717       IF(MSUB(95).EQ.1.OR.MINT(82).GE.2) CALL PYMULT(2) 
7718       ISUB=0    
7719   100 MINT(51)=0    
7720     
7721 C...Choice of process type - first event of overlay.    

7722       IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN 
7723         RSUB=XSEC(0,1)*RLU(0)   
7724         DO 110 I=1,200  
7725         IF(MSUB(I).NE.1) GOTO 110   
7726         ISUB=I  
7727         RSUB=RSUB-XSEC(I,1) 
7728         IF(RSUB.LE.0.) GOTO 120 
7729   110   CONTINUE    
7730   120   IF(ISUB.EQ.95) ISUB=96  
7731     
7732 C...Choice of inclusive process type - overlayed events.    

7733       ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN  
7734         RSUB=VINT(131)*RLU(0)   
7735         ISUB=96 
7736         IF(RSUB.GT.VINT(106)) ISUB=93   
7737         IF(RSUB.GT.VINT(106)+VINT(104)) ISUB=92 
7738         IF(RSUB.GT.VINT(106)+VINT(104)+VINT(103)) ISUB=91   
7739       ENDIF 
7740       IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1   
7741       IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1 
7742       MINT(1)=ISUB  
7743     
7744 C...Find resonances (explicit or implicit in cross-section).    

7745       MINT(72)=0    
7746       KFR1=0    
7747       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN   
7748         KFR1=KFPR(ISUB,1)   
7749       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN    
7750         KFR1=25 
7751       ENDIF 
7752       IF(KFR1.NE.0) THEN    
7753         TAUR1=PMAS(KFR1,1)**2/VINT(2)   
7754         GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2) 
7755         MINT(72)=1  
7756         MINT(73)=KFR1   
7757         VINT(73)=TAUR1  
7758         VINT(74)=GAMR1  
7759       ENDIF 
7760       IF(ISUB.EQ.141) THEN  
7761         KFR2=23 
7762         TAUR2=PMAS(KFR2,1)**2/VINT(2)   
7763         GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2) 
7764         MINT(72)=2  
7765         MINT(74)=KFR2   
7766         VINT(75)=TAUR2  
7767         VINT(76)=GAMR2  
7768       ENDIF 
7769     
7770 C...Find product masses and minimum pT of process,  

7771 C...optionally with broadening according to a truncated Breit-Wigner.   

7772       VINT(63)=0.   
7773       VINT(64)=0.   
7774       MINT(71)=0    
7775       VINT(71)=CKIN(3)  
7776       IF(MINT(82).GE.2) VINT(71)=0. 
7777       IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN   
7778         DO 130 I=1,2    
7779         IF(KFPR(ISUB,I).EQ.0) THEN  
7780         ELSEIF(MSTP(42).LE.0) THEN  
7781           VINT(62+I)=PMAS(KFPR(ISUB,I),1)**2    
7782         ELSE    
7783           VINT(62+I)=ULMASS(KFPR(ISUB,I))**2    
7784         ENDIF   
7785   130   CONTINUE    
7786         IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1 
7787         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) 
7788       ENDIF 
7789     
7790       IF(ISET(ISUB).EQ.0) THEN  
7791 C...Double or single diffractive, or elastic scattering:    

7792 C...choose m^2 according to 1/m^2 (diffractive), constant (elastic) 

7793         IS=INT(1.5+RLU(0))  
7794         VINT(63)=VINT(3)**2 
7795         VINT(64)=VINT(4)**2 
7796         IF(ISUB.EQ.92.OR.ISUB.EQ.93) VINT(62+IS)=PARP(111)**2   
7797         IF(ISUB.EQ.93) VINT(65-IS)=PARP(111)**2 
7798         SH=VINT(2)  
7799         SQM1=VINT(3)**2 
7800         SQM2=VINT(4)**2 
7801         SQM3=VINT(63)   
7802         SQM4=VINT(64)   
7803         SQLA12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2   
7804         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4   
7805         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH    
7806         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH 
7807         THL=0.5*(THTER1-THTER2) 
7808         THU=0.5*(THTER1+THTER2) 
7809         THM=MIN(MAX(THL,PARP(101)),THU) 
7810         JTMAX=0 
7811         IF(ISUB.EQ.92.OR.ISUB.EQ.93) JTMAX=ISUB-91  
7812         DO 140 JT=1,JTMAX   
7813         MINT(13+3*JT-IS*(2*JT-3))=1 
7814         SQMMIN=VINT(59+3*JT-IS*(2*JT-3))    
7815         SQMI=VINT(8-3*JT+IS*(2*JT-3))**2    
7816         SQMJ=VINT(3*JT-1-IS*(2*JT-3))**2    
7817         SQMF=VINT(68-3*JT+IS*(2*JT-3))  
7818         SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-    
7819      &  SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)   
7820         QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+  
7821      &  SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))   
7822         SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))  
7823         IF(ABS(QUAR/SQUA**2).LT.1.E-06) SQMMAX=0.5*QUAR/SQUA    
7824         SQMMAX=MIN(SQMMAX,(VINT(1)-SQRT(SQMF))**2)  
7825         VINT(59+3*JT-IS*(2*JT-3))=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)    
7826   140   CONTINUE    
7827 C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).   

7828         SQM3=VINT(63)   
7829         SQM4=VINT(64)   
7830         SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4   
7831         THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH    
7832         THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH 
7833         THL=0.5*(THTER1-THTER2) 
7834         THU=0.5*(THTER1+THTER2) 
7835         B=VINT(121) 
7836         C=VINT(122) 
7837         IF(ISUB.EQ.92.OR.ISUB.EQ.93) THEN   
7838           B=0.5*B   
7839           C=0.5*C   
7840         ENDIF   
7841         THM=MIN(MAX(THL,PARP(101)),THU) 
7842         EXPTH=0.    
7843         THARG=B*(THM-THU)   
7844         IF(THARG.GT.-20.) EXPTH=EXP(THARG)  
7845   150   TH=THU+LOG(EXPTH+(1.-EXPTH)*RLU(0))/B   
7846         TH=MAX(THM,MIN(THU,TH)) 
7847         RATLOG=MIN((B+C*(TH+THM))*(TH-THM),(B+C*(TH+THU))*(TH-THU)) 
7848         IF(RATLOG.LT.LOG(RLU(0))) GOTO 150  
7849         VINT(21)=1. 
7850         VINT(22)=0. 
7851         VINT(23)=MIN(1.,MAX(-1.,(2.*TH-THTER1)/THTER2)) 
7852     
7853 C...Note: in the following, by In is meant the integral over the    

7854 C...quantity multiplying coefficient cn.    

7855 C...Choose tau according to h1(tau)/tau, where  

7856 C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +    

7857 C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +  

7858 C...I0/I4*c4*1/(tau+tau_R') +   

7859 C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and    

7860 C...c0 + c1 + c2 + c3 + c4 + c5 = 1 

7861       ELSEIF(ISET(ISUB).GE.1.AND.ISET(ISUB).LE.4) THEN  
7862         CALL PYKLIM(1)  
7863         IF(MINT(51).NE.0) GOTO 100  
7864         RTAU=RLU(0) 
7865         MTAU=1  
7866         IF(RTAU.GT.COEF(ISUB,1)) MTAU=2 
7867         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3    
7868         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4   
7869         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)) 
7870      &  MTAU=5  
7871         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ 
7872      &  COEF(ISUB,5)) MTAU=6    
7873         CALL PYKMAP(1,MTAU,RLU(0))  
7874     
7875 C...2 -> 3, 4 processes:    

7876 C...Choose tau' according to h4(tau,tau')/tau', where   

7877 C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and 

7878 C...c0 + c1 = 1.    

7879         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN 
7880           CALL PYKLIM(4)    
7881           IF(MINT(51).NE.0) GOTO 100    
7882           RTAUP=RLU(0)  
7883           MTAUP=1   
7884           IF(RTAUP.GT.COEF(ISUB,15)) MTAUP=2    
7885           CALL PYKMAP(4,MTAUP,RLU(0))   
7886         ENDIF   
7887     
7888 C...Choose y* according to h2(y*), where    

7889 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +    

7890 C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.    

7891         CALL PYKLIM(2)  
7892         IF(MINT(51).NE.0) GOTO 100  
7893         RYST=RLU(0) 
7894         MYST=1  
7895         IF(RYST.GT.COEF(ISUB,7)) MYST=2 
7896         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3    
7897         CALL PYKMAP(2,MYST,RLU(0))  
7898     
7899 C...2 -> 2 processes:   

7900 C...Choose cos(theta-hat) (cth) according to h3(cth), where 

7901 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +    

7902 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,    

7903 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), 

7904 C...and c0 + c1 + c2 + c3 + c4 = 1. 

7905         CALL PYKLIM(3)  
7906         IF(MINT(51).NE.0) GOTO 100  
7907         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN 
7908           RCTH=RLU(0)   
7909           MCTH=1    
7910           IF(RCTH.GT.COEF(ISUB,10)) MCTH=2  
7911           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)) MCTH=3    
7912           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)) MCTH=4  
7913           IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)+ 
7914      &    COEF(ISUB,13)) MCTH=5 
7915           CALL PYKMAP(3,MCTH,RLU(0))    
7916         ENDIF   
7917     
7918 C...Low-pT or multiple interactions (first semihard interaction).   

7919       ELSEIF(ISET(ISUB).EQ.5) THEN  
7920         CALL PYMULT(3)  
7921         ISUB=MINT(1)    
7922       ENDIF 
7923     
7924 C...Choose azimuthal angle. 

7925       VINT(24)=PARU(2)*RLU(0)   
7926     
7927 C...Check against user cuts on kinematics at parton level.  

7928       MINT(51)=0    
7929       IF(ISUB.LE.90.OR.ISUB.GT.100) CALL PYKLIM(0)  
7930       IF(MINT(51).NE.0) GOTO 100    
7931       IF(MINT(82).EQ.1.AND.MSTP(141).GE.1) THEN 
7932         MCUT=0  
7933         IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)   
7934      &  CALL PYKCUT(MCUT)   
7935         IF(MCUT.NE.0) GOTO 100  
7936       ENDIF 
7937     
7938 C...Calculate differential cross-section for different subprocesses.    

7939       CALL PYSIGH(NCHN,SIGS)    
7940     
7941 C...Calculations for Monte Carlo estimate of all cross-sections.    

7942       IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN   
7943         XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS  
7944       ELSEIF(MINT(82).EQ.1) THEN    
7945         XSEC(ISUB,2)=XSEC(ISUB,2)+XSEC(ISUB,1)  
7946       ENDIF 
7947     
7948 C...Multiple interactions: store results of cross-section calculation.  

7949       IF(MINT(43).EQ.4.AND.MSTP(82).GE.3) THEN  
7950         VINT(153)=SIGS  
7951         CALL PYMULT(4)  
7952       ENDIF 
7953     
7954 C...Weighting using estimate of maximum of differential cross-section.  

7955       VIOL=SIGS/XSEC(ISUB,1)    
7956       IF(VIOL.LT.RLU(0)) GOTO 100   
7957     
7958 C...Check for possible violation of estimated maximum of differential   

7959 C...cross-section used in weighting.    

7960       IF(MSTP(123).LE.0) THEN   
7961         IF(VIOL.GT.1.) THEN 
7962           WRITE(MSTU(11),1000) VIOL,NGEN(0,3)+1 
7963           WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26) 
7964           STOP  
7965         ENDIF   
7966       ELSEIF(MSTP(123).EQ.1) THEN   
7967         IF(VIOL.GT.VINT(108)) THEN  
7968           VINT(108)=VIOL    
7969 C          IF(VIOL.GT.1.) THEN   

7970 C            WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1   

7971 C            WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),   

7972 C     &      VINT(26)    

7973 C          ENDIF 

7974         ENDIF   
7975       ELSEIF(VIOL.GT.VINT(108)) THEN    
7976         VINT(108)=VIOL  
7977         IF(VIOL.GT.1.) THEN 
7978           XDIF=XSEC(ISUB,1)*(VIOL-1.)   
7979           XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF    
7980           IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))    
7981      &    XSEC(0,1)=XSEC(0,1)+XDIF  
7982 C          WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1 

7983 C          WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26) 

7984 C          IF(ISUB.LE.9) THEN    

7985 C            WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)  

7986 C          ELSEIF(ISUB.LE.99) THEN   

7987 C            WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)  

7988 C          ELSE  

7989 C            WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)  

7990 C          ENDIF 

7991           VINT(108)=1.  
7992         ENDIF   
7993       ENDIF 
7994     
7995 C...Multiple interactions: choose impact parameter. 

7996       VINT(148)=1.  
7997       IF(MINT(43).EQ.4.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.MSTP(82).GE.3)    
7998      &THEN  
7999         CALL PYMULT(5)  
8000         IF(VINT(150).LT.RLU(0)) GOTO 100    
8001       ENDIF 
8002       IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN  
8003         IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1    
8004         IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1    
8005       ENDIF 
8006       IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1  
8007     
8008 C...Choose flavour of reacting partons (and subprocess).    

8009       RSIGS=SIGS*RLU(0) 
8010       QT2=VINT(48)  
8011       RQQBAR=PARP(87)*(1.-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)    
8012       IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.    
8013      &RLU(0).GT.RQQBAR)) THEN   
8014         DO 190 ICHN=1,NCHN  
8015         KFL1=ISIG(ICHN,1)   
8016         KFL2=ISIG(ICHN,2)   
8017         MINT(2)=ISIG(ICHN,3)    
8018         RSIGS=RSIGS-SIGH(ICHN)  
8019         IF(RSIGS.LE.0.) GOTO 210    
8020   190   CONTINUE    
8021     
8022 C...Multiple interactions: choose qqbar preferentially at small pT. 

8023       ELSEIF(ISUB.EQ.96) THEN   
8024         CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)    
8025         CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)    
8026         MINT(1)=11  
8027         MINT(2)=1   
8028         IF(KFL1.EQ.KFL2.AND.RLU(0).LT.0.5) MINT(2)=2    
8029     
8030 C...Low-pT: choose string drawing configuration.    

8031       ELSE  
8032         KFL1=21 
8033         KFL2=21 
8034         RSIGS=6.*RLU(0) 
8035         MINT(2)=1   
8036         IF(RSIGS.GT.1.) MINT(2)=2   
8037         IF(RSIGS.GT.2.) MINT(2)=3   
8038       ENDIF 
8039     
8040 C...Reassign QCD process. Partons before initial state radiation.   

8041   210 IF(MINT(2).GT.10) THEN    
8042         MINT(1)=MINT(2)/10  
8043         MINT(2)=MOD(MINT(2),10) 
8044       ENDIF 
8045       MINT(15)=KFL1 
8046       MINT(16)=KFL2 
8047       MINT(13)=MINT(15) 
8048       MINT(14)=MINT(16) 
8049       VINT(141)=VINT(41)    
8050       VINT(142)=VINT(42)    
8051     
8052 C...Format statements for differential cross-section maximum violations.    

8053  1000 FORMAT(1X,'Error: maximum violated by',1P,E11.3,1X,   
8054      &'in event',1X,I7,'.'/1X,'Execution stopped!') 
8055  1100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau=',1P, 
8056      &E11.3,', y* =',E11.3,', cthe = ',0P,F11.7,', tau'' =',1P,E11.3)   
8057 clin 1200 FORMAT(1X,'Warning: maximum violated by',1P,E11.3,1X, 

8058 c     &'in event',1X,I7) 

8059 c 1300 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,E11.3) 

8060 c 1400 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,E11.3) 

8061 clin 1500 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,E11.3) 

8062     
8063       RETURN    
8064       END   
8065     
8066 C*********************************************************************  

8067     
8068       SUBROUTINE PYSCAT 
8069     
8070 C...Finds outgoing flavours and event type; sets up the kinematics  

8071 C...and colour flow of the hard scattering. 

8072       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
8073       SAVE /LUJETS/ 
8074       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
8075       SAVE /LUDAT1/ 
8076       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
8077       SAVE /LUDAT2/ 
8078       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
8079       SAVE /LUDAT3/ 
8080       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
8081       SAVE /PYSUBS/ 
8082       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
8083       SAVE /PYPARS/ 
8084       COMMON/PYINT1/MINT(400),VINT(400) 
8085       SAVE /PYINT1/ 
8086       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
8087       SAVE /PYINT2/ 
8088       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
8089       SAVE /PYINT3/ 
8090       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
8091       SAVE /AMPTPYINT4/ 
8092       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
8093       SAVE /PYINT5/ 
8094       DIMENSION WDTP(0:40),WDTE(0:40,0:5),PMQ(2),Z(2),CTHE(2),PHI(2)    
8095     
8096 C...Choice of subprocess, number of documentation lines.    

8097       ISUB=MINT(1)  
8098       IDOC=6+ISET(ISUB) 
8099       IF(ISUB.EQ.95) IDOC=8 
8100       MINT(3)=IDOC-6    
8101       IF(IDOC.GE.9) IDOC=IDOC+2 
8102       MINT(4)=IDOC  
8103       IPU1=MINT(84)+1   
8104       IPU2=MINT(84)+2   
8105       IPU3=MINT(84)+3   
8106       IPU4=MINT(84)+4   
8107       IPU5=MINT(84)+5   
8108       IPU6=MINT(84)+6   
8109     
8110 C...Reset K, P and V vectors. Store incoming particles. 

8111       DO 100 JT=1,MSTP(126)+10  
8112       I=MINT(83)+JT 
8113       DO 100 J=1,5  
8114       K(I,J)=0  
8115       P(I,J)=0. 
8116   100 V(I,J)=0. 
8117       DO 110 JT=1,2 
8118       I=MINT(83)+JT 
8119       K(I,1)=21 
8120       K(I,2)=MINT(10+JT)    
8121       P(I,1)=0. 
8122       P(I,2)=0. 
8123       P(I,5)=VINT(2+JT) 
8124       P(I,3)=VINT(5)*(-1)**(JT+1)   
8125   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)  
8126       MINT(6)=2 
8127       KFRES=0   
8128     
8129 C...Store incoming partons in their CM-frame.   

8130       SH=VINT(44)   
8131       SHR=SQRT(SH)  
8132       SHP=VINT(26)*VINT(2)  
8133       SHPR=SQRT(SHP)    
8134       SHUSER=SHR    
8135       IF(ISET(ISUB).GE.3) SHUSER=SHPR   
8136       DO 120 JT=1,2 
8137       I=MINT(84)+JT 
8138       K(I,1)=14 
8139       K(I,2)=MINT(14+JT)    
8140       K(I,3)=MINT(83)+2+JT  
8141   120 P(I,5)=ULMASS(K(I,2)) 
8142       IF(P(IPU1,5)+P(IPU2,5).GE.SHUSER) THEN    
8143         P(IPU1,5)=0.    
8144         P(IPU2,5)=0.    
8145       ENDIF 
8146       P(IPU1,4)=0.5*(SHUSER+(P(IPU1,5)**2-P(IPU2,5)**2)/SHUSER) 
8147       P(IPU1,3)=SQRT(MAX(0.,P(IPU1,4)**2-P(IPU1,5)**2)) 
8148       P(IPU2,4)=SHUSER-P(IPU1,4)    
8149       P(IPU2,3)=-P(IPU1,3)  
8150     
8151 C...Copy incoming partons to documentation lines.   

8152       DO 130 JT=1,2 
8153       I1=MINT(83)+4+JT  
8154       I2=MINT(84)+JT    
8155       K(I1,1)=21    
8156       K(I1,2)=K(I2,2)   
8157       K(I1,3)=I1-2  
8158       DO 130 J=1,5  
8159   130 P(I1,J)=P(I2,J)   
8160     
8161 C...Choose new quark flavour for relevant annihilation graphs.  

8162       KFLQ=0
8163       IF(ISUB.EQ.12.OR.ISUB.EQ.53) THEN 
8164         CALL PYWIDT(21,SHR,WDTP,WDTE)   
8165         RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*RLU(0) 
8166         DO 140 I=1,2*MSTP(1)    
8167         KFLQ=I  
8168         RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))   
8169         IF(RKFL.LE.0.) GOTO 150 
8170   140   CONTINUE    
8171   150   CONTINUE    
8172       ENDIF 
8173     
8174 C...Final state flavours and colour flow: default values.   

8175       JS=1  
8176       MINT(21)=MINT(15) 
8177       MINT(22)=MINT(16) 
8178       MINT(23)=0    
8179       MINT(24)=0    
8180       KCC=20    
8181       KCS=ISIGN(1,MINT(15)) 
8182     
8183       IF(ISUB.LE.10) THEN   
8184       IF(ISUB.EQ.1) THEN    
8185 C...f + fb -> gamma*/Z0.    

8186         KFRES=23    
8187     
8188       ELSEIF(ISUB.EQ.2) THEN    
8189 C...f + fb' -> W+/- .   

8190         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
8191         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
8192         KFRES=ISIGN(24,KCH1+KCH2)   
8193     
8194       ELSEIF(ISUB.EQ.3) THEN    
8195 C...f + fb -> H0.   

8196         KFRES=25    
8197     
8198       ELSEIF(ISUB.EQ.4) THEN    
8199 C...gamma + W+/- -> W+/-.   

8200     
8201       ELSEIF(ISUB.EQ.5) THEN    
8202 C...Z0 + Z0 -> H0.  

8203         XH=SH/SHP   
8204         MINT(21)=MINT(15)   
8205         MINT(22)=MINT(16)   
8206         PMQ(1)=ULMASS(MINT(21)) 
8207         PMQ(2)=ULMASS(MINT(22)) 
8208   240   JT=INT(1.5+RLU(0))  
8209         ZMIN=2.*PMQ(JT)/SHPR    
8210         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
8211         ZMAX=MIN(1.-XH,ZMAX)    
8212         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
8213         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
8214      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 240 
8215         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
8216         IF(SQC1.LT.1.E-8) GOTO 240  
8217         C1=SQRT(SQC1)   
8218         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
8219         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
8220         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
8221         Z(3-JT)=1.-XH/(1.-Z(JT))    
8222         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
8223         IF(SQC1.LT.1.E-8) GOTO 240  
8224         C1=SQRT(SQC1)   
8225         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
8226         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
8227         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
8228         PHIR=PARU(2)*RLU(0) 
8229         CPHI=COS(PHIR)  
8230         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
8231         Z1=2.-Z(JT) 
8232         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
8233         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
8234         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
8235      &  PMQ(3-JT)**2/SHP))  
8236         ZMIN=2.*PMQ(3-JT)/SHPR  
8237         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
8238         ZMAX=MIN(1.-XH,ZMAX)    
8239         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 240 
8240         KCC=22  
8241         KFRES=25    
8242     
8243       ELSEIF(ISUB.EQ.6) THEN    
8244 C...Z0 + W+/- -> W+/-.  

8245     
8246       ELSEIF(ISUB.EQ.7) THEN    
8247 C...W+ + W- -> Z0.  

8248     
8249       ELSEIF(ISUB.EQ.8) THEN    
8250 C...W+ + W- -> H0.  

8251         XH=SH/SHP   
8252   250   DO 280 JT=1,2   
8253         I=MINT(14+JT)   
8254         IA=IABS(I)  
8255         IF(IA.LE.10) THEN   
8256           RVCKM=VINT(180+I)*RLU(0)  
8257           DO 270 J=1,MSTP(1)    
8258           IB=2*J-1+MOD(IA,2)    
8259           IPM=(5-ISIGN(1,I))/2  
8260           IDC=J+MDCY(IA,2)+2    
8261           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270  
8262           MINT(20+JT)=ISIGN(IB,I)   
8263           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)   
8264           IF(RVCKM.LE.0.) GOTO 280  
8265   270     CONTINUE  
8266         ELSE    
8267           IB=2*((IA+1)/2)-1+MOD(IA,2)   
8268           MINT(20+JT)=ISIGN(IB,I)   
8269         ENDIF   
8270   280   PMQ(JT)=ULMASS(MINT(20+JT)) 
8271         JT=INT(1.5+RLU(0))  
8272         ZMIN=2.*PMQ(JT)/SHPR    
8273         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
8274         ZMAX=MIN(1.-XH,ZMAX)    
8275         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
8276         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
8277      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 250 
8278         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
8279         IF(SQC1.LT.1.E-8) GOTO 250  
8280         C1=SQRT(SQC1)   
8281         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
8282         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
8283         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
8284         Z(3-JT)=1.-XH/(1.-Z(JT))    
8285         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
8286         IF(SQC1.LT.1.E-8) GOTO 250  
8287         C1=SQRT(SQC1)   
8288         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
8289         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
8290         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
8291         PHIR=PARU(2)*RLU(0) 
8292         CPHI=COS(PHIR)  
8293         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
8294         Z1=2.-Z(JT) 
8295         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
8296         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
8297         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
8298      &  PMQ(3-JT)**2/SHP))  
8299         ZMIN=2.*PMQ(3-JT)/SHPR  
8300         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
8301         ZMAX=MIN(1.-XH,ZMAX)    
8302         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 250 
8303         KCC=22  
8304         KFRES=25    
8305       ENDIF 
8306     
8307       ELSEIF(ISUB.LE.20) THEN   
8308       IF(ISUB.EQ.11) THEN   
8309 C...f + f' -> f + f'; th = (p(f)-p(f))**2.  

8310         KCC=MINT(2) 
8311         IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2    
8312     
8313       ELSEIF(ISUB.EQ.12) THEN   
8314 C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.   

8315         MINT(21)=ISIGN(KFLQ,MINT(15))   
8316         MINT(22)=-MINT(21)  
8317         KCC=4   
8318     
8319       ELSEIF(ISUB.EQ.13) THEN   
8320 C...f + fb -> g + g; th arbitrary.  

8321         MINT(21)=21 
8322         MINT(22)=21 
8323         KCC=MINT(2)+4   
8324     
8325       ELSEIF(ISUB.EQ.14) THEN   
8326 C...f + fb -> g + gam; th arbitrary.    

8327         IF(RLU(0).GT.0.5) JS=2  
8328         MINT(20+JS)=21  
8329         MINT(23-JS)=22  
8330         KCC=17+JS   
8331     
8332       ELSEIF(ISUB.EQ.15) THEN   
8333 C...f + fb -> g + Z0; th arbitrary. 

8334         IF(RLU(0).GT.0.5) JS=2  
8335         MINT(20+JS)=21  
8336         MINT(23-JS)=23  
8337         KCC=17+JS   
8338     
8339       ELSEIF(ISUB.EQ.16) THEN   
8340 C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 

8341         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
8342         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
8343         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2  
8344         MINT(20+JS)=21  
8345         MINT(23-JS)=ISIGN(24,KCH1+KCH2) 
8346         KCC=17+JS   
8347     
8348       ELSEIF(ISUB.EQ.17) THEN   
8349 C...f + fb -> g + H0; th arbitrary. 

8350         IF(RLU(0).GT.0.5) JS=2  
8351         MINT(20+JS)=21  
8352         MINT(23-JS)=25  
8353         KCC=17+JS   
8354     
8355       ELSEIF(ISUB.EQ.18) THEN   
8356 C...f + fb -> gamma + gamma; th arbitrary.  

8357         MINT(21)=22 
8358         MINT(22)=22 
8359     
8360       ELSEIF(ISUB.EQ.19) THEN   
8361 C...f + fb -> gamma + Z0; th arbitrary. 

8362         IF(RLU(0).GT.0.5) JS=2  
8363         MINT(20+JS)=22  
8364         MINT(23-JS)=23  
8365     
8366       ELSEIF(ISUB.EQ.20) THEN   
8367 C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 

8368         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
8369         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
8370         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2  
8371         MINT(20+JS)=22  
8372         MINT(23-JS)=ISIGN(24,KCH1+KCH2) 
8373       ENDIF 
8374     
8375       ELSEIF(ISUB.LE.30) THEN   
8376       IF(ISUB.EQ.21) THEN   
8377 C...f + fb -> gamma + H0; th arbitrary. 

8378         IF(RLU(0).GT.0.5) JS=2  
8379         MINT(20+JS)=22  
8380         MINT(23-JS)=25  
8381     
8382       ELSEIF(ISUB.EQ.22) THEN   
8383 C...f + fb -> Z0 + Z0; th arbitrary.    

8384         MINT(21)=23 
8385         MINT(22)=23 
8386     
8387       ELSEIF(ISUB.EQ.23) THEN   
8388 C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    

8389         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
8390         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
8391         IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2  
8392         MINT(20+JS)=23  
8393         MINT(23-JS)=ISIGN(24,KCH1+KCH2) 
8394     
8395       ELSEIF(ISUB.EQ.24) THEN   
8396 C...f + fb -> Z0 + H0; th arbitrary.    

8397         IF(RLU(0).GT.0.5) JS=2  
8398         MINT(20+JS)=23  
8399         MINT(23-JS)=25  
8400     
8401       ELSEIF(ISUB.EQ.25) THEN   
8402 C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.    

8403         MINT(21)=-ISIGN(24,MINT(15))    
8404         MINT(22)=-MINT(21)  
8405     
8406       ELSEIF(ISUB.EQ.26) THEN   
8407 C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    

8408         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
8409         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
8410         IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2  
8411         MINT(20+JS)=ISIGN(24,KCH1+KCH2) 
8412         MINT(23-JS)=25  
8413     
8414       ELSEIF(ISUB.EQ.27) THEN   
8415 C...f + fb -> H0 + H0.  

8416     
8417       ELSEIF(ISUB.EQ.28) THEN   
8418 C...f + g -> f + g; th = (p(f)-p(f))**2.    

8419         KCC=MINT(2)+6   
8420         IF(MINT(15).EQ.21) KCC=KCC+2    
8421         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))    
8422         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))    
8423     
8424       ELSEIF(ISUB.EQ.29) THEN   
8425 C...f + g -> f + gamma; th = (p(f)-p(f))**2.    

8426         IF(MINT(15).EQ.21) JS=2 
8427         MINT(23-JS)=22  
8428         KCC=15+JS   
8429         KCS=ISIGN(1,MINT(14+JS))    
8430     
8431       ELSEIF(ISUB.EQ.30) THEN   
8432 C...f + g -> f + Z0; th = (p(f)-p(f))**2.   

8433         IF(MINT(15).EQ.21) JS=2 
8434         MINT(23-JS)=23  
8435         KCC=15+JS   
8436         KCS=ISIGN(1,MINT(14+JS))    
8437       ENDIF 
8438     
8439       ELSEIF(ISUB.LE.40) THEN   
8440       IF(ISUB.EQ.31) THEN   
8441 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.    

8442         IF(MINT(15).EQ.21) JS=2 
8443         I=MINT(14+JS)   
8444         IA=IABS(I)  
8445         MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)  
8446         RVCKM=VINT(180+I)*RLU(0)    
8447         DO 220 J=1,MSTP(1)  
8448         IB=2*J-1+MOD(IA,2)  
8449         IPM=(5-ISIGN(1,I))/2    
8450         IDC=J+MDCY(IA,2)+2  
8451         IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 220    
8452         MINT(20+JS)=ISIGN(IB,I) 
8453         RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) 
8454         IF(RVCKM.LE.0.) GOTO 230    
8455   220   CONTINUE    
8456   230   KCC=15+JS   
8457         KCS=ISIGN(1,MINT(14+JS))    
8458     
8459       ELSEIF(ISUB.EQ.32) THEN   
8460 C...f + g -> f + H0; th = (p(f)-p(f))**2.   

8461         IF(MINT(15).EQ.21) JS=2 
8462         MINT(23-JS)=25  
8463         KCC=15+JS   
8464         KCS=ISIGN(1,MINT(14+JS))    
8465     
8466       ELSEIF(ISUB.EQ.33) THEN   
8467 C...f + gamma -> f + g. 

8468     
8469       ELSEIF(ISUB.EQ.34) THEN   
8470 C...f + gamma -> f + gamma. 

8471     
8472       ELSEIF(ISUB.EQ.35) THEN   
8473 C...f + gamma -> f + Z0.    

8474     
8475       ELSEIF(ISUB.EQ.36) THEN   
8476 C...f + gamma -> f' + W+/-. 

8477     
8478       ELSEIF(ISUB.EQ.37) THEN   
8479 C...f + gamma -> f + H0.    

8480     
8481       ELSEIF(ISUB.EQ.38) THEN   
8482 C...f + Z0 -> f + g.    

8483     
8484       ELSEIF(ISUB.EQ.39) THEN   
8485 C...f + Z0 -> f + gamma.    

8486     
8487       ELSEIF(ISUB.EQ.40) THEN   
8488 C...f + Z0 -> f + Z0.   

8489       ENDIF 
8490     
8491       ELSEIF(ISUB.LE.50) THEN   
8492       IF(ISUB.EQ.41) THEN   
8493 C...f + Z0 -> f' + W+/-.    

8494     
8495       ELSEIF(ISUB.EQ.42) THEN   
8496 C...f + Z0 -> f + H0.   

8497     
8498       ELSEIF(ISUB.EQ.43) THEN   
8499 C...f + W+/- -> f' + g. 

8500     
8501       ELSEIF(ISUB.EQ.44) THEN   
8502 C...f + W+/- -> f' + gamma. 

8503     
8504       ELSEIF(ISUB.EQ.45) THEN   
8505 C...f + W+/- -> f' + Z0.    

8506     
8507       ELSEIF(ISUB.EQ.46) THEN   
8508 C...f + W+/- -> f' + W+/-.  

8509     
8510       ELSEIF(ISUB.EQ.47) THEN   
8511 C...f + W+/- -> f' + H0.    

8512     
8513       ELSEIF(ISUB.EQ.48) THEN   
8514 C...f + H0 -> f + g.    

8515     
8516       ELSEIF(ISUB.EQ.49) THEN   
8517 C...f + H0 -> f + gamma.    

8518     
8519       ELSEIF(ISUB.EQ.50) THEN   
8520 C...f + H0 -> f + Z0.   

8521       ENDIF 
8522     
8523       ELSEIF(ISUB.LE.60) THEN   
8524       IF(ISUB.EQ.51) THEN   
8525 C...f + H0 -> f' + W+/-.    

8526     
8527       ELSEIF(ISUB.EQ.52) THEN   
8528 C...f + H0 -> f + H0.   

8529     
8530       ELSEIF(ISUB.EQ.53) THEN   
8531 C...g + g -> f + fb; th arbitrary.  

8532         KCS=(-1)**INT(1.5+RLU(0))   
8533         MINT(21)=ISIGN(KFLQ,KCS)    
8534         MINT(22)=-MINT(21)  
8535         KCC=MINT(2)+10  
8536     
8537       ELSEIF(ISUB.EQ.54) THEN   
8538 C...g + gamma -> f + fb.    

8539     
8540       ELSEIF(ISUB.EQ.55) THEN   
8541 C...g + Z0 -> f + fb.   

8542     
8543       ELSEIF(ISUB.EQ.56) THEN   
8544 C...g + W+/- -> f + fb'.    

8545     
8546       ELSEIF(ISUB.EQ.57) THEN   
8547 C...g + H0 -> f + fb.   

8548     
8549       ELSEIF(ISUB.EQ.58) THEN   
8550 C...gamma + gamma -> f + fb.    

8551     
8552       ELSEIF(ISUB.EQ.59) THEN   
8553 C...gamma + Z0 -> f + fb.   

8554     
8555       ELSEIF(ISUB.EQ.60) THEN   
8556 C...gamma + W+/- -> f + fb'.    

8557       ENDIF 
8558     
8559       ELSEIF(ISUB.LE.70) THEN   
8560       IF(ISUB.EQ.61) THEN   
8561 C...gamma + H0 -> f + fb.   

8562     
8563       ELSEIF(ISUB.EQ.62) THEN   
8564 C...Z0 + Z0 -> f + fb.  

8565     
8566       ELSEIF(ISUB.EQ.63) THEN   
8567 C...Z0 + W+/- -> f + fb'.   

8568     
8569       ELSEIF(ISUB.EQ.64) THEN   
8570 C...Z0 + H0 -> f + fb.  

8571     
8572       ELSEIF(ISUB.EQ.65) THEN   
8573 C...W+ + W- -> f + fb.  

8574     
8575       ELSEIF(ISUB.EQ.66) THEN   
8576 C...W+/- + H0 -> f + fb'.   

8577     
8578       ELSEIF(ISUB.EQ.67) THEN   
8579 C...H0 + H0 -> f + fb.  

8580     
8581       ELSEIF(ISUB.EQ.68) THEN   
8582 C...g + g -> g + g; th arbitrary.   

8583         KCC=MINT(2)+12  
8584         KCS=(-1)**INT(1.5+RLU(0))   
8585     
8586       ELSEIF(ISUB.EQ.69) THEN   
8587 C...gamma + gamma -> W+ + W-.   

8588     
8589       ELSEIF(ISUB.EQ.70) THEN   
8590 C...gamma + W+/- -> gamma + W+/-    

8591       ENDIF 
8592     
8593       ELSEIF(ISUB.LE.80) THEN   
8594       IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN 
8595 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-. 

8596         XH=SH/SHP   
8597         MINT(21)=MINT(15)   
8598         MINT(22)=MINT(16)   
8599         PMQ(1)=ULMASS(MINT(21)) 
8600         PMQ(2)=ULMASS(MINT(22)) 
8601   290   JT=INT(1.5+RLU(0))  
8602         ZMIN=2.*PMQ(JT)/SHPR    
8603         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
8604         ZMAX=MIN(1.-XH,ZMAX)    
8605         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
8606         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
8607      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 290 
8608         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
8609         IF(SQC1.LT.1.E-8) GOTO 290  
8610         C1=SQRT(SQC1)   
8611         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
8612         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
8613         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
8614         Z(3-JT)=1.-XH/(1.-Z(JT))    
8615         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
8616         IF(SQC1.LT.1.E-8) GOTO 290  
8617         C1=SQRT(SQC1)   
8618         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
8619         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
8620         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
8621         PHIR=PARU(2)*RLU(0) 
8622         CPHI=COS(PHIR)  
8623         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
8624         Z1=2.-Z(JT) 
8625         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
8626         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
8627         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
8628      &  PMQ(3-JT)**2/SHP))  
8629         ZMIN=2.*PMQ(3-JT)/SHPR  
8630         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
8631         ZMAX=MIN(1.-XH,ZMAX)    
8632         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 290 
8633         KCC=22  
8634     
8635       ELSEIF(ISUB.EQ.73) THEN   
8636 C...Z0 + W+/- -> Z0 + W+/-. 

8637         XH=SH/SHP   
8638   300   JT=INT(1.5+RLU(0))  
8639         I=MINT(14+JT)   
8640         IA=IABS(I)  
8641         IF(IA.LE.10) THEN   
8642           RVCKM=VINT(180+I)*RLU(0)  
8643           DO 320 J=1,MSTP(1)    
8644           IB=2*J-1+MOD(IA,2)    
8645           IPM=(5-ISIGN(1,I))/2  
8646           IDC=J+MDCY(IA,2)+2    
8647           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 320  
8648           MINT(20+JT)=ISIGN(IB,I)   
8649           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)   
8650           IF(RVCKM.LE.0.) GOTO 330  
8651   320     CONTINUE  
8652         ELSE    
8653           IB=2*((IA+1)/2)-1+MOD(IA,2)   
8654           MINT(20+JT)=ISIGN(IB,I)   
8655         ENDIF   
8656   330   PMQ(JT)=ULMASS(MINT(20+JT)) 
8657         MINT(23-JT)=MINT(17-JT) 
8658         PMQ(3-JT)=ULMASS(MINT(23-JT))   
8659         JT=INT(1.5+RLU(0))  
8660         ZMIN=2.*PMQ(JT)/SHPR    
8661         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
8662         ZMAX=MIN(1.-XH,ZMAX)    
8663         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
8664         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
8665      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 300 
8666         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
8667         IF(SQC1.LT.1.E-8) GOTO 300  
8668         C1=SQRT(SQC1)   
8669         C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
8670         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
8671         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
8672         Z(3-JT)=1.-XH/(1.-Z(JT))    
8673         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
8674         IF(SQC1.LT.1.E-8) GOTO 300  
8675         C1=SQRT(SQC1)   
8676         C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
8677         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
8678         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
8679         PHIR=PARU(2)*RLU(0) 
8680         CPHI=COS(PHIR)  
8681         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
8682         Z1=2.-Z(JT) 
8683         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
8684         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
8685         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
8686      &  PMQ(3-JT)**2/SHP))  
8687         ZMIN=2.*PMQ(3-JT)/SHPR  
8688         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
8689         ZMAX=MIN(1.-XH,ZMAX)    
8690         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 300 
8691         KCC=22  
8692     
8693       ELSEIF(ISUB.EQ.74) THEN   
8694 C...Z0 + H0 -> Z0 + H0. 

8695     
8696       ELSEIF(ISUB.EQ.75) THEN   
8697 C...W+ + W- -> gamma + gamma.   

8698     
8699       ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN 
8700 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-. 

8701         XH=SH/SHP   
8702   340   DO 370 JT=1,2   
8703         I=MINT(14+JT)   
8704         IA=IABS(I)  
8705         IF(IA.LE.10) THEN   
8706           RVCKM=VINT(180+I)*RLU(0)  
8707           DO 360 J=1,MSTP(1)    
8708           IB=2*J-1+MOD(IA,2)    
8709           IPM=(5-ISIGN(1,I))/2  
8710           IDC=J+MDCY(IA,2)+2    
8711           IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 360  
8712           MINT(20+JT)=ISIGN(IB,I)   
8713           RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)   
8714           IF(RVCKM.LE.0.) GOTO 370  
8715   360     CONTINUE  
8716         ELSE    
8717           IB=2*((IA+1)/2)-1+MOD(IA,2)   
8718           MINT(20+JT)=ISIGN(IB,I)   
8719         ENDIF   
8720   370   PMQ(JT)=ULMASS(MINT(20+JT)) 
8721         JT=INT(1.5+RLU(0))  
8722         ZMIN=2.*PMQ(JT)/SHPR    
8723         ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))  
8724         ZMAX=MIN(1.-XH,ZMAX)    
8725         Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)   
8726         IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.  
8727      &  (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 340 
8728         SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)    
8729         IF(SQC1.LT.1.E-8) GOTO 340  
8730         C1=SQRT(SQC1)   
8731         C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) 
8732         CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1   
8733         CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))  
8734         Z(3-JT)=1.-XH/(1.-Z(JT))    
8735         SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)    
8736         IF(SQC1.LT.1.E-8) GOTO 340  
8737         C1=SQRT(SQC1)   
8738         C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) 
8739         CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1 
8740         CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))  
8741         PHIR=PARU(2)*RLU(0) 
8742         CPHI=COS(PHIR)  
8743         ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI    
8744         Z1=2.-Z(JT) 
8745         Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP) 
8746         Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP    
8747         Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*    
8748      &  PMQ(3-JT)**2/SHP))  
8749         ZMIN=2.*PMQ(3-JT)/SHPR  
8750         ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))    
8751         ZMAX=MIN(1.-XH,ZMAX)    
8752         IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340 
8753         KCC=22  
8754     
8755       ELSEIF(ISUB.EQ.78) THEN   
8756 C...W+/- + H0 -> W+/- + H0. 

8757     
8758       ELSEIF(ISUB.EQ.79) THEN   
8759 C...H0 + H0 -> H0 + H0. 

8760       ENDIF 
8761     
8762       ELSEIF(ISUB.LE.90) THEN   
8763       IF(ISUB.EQ.81) THEN   
8764 C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.   

8765         MINT(21)=ISIGN(MINT(46),MINT(15))   
8766         MINT(22)=-MINT(21)  
8767         KCC=4   
8768     
8769       ELSEIF(ISUB.EQ.82) THEN   
8770 C...g + g -> Q + Qb; th arbitrary.  

8771         KCS=(-1)**INT(1.5+RLU(0))   
8772         MINT(21)=ISIGN(MINT(46),KCS)    
8773         MINT(22)=-MINT(21)  
8774         KCC=MINT(2)+10  
8775       ENDIF 
8776     
8777       ELSEIF(ISUB.LE.100) THEN  
8778       IF(ISUB.EQ.95) THEN   
8779 C...Low-pT ( = energyless g + g -> g + g).  

8780         KCC=MINT(2)+12  
8781         KCS=(-1)**INT(1.5+RLU(0))   
8782     
8783       ELSEIF(ISUB.EQ.96) THEN   
8784 C...Multiple interactions (should be reassigned to QCD process).    

8785       ENDIF 
8786     
8787       ELSEIF(ISUB.LE.110) THEN  
8788       IF(ISUB.EQ.101) THEN  
8789 C...g + g -> gamma*/Z0. 

8790         KCC=21  
8791         KFRES=22    
8792     
8793       ELSEIF(ISUB.EQ.102) THEN  
8794 C...g + g -> H0.    

8795         KCC=21  
8796         KFRES=25    
8797       ENDIF 
8798     
8799       ELSEIF(ISUB.LE.120) THEN  
8800       IF(ISUB.EQ.111) THEN  
8801 C...f + fb -> g + H0; th arbitrary. 

8802         IF(RLU(0).GT.0.5) JS=2  
8803         MINT(20+JS)=21  
8804         MINT(23-JS)=25  
8805         KCC=17+JS   
8806     
8807       ELSEIF(ISUB.EQ.112) THEN  
8808 C...f + g -> f + H0; th = (p(f) - p(f))**2. 

8809         IF(MINT(15).EQ.21) JS=2 
8810         MINT(23-JS)=25  
8811         KCC=15+JS   
8812         KCS=ISIGN(1,MINT(14+JS))    
8813     
8814       ELSEIF(ISUB.EQ.113) THEN  
8815 C...g + g -> g + H0; th arbitrary.  

8816         IF(RLU(0).GT.0.5) JS=2  
8817         MINT(23-JS)=25  
8818         KCC=22+JS   
8819         KCS=(-1)**INT(1.5+RLU(0))   
8820     
8821       ELSEIF(ISUB.EQ.114) THEN  
8822 C...g + g -> gamma + gamma; th arbitrary.   

8823         IF(RLU(0).GT.0.5) JS=2  
8824         MINT(21)=22 
8825         MINT(22)=22 
8826         KCC=21  
8827     
8828       ELSEIF(ISUB.EQ.115) THEN  
8829 C...g + g -> gamma + Z0.    

8830     
8831       ELSEIF(ISUB.EQ.116) THEN  
8832 C...g + g -> Z0 + Z0.   

8833     
8834       ELSEIF(ISUB.EQ.117) THEN  
8835 C...g + g -> W+ + W-.   

8836       ENDIF 
8837     
8838       ELSEIF(ISUB.LE.140) THEN  
8839       IF(ISUB.EQ.121) THEN  
8840 C...g + g -> f + fb + H0.   

8841       ENDIF 
8842     
8843       ELSEIF(ISUB.LE.160) THEN  
8844       IF(ISUB.EQ.141) THEN  
8845 C...f + fb -> gamma*/Z0/Z'0.    

8846         KFRES=32    
8847     
8848       ELSEIF(ISUB.EQ.142) THEN  
8849 C...f + fb' -> H+/-.    

8850         KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))   
8851         KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))   
8852         KFRES=ISIGN(37,KCH1+KCH2)   
8853     
8854       ELSEIF(ISUB.EQ.143) THEN  
8855 C...f + fb' -> R.   

8856         KFRES=ISIGN(40,MINT(15)+MINT(16))   
8857       ENDIF 
8858     
8859       ELSE  
8860       IF(ISUB.EQ.161) THEN  
8861 C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.    

8862         IF(MINT(16).EQ.21) JS=2 
8863         IA=IABS(MINT(17-JS))    
8864         MINT(20+JS)=ISIGN(37,KCHG(IA,1)*MINT(17-JS))    
8865         JA=IA+MOD(IA,2)-MOD(IA+1,2) 
8866         MINT(23-JS)=ISIGN(JA,MINT(17-JS))   
8867         KCC=18-JS   
8868         IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))    
8869         IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))    
8870       ENDIF 
8871       ENDIF 
8872     
8873       IF(IDOC.EQ.7) THEN    
8874 C...Resonance not decaying: store colour connection indices.    

8875         I=MINT(83)+7    
8876         K(IPU3,1)=1 
8877         K(IPU3,2)=KFRES 
8878         K(IPU3,3)=I 
8879         P(IPU3,4)=SHUSER    
8880         P(IPU3,5)=SHUSER    
8881         K(IPU1,4)=IPU2  
8882         K(IPU1,5)=IPU2  
8883         K(IPU2,4)=IPU1  
8884         K(IPU2,5)=IPU1  
8885         K(I,1)=21   
8886         K(I,2)=KFRES    
8887         P(I,4)=SHUSER   
8888         P(I,5)=SHUSER   
8889         N=IPU3  
8890         MINT(21)=KFRES  
8891         MINT(22)=0  
8892     
8893       ELSEIF(IDOC.EQ.8) THEN    
8894 C...2 -> 2 processes: store outgoing partons in their CM-frame. 

8895         DO 390 JT=1,2   
8896         I=MINT(84)+2+JT 
8897         K(I,1)=1    
8898         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3   
8899         K(I,2)=MINT(20+JT)  
8900         K(I,3)=MINT(83)+IDOC+JT-2   
8901         IF(IABS(K(I,2)).LE.10.OR.K(I,2).EQ.21) THEN 
8902           P(I,5)=ULMASS(K(I,2)) 
8903         ELSE    
8904           P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))    
8905         ENDIF   
8906   390   CONTINUE    
8907         IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN 
8908           KFA1=IABS(MINT(21))   
8909           KFA2=IABS(MINT(22))   
8910           IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))  
8911      &    THEN  
8912             MINT(51)=1  
8913             RETURN  
8914           ENDIF 
8915           P(IPU3,5)=0.  
8916           P(IPU4,5)=0.  
8917         ENDIF   
8918         P(IPU3,4)=0.5*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR) 
8919         P(IPU3,3)=SQRT(MAX(0.,P(IPU3,4)**2-P(IPU3,5)**2))   
8920         P(IPU4,4)=SHR-P(IPU3,4) 
8921         P(IPU4,3)=-P(IPU3,3)    
8922         N=IPU4  
8923         MINT(7)=MINT(83)+7  
8924         MINT(8)=MINT(83)+8  
8925     
8926 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4). 

8927         CALL LUDBRB(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)  
8928     
8929       ELSEIF(IDOC.EQ.9) THEN    
8930 C'''2 -> 3 processes:   

8931     
8932       ELSEIF(IDOC.EQ.11) THEN   
8933 C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons. 

8934         PHI(1)=PARU(2)*RLU(0)   
8935         PHI(2)=PHI(1)-PHIR  
8936         DO 400 JT=1,2   
8937         I=MINT(84)+2+JT 
8938         K(I,1)=1    
8939         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3   
8940         K(I,2)=MINT(20+JT)  
8941         K(I,3)=MINT(83)+IDOC+JT-2   
8942         P(I,5)=ULMASS(K(I,2))   
8943         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.  
8944         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))    
8945         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2)) 
8946         P(I,1)=PTABS*COS(PHI(JT))   
8947         P(I,2)=PTABS*SIN(PHI(JT))   
8948         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)   
8949         P(I,4)=0.5*SHPR*Z(JT)   
8950         IZW=MINT(83)+6+JT   
8951         K(IZW,1)=21 
8952         K(IZW,2)=23 
8953         IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT)))    
8954         K(IZW,3)=IZW-2  
8955         P(IZW,1)=-P(I,1)    
8956         P(IZW,2)=-P(I,2)    
8957         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)  
8958         P(IZW,4)=0.5*SHPR*(1.-Z(JT))    
8959   400   P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))    
8960         I=MINT(83)+9    
8961         K(IPU5,1)=1 
8962         K(IPU5,2)=KFRES 
8963         K(IPU5,3)=I 
8964         P(IPU5,5)=SHR   
8965         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)  
8966         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)  
8967         P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)  
8968         P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)  
8969         K(I,1)=21   
8970         K(I,2)=KFRES    
8971         DO 410 J=1,5    
8972   410   P(I,J)=P(IPU5,J)    
8973         N=IPU5  
8974         MINT(23)=KFRES  
8975     
8976       ELSEIF(IDOC.EQ.12) THEN   
8977 C...Z0 and W+/- scattering: store bosons and outgoing partons.  

8978         PHI(1)=PARU(2)*RLU(0)   
8979         PHI(2)=PHI(1)-PHIR  
8980         DO 420 JT=1,2   
8981         I=MINT(84)+2+JT 
8982         K(I,1)=1    
8983         IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3   
8984         K(I,2)=MINT(20+JT)  
8985         K(I,3)=MINT(83)+IDOC+JT-2   
8986         P(I,5)=ULMASS(K(I,2))   
8987         IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.  
8988         PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))    
8989         PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2)) 
8990         P(I,1)=PTABS*COS(PHI(JT))   
8991         P(I,2)=PTABS*SIN(PHI(JT))   
8992         P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)   
8993         P(I,4)=0.5*SHPR*Z(JT)   
8994         IZW=MINT(83)+6+JT   
8995         K(IZW,1)=21 
8996         IF(MINT(14+JT).EQ.MINT(20+JT)) THEN 
8997           K(IZW,2)=23   
8998         ELSE    
8999           K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT))-LUCHGE(MINT(20+JT)))    
9000         ENDIF   
9001         K(IZW,3)=IZW-2  
9002         P(IZW,1)=-P(I,1)    
9003         P(IZW,2)=-P(I,2)    
9004         P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)  
9005         P(IZW,4)=0.5*SHPR*(1.-Z(JT))    
9006         P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))    
9007         IPU=MINT(84)+4+JT   
9008         K(IPU,1)=3  
9009         K(IPU,2)=KFPR(ISUB,JT)  
9010         K(IPU,3)=MINT(83)+8+JT  
9011         IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN 
9012           P(IPU,5)=ULMASS(K(IPU,2)) 
9013         ELSE    
9014           P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))  
9015         ENDIF   
9016         MINT(22+JT)=K(IZW,2)    
9017   420   CONTINUE    
9018         IF(ISUB.EQ.72) K(MINT(84)+4+INT(1.5+RLU(0)),2)=-24  
9019 C...Find rotation and boost for hard scattering subsystem.  

9020         I1=MINT(83)+7   
9021         I2=MINT(83)+8   
9022         BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))   
9023         BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))   
9024         BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))   
9025         GAMCM=(P(I1,4)+P(I2,4))/SHR 
9026         BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3) 
9027         PX=P(I1,1)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEXCM 
9028         PY=P(I1,2)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEYCM 
9029         PZ=P(I1,3)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEZCM 
9030         THECM=ULANGL(PZ,SQRT(PX**2+PY**2))  
9031         PHICM=ULANGL(PX,PY) 
9032 C...Store hard scattering subsystem. Rotate and boost it.   

9033         SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4.*P(IPU5,5)**2*    
9034      &  P(IPU6,5)**2    
9035         PABS=SQRT(MAX(0.,SQLAM/(4.*SH)))    
9036         CTHWZ=VINT(23)  
9037         STHWZ=SQRT(MAX(0.,1.-CTHWZ**2)) 
9038         PHIWZ=VINT(24)-PHICM    
9039         P(IPU5,1)=PABS*STHWZ*COS(PHIWZ) 
9040         P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ) 
9041         P(IPU5,3)=PABS*CTHWZ    
9042         P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)    
9043         P(IPU6,1)=-P(IPU5,1)    
9044         P(IPU6,2)=-P(IPU5,2)    
9045         P(IPU6,3)=-P(IPU5,3)    
9046         P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)    
9047         CALL LUDBRB(IPU5,IPU6,THECM,PHICM,DBLE(BEXCM),DBLE(BEYCM),  
9048      &  DBLE(BEZCM))    
9049         DO 430 JT=1,2   
9050         I1=MINT(83)+8+JT    
9051         I2=MINT(84)+4+JT    
9052         K(I1,1)=21  
9053         K(I1,2)=K(I2,2) 
9054         DO 430 J=1,5    
9055   430   P(I1,J)=P(I2,J) 
9056         N=IPU6  
9057         MINT(7)=MINT(83)+9  
9058         MINT(8)=MINT(83)+10 
9059       ENDIF 
9060     
9061       IF(IDOC.GE.8) THEN    
9062 C...Store colour connection indices.    

9063         DO 440 J=1,2    
9064         JC=J    
9065         IF(KCS.EQ.-1) JC=3-J    
9066         IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=    
9067      &  K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC) 
9068         IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=    
9069      &  K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC) 
9070         IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= 
9071      &  MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))   
9072   440   IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= 
9073      &  MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))   
9074     
9075 C...Copy outgoing partons to documentation lines.   

9076         DO 450 I=1,2    
9077         I1=MINT(83)+IDOC-2+I    
9078         I2=MINT(84)+2+I 
9079         K(I1,1)=21  
9080         K(I1,2)=K(I2,2) 
9081         IF(IDOC.LE.9) K(I1,3)=0 
9082         IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I 
9083         DO 450 J=1,5    
9084   450   P(I1,J)=P(I2,J) 
9085       ENDIF 
9086       MINT(52)=N    
9087     
9088 C...Low-pT events: remove gluons used for string drawing purposes.  

9089       IF(ISUB.EQ.95) THEN   
9090         K(IPU3,1)=K(IPU3,1)+10  
9091         K(IPU4,1)=K(IPU4,1)+10  
9092         DO 460 J=41,66  
9093   460   VINT(J)=0.  
9094         DO 470 I=MINT(83)+5,MINT(83)+8  
9095         DO 470 J=1,5    
9096   470   P(I,J)=0.   
9097       ENDIF 
9098     
9099       RETURN    
9100       END   
9101     
9102 C*********************************************************************  

9103     
9104       SUBROUTINE PYSSPA(IPU1,IPU2)  
9105     
9106 C...Generates spacelike parton showers. 

9107       IMPLICIT DOUBLE PRECISION(D)  
9108       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9109       SAVE /LUJETS/ 
9110       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
9111       SAVE /LUDAT1/ 
9112       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
9113       SAVE /LUDAT2/ 
9114       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
9115       SAVE /PYSUBS/ 
9116       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
9117       SAVE /PYPARS/ 
9118       COMMON/PYINT1/MINT(400),VINT(400) 
9119       SAVE /PYINT1/ 
9120       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
9121       SAVE /PYINT2/ 
9122       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
9123       SAVE /PYINT3/ 
9124       DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVS(2),ROBO(5),   
9125      &XFS(2,-6:6),XFA(-6:6),XFB(-6:6),XFN(-6:6),WTAP(-6:6),WTSF(-6:6),  
9126      &THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),DPB(4)   
9127     
9128 C...Calculate maximum virtuality and check that evolution possible. 

9129       IPUS1=IPU1    
9130       IPUS2=IPU2    
9131       ISUB=MINT(1)  
9132       Q2E=VINT(52)  
9133       IF(ISET(ISUB).EQ.1) THEN  
9134         Q2E=Q2E/PARP(67)    
9135       ELSEIF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN   
9136         Q2E=PMAS(23,1)**2   
9137         IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2E=PMAS(24,1)**2 
9138       ENDIF 
9139       TMAX=LOG(PARP(67)*PARP(63)*Q2E/PARP(61)**2)   
9140       IF(PARP(67)*Q2E.LT.MAX(PARP(62)**2,2.*PARP(61)**2).OR.    
9141      &TMAX.LT.0.2) RETURN   
9142     
9143 C...Common constants and initial values. Save normal Lambda value.  

9144       XE0=2.*PARP(65)/VINT(1)   
9145       ALAMS=PARU(111)   
9146       PARU(111)=PARP(61)    
9147       NS=N  
9148   100 N=NS  
9149       DO 110 JT=1,2 
9150       KFLS(JT)=MINT(14+JT)  
9151       KFLS(JT+2)=KFLS(JT)   
9152       XS(JT)=VINT(40+JT)    
9153       ZS(JT)=1. 
9154       Q2S(JT)=PARP(67)*Q2E  
9155       TEVS(JT)=TMAX 
9156       ALAM(JT)=PARP(61) 
9157       THE2(JT)=100. 
9158       DO 110 KFL=-6,6   
9159   110 XFS(JT,KFL)=XSFX(JT,KFL)  
9160       DSH=dble(VINT(44))
9161       IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) DSH=dble(VINT(26)*VINT(2))
9162 cms.. pre-initialize for compiler

9163       KFLA=0
9164       Z=0.
9165       TEVB=0.
9166       THE2T=0.
9167 
9168 C...Pick up leg with highest virtuality.    

9169   120 N=N+1 
9170       JT=1  
9171       IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2   
9172       KFLB=KFLS(JT) 
9173       XB=XS(JT) 
9174       DO 130 KFL=-6,6   
9175   130 XFB(KFL)=XFS(JT,KFL)  
9176       DSHR=2D0*SQRT(DSH)    
9177       DSHZ=DSH/DBLE(ZS(JT)) 
9178       XE=MAX(XE0,XB*(1./(1.-PARP(66))-1.))  
9179       IF(XB+XE.GE.0.999) THEN   
9180         Q2B=0.  
9181         GOTO 220    
9182       ENDIF 
9183     
9184 C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.   

9185       IF(MSTP(62).LE.1) THEN    
9186         Q2B=0.5*(1./ZS(JT)+1.)*Q2S(JT)+0.5*(1./ZS(JT)-1.)*(Q2S(3-JT)-   
9187      &  SNGL(DSH)+SQRT((SNGL(DSH)+Q2S(1)+Q2S(2))**2+8.*Q2S(1)*Q2S(2)*   
9188      &  ZS(JT)/(1.-ZS(JT))))    
9189         TEVB=LOG(PARP(63)*Q2B/ALAM(JT)**2)  
9190       ELSE  
9191         Q2B=Q2S(JT) 
9192         TEVB=TEVS(JT)   
9193       ENDIF 
9194       ALSDUM=ULALPS(PARP(63)*Q2B)   
9195       TEVB=TEVB+2.*LOG(ALAM(JT)/PARU(117))  
9196       TEVBSV=TEVB   
9197       ALAM(JT)=PARU(117)    
9198       B0=(33.-2.*MSTU(118))/6.  
9199     
9200 C...Calculate Altarelli-Parisi and structure function weights.  

9201       DO 140 KFL=-6,6   
9202       WTAP(KFL)=0.  
9203   140 WTSF(KFL)=0.  
9204       IF(KFLB.EQ.21) THEN   
9205         WTAPQ=16.*(1.-SQRT(XB+XE))/(3.*SQRT(XB))    
9206         DO 150 KFL=-MSTP(54),MSTP(54)   
9207         IF(KFL.EQ.0) WTAP(KFL)=6.*LOG((1.-XB)/XE)   
9208   150   IF(KFL.NE.0) WTAP(KFL)=WTAPQ    
9209       ELSE  
9210         WTAP(0)=0.5*XB*(1./(XB+XE)-1.)  
9211         WTAP(KFLB)=8.*LOG((1.-XB)*(XB+XE)/XE)/3.    
9212       ENDIF 
9213   160 WTSUM=0.  
9214       IF(KFLB.NE.21) XFBO=XFB(KFLB) 
9215       IF(KFLB.EQ.21) XFBO=XFB(0)
9216 C***************************************************************

9217 C**********ERROR HAS OCCURED HERE

9218       IF(XFBO.EQ.0.0) THEN
9219                 WRITE(MSTU(11),1000)
9220                 WRITE(MSTU(11),1001) KFLB,XFB(KFLB)
9221                 XFBO=0.00001
9222       ENDIF
9223 C****************************************************************    

9224       DO 170 KFL=-MSTP(54),MSTP(54) 
9225       WTSF(KFL)=XFB(KFL)/XFBO   
9226   170 WTSUM=WTSUM+WTAP(KFL)*WTSF(KFL)   
9227       WTSUM=MAX(0.0001,WTSUM)   
9228     
9229 C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).  

9230   180 IF(MSTP(64).LE.0) THEN    
9231         TEVB=TEVB+LOG(RLU(0))*PARU(2)/(PARU(111)*WTSUM) 
9232       ELSEIF(MSTP(64).EQ.1) THEN    
9233         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/WTSUM))  
9234       ELSE  
9235         TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/(5.*WTSUM))) 
9236       ENDIF 
9237   190 Q2REF=ALAM(JT)**2*EXP(TEVB)   
9238       Q2B=Q2REF/PARP(63)    
9239     
9240 C...Evolution ended or select flavour for branching parton. 

9241       IF(Q2B.LT.PARP(62)**2) THEN   
9242         Q2B=0.  
9243       ELSE  
9244         WTRAN=RLU(0)*WTSUM  
9245         KFLA=-MSTP(54)-1    
9246   200   KFLA=KFLA+1 
9247         WTRAN=WTRAN-WTAP(KFLA)*WTSF(KFLA)   
9248         IF(KFLA.LT.MSTP(54).AND.WTRAN.GT.0.) GOTO 200   
9249         IF(KFLA.EQ.0) KFLA=21   
9250     
9251 C...Choose z value and corrective weight.   

9252         IF(KFLB.EQ.21.AND.KFLA.EQ.21) THEN  
9253           Z=1./(1.+((1.-XB)/XB)*(XE/(1.-XB))**RLU(0))   
9254           WTZ=(1.-Z*(1.-Z))**2  
9255         ELSEIF(KFLB.EQ.21) THEN 
9256           Z=XB/(1.-RLU(0)*(1.-SQRT(XB+XE)))**2  
9257           WTZ=0.5*(1.+(1.-Z)**2)*SQRT(Z)    
9258         ELSEIF(KFLA.EQ.21) THEN 
9259           Z=XB*(1.+RLU(0)*(1./(XB+XE)-1.))  
9260           WTZ=1.-2.*Z*(1.-Z)    
9261         ELSE    
9262           Z=1.-(1.-XB)*(XE/((XB+XE)*(1.-XB)))**RLU(0)   
9263           WTZ=0.5*(1.+Z**2) 
9264         ENDIF   
9265     
9266 C...Option with resummation of soft gluon emission as effective z shift.    

9267         IF(MSTP(65).GE.1) THEN  
9268           RSOFT=6.  
9269           IF(KFLB.NE.21) RSOFT=8./3.    
9270           Z=Z*(TEVB/TEVS(JT))**(RSOFT*XE/((XB+XE)*B0))  
9271           IF(Z.LE.XB) GOTO 180  
9272         ENDIF   
9273     
9274 C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.   

9275         IF(MSTP(64).GE.2) THEN  
9276           IF((1.-Z)*Q2B.LT.PARP(62)**2) GOTO 180    
9277           ALPRAT=TEVB/(TEVB+LOG(1.-Z))  
9278           IF(ALPRAT.LT.5.*RLU(0)) GOTO 180  
9279           IF(ALPRAT.GT.5.) WTZ=WTZ*ALPRAT/5.    
9280         ENDIF   
9281     
9282 C...Option with angular ordering requirement.   

9283         IF(MSTP(62).GE.3) THEN  
9284           THE2T=(4.*Z**2*Q2B)/(VINT(2)*(1.-Z)*XB**2)    
9285           IF(THE2T.GT.THE2(JT)) GOTO 180    
9286         ENDIF   
9287     
9288 C...Weighting with new structure functions. 

9289         CALL PYSTFU(MINT(10+JT),XB,Q2REF,XFN,JT)   
9290         IF(KFLB.NE.21) XFBN=XFN(KFLB)   
9291         IF(KFLB.EQ.21) XFBN=XFN(0)  
9292         IF(XFBN.LT.1E-20) THEN  
9293           IF(KFLA.EQ.KFLB) THEN 
9294             TEVB=TEVBSV 
9295             WTAP(KFLB)=0.   
9296             GOTO 160    
9297           ELSEIF(TEVBSV-TEVB.GT.0.2) THEN   
9298             TEVB=0.5*(TEVBSV+TEVB)  
9299             GOTO 190    
9300           ELSE  
9301             XFBN=1E-10  
9302           ENDIF 
9303         ENDIF   
9304         DO 210 KFL=-MSTP(54),MSTP(54)   
9305   210   XFB(KFL)=XFN(KFL)   
9306         XA=XB/Z 
9307         CALL PYSTFU(MINT(10+JT),XA,Q2REF,XFA,JT)   
9308         IF(KFLA.NE.21) XFAN=XFA(KFLA)   
9309         IF(KFLA.EQ.21) XFAN=XFA(0)  
9310         IF(XFAN.LT.1E-20) GOTO 160  
9311         IF(KFLA.NE.21) WTSFA=WTSF(KFLA) 
9312         IF(KFLA.EQ.21) WTSFA=WTSF(0)    
9313         IF(WTZ*XFAN/XFBN.LT.RLU(0)*WTSFA) GOTO 160  
9314       ENDIF 
9315     
9316 C...Define two hard scatterers in their CM-frame.   

9317   220 IF(N.EQ.NS+2) THEN    
9318         DQ2(JT)=dble(Q2B)
9319         DPLCM=DSQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR   
9320         DO 240 JR=1,2   
9321         I=NS+JR 
9322         IF(JR.EQ.1) IPO=IPUS1   
9323         IF(JR.EQ.2) IPO=IPUS2   
9324         DO 230 J=1,5    
9325         K(I,J)=0    
9326         P(I,J)=0.   
9327   230   V(I,J)=0.   
9328         K(I,1)=14   
9329         K(I,2)=KFLS(JR+2)   
9330         K(I,4)=IPO  
9331         K(I,5)=IPO  
9332         P(I,3)=sngl(DPLCM)*(-1)**(JR+1)   
9333         P(I,4)=sngl((DSH+DQ2(3-JR)-DQ2(JR))/DSHR)
9334         P(I,5)=-SQRT(SNGL(DQ2(JR))) 
9335         K(IPO,1)=14 
9336         K(IPO,3)=I  
9337         K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I    
9338   240   K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I    
9339     
9340 C...Find maximum allowed mass of timelike parton.   

9341       ELSEIF(N.GT.NS+2) THEN    
9342         JR=3-JT 
9343         DQ2(3)=dble(Q2B)
9344         DPC(1)=dble(P(IS(1),4))
9345         DPC(2)=dble(P(IS(2),4))
9346         DPC(3)=dble(0.5*(ABS(P(IS(1),3))+ABS(P(IS(2),3))))
9347         DPD(1)=DSH+DQ2(JR)+DQ2(JT)  
9348         DPD(2)=DSHZ+DQ2(JR)+DQ2(3)  
9349         DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))  
9350         DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))   
9351         IKIN=0  
9352         IF(Q2S(JR).GE.(0.5*PARP(62))**2.AND.DPD(1)-DPD(3).GE.   
9353      &  1D-10*DPD(1)) IKIN=1    
9354         IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/DBLE(ZS(JT))-DQ2(3))*(DSH/ 
9355      &  (DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))    
9356         IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/(2.d0*  
9357      &  DQ2(JR))-DQ2(JT)-DQ2(3) 
9358     
9359 C...Generate timelike parton shower (if required).  

9360         IT=N    
9361         DO 250 J=1,5    
9362         K(IT,J)=0   
9363         P(IT,J)=0.  
9364   250   V(IT,J)=0.  
9365         K(IT,1)=3   
9366         K(IT,2)=21  
9367         IF(KFLB.EQ.21.AND.KFLS(JT+2).NE.21) K(IT,2)=-KFLS(JT+2) 
9368         IF(KFLB.NE.21.AND.KFLS(JT+2).EQ.21) K(IT,2)=KFLB    
9369         P(IT,5)=ULMASS(K(IT,2)) 
9370         IF(SNGL(DMSMA).LE.P(IT,5)**2) GOTO 100  
9371         IF(MSTP(63).GE.1) THEN  
9372           P(IT,4)=sngl((DSHZ-DSH-dble(P(IT,5))**2)/DSHR)
9373           P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)   
9374           IF(MSTP(63).EQ.1) THEN    
9375             Q2TIM=sngl(DMSMA)
9376           ELSEIF(MSTP(63).EQ.2) THEN    
9377             Q2TIM=MIN(SNGL(DMSMA),PARP(71)*Q2S(JT)) 
9378           ELSE  
9379 C'''Here remains to introduce angular ordering in first branching.  

9380             Q2TIM=sngl(DMSMA)
9381           ENDIF 
9382           CALL LUSHOW(IT,0,SQRT(Q2TIM)) 
9383           IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)   
9384         ENDIF   
9385     
9386 C...Reconstruct kinematics of branching: timelike parton shower.    

9387         DMS=dble(P(IT,5)**2)
9388         IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))  
9389         IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5d0*DPD(1)*DPD(2)
9390      &       +0.5d0*DPD(3)*
9391      &  DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.d0*DSH*DPC(3)**2) 
9392         IF(DPT2.LT.0.d0) GOTO 100 
9393         DPB(1)=(0.5d0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/  
9394      &  DSHR)/DPC(3)-DPC(3) 
9395         P(IT,1)=SQRT(SNGL(DPT2))    
9396         P(IT,3)=sngl(DPB(1))*(-1)**(JT+1) 
9397         P(IT,4)=sngl((DSHZ-DSH-DMS)/DSHR)
9398         IF(N.GE.IT+1) THEN  
9399           DPB(1)=SQRT(DPB(1)**2+DPT2)   
9400           DPB(2)=SQRT(DPB(1)**2+DMS)    
9401           DPB(3)=dble(P(IT+1,3))
9402           DPB(4)=SQRT(DPB(3)**2+DMS)    
9403           DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)* 
9404      &    DPB(1))   
9405           CALL LUDBRB(IT+1,N,0.,0.,0D0,0D0,DBEZ)    
9406           THE=ULANGL(P(IT,3),P(IT,1))   
9407           CALL LUDBRB(IT+1,N,THE,0.,0D0,0D0,0D0)    
9408         ENDIF   
9409     
9410 C...Reconstruct kinematics of branching: spacelike parton.  

9411         DO 260 J=1,5    
9412         K(N+1,J)=0  
9413         P(N+1,J)=0. 
9414   260   V(N+1,J)=0. 
9415         K(N+1,1)=14 
9416         K(N+1,2)=KFLB   
9417         P(N+1,1)=P(IT,1)    
9418         P(N+1,3)=P(IT,3)+P(IS(JT),3)    
9419         P(N+1,4)=P(IT,4)+P(IS(JT),4)    
9420         P(N+1,5)=-SQRT(SNGL(DQ2(3)))    
9421     
9422 C...Define colour flow of branching.    

9423         K(IS(JT),3)=N+1 
9424         K(IT,3)=N+1 
9425         ID1=IT  
9426         IF((K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(ID1,2).GT.0.AND. 
9427      &  K(ID1,2).NE.21).OR.(K(N+1,2).LT.0.AND.K(ID1,2).EQ.21).OR.   
9428      &  (K(N+1,2).EQ.21.AND.K(ID1,2).EQ.21.AND.RLU(0).GT.0.5).OR.   
9429      &  (K(N+1,2).EQ.21.AND.K(ID1,2).LT.0)) ID1=IS(JT)  
9430         ID2=IT+IS(JT)-ID1   
9431         K(N+1,4)=K(N+1,4)+ID1   
9432         K(N+1,5)=K(N+1,5)+ID2   
9433         K(ID1,4)=K(ID1,4)+MSTU(5)*(N+1) 
9434         K(ID1,5)=K(ID1,5)+MSTU(5)*ID2   
9435         K(ID2,4)=K(ID2,4)+MSTU(5)*ID1   
9436         K(ID2,5)=K(ID2,5)+MSTU(5)*(N+1) 
9437         N=N+1   
9438     
9439 C...Boost to new CM-frame.  

9440         CALL LUDBRB(NS+1,N,0.,0.,-DBLE((P(N,1)+P(IS(JR),1))/(P(N,4)+    
9441      &  P(IS(JR),4))),0D0,-DBLE((P(N,3)+P(IS(JR),3))/(P(N,4)+   
9442      &  P(IS(JR),4))))  
9443         IR=N+(JT-1)*(IS(1)-N)   
9444         CALL LUDBRB(NS+1,N,-ULANGL(P(IR,3),P(IR,1)),PARU(2)*RLU(0), 
9445      &  0D0,0D0,0D0)    
9446       ENDIF 
9447     
9448 C...Save quantities, loop back. 

9449       IS(JT)=N  
9450       Q2S(JT)=Q2B   
9451       DQ2(JT)=dble(Q2B)
9452       IF(MSTP(62).GE.3) THE2(JT)=THE2T  
9453       DSH=DSHZ  
9454       IF(Q2B.GE.(0.5*PARP(62))**2) THEN 
9455         KFLS(JT+2)=KFLS(JT) 
9456         KFLS(JT)=KFLA   
9457         XS(JT)=XA   
9458         ZS(JT)=Z    
9459         DO 270 KFL=-6,6 
9460   270   XFS(JT,KFL)=XFA(KFL)    
9461         TEVS(JT)=TEVB   
9462       ELSE  
9463         IF(JT.EQ.1) IPU1=N  
9464         IF(JT.EQ.2) IPU2=N  
9465       ENDIF 
9466       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN 
9467         CALL LUERRM(11,'(PYSSPA:) no more memory left in LUJETS')   
9468         IF(MSTU(21).GE.1) N=NS  
9469         IF(MSTU(21).GE.1) RETURN    
9470       ENDIF 
9471       IF(MAX(Q2S(1),Q2S(2)).GE.(0.5*PARP(62))**2.OR.N.LE.NS+1) GOTO 120 
9472     
9473 C...Boost hard scattering partons to frame of shower initiators.    

9474       DO 280 J=1,3  
9475   280 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4)) 
9476       DO 290 J=1,5  
9477   290 P(N+2,J)=P(NS+1,J)    
9478       ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2    
9479       IF(ROBOT.GE.0.999999) THEN    
9480         ROBOT=1.00001*SQRT(ROBOT)   
9481         ROBO(3)=ROBO(3)/ROBOT   
9482         ROBO(4)=ROBO(4)/ROBOT   
9483         ROBO(5)=ROBO(5)/ROBOT   
9484       ENDIF 
9485       CALL LUDBRB(N+2,N+2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),  
9486      &-DBLE(ROBO(5)))   
9487       ROBO(2)=ULANGL(P(N+2,1),P(N+2,2)) 
9488       ROBO(1)=ULANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))    
9489       CALL LUDBRB(MINT(83)+5,NS,ROBO(1),ROBO(2),DBLE(ROBO(3)),  
9490      &DBLE(ROBO(4)),DBLE(ROBO(5)))  
9491     
9492 C...Store user information. Reset Lambda value. 

9493       K(IPU1,3)=MINT(83)+3  
9494       K(IPU2,3)=MINT(83)+4  
9495       DO 300 JT=1,2 
9496       MINT(12+JT)=KFLS(JT)  
9497   300 VINT(140+JT)=XS(JT)   
9498       PARU(111)=ALAMS   
9499  1000 FORMAT(5X,'structure function has a zero point here')
9500  1001 FORMAT(5X,'xf(x,i=',I5,')=',F10.5)
9501 
9502       RETURN    
9503       END   
9504     
9505 C*********************************************************************  

9506     
9507       SUBROUTINE PYMULT(MMUL)   
9508     
9509 C...Initializes treatment of multiple interactions, selects kinematics  

9510 C...of hardest interaction if low-pT physics included in run, and   

9511 C...generates all non-hardest interactions. 

9512       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9513       SAVE /LUJETS/ 
9514       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
9515       SAVE /LUDAT1/ 
9516       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
9517       SAVE /LUDAT2/ 
9518       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
9519       SAVE /PYSUBS/ 
9520       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
9521       SAVE /PYPARS/ 
9522       COMMON/PYINT1/MINT(400),VINT(400) 
9523       SAVE /PYINT1/ 
9524       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
9525       SAVE /PYINT2/ 
9526       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
9527       SAVE /PYINT3/ 
9528       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
9529       SAVE /PYINT5/ 
9530       DIMENSION NMUL(20),SIGM(20),KSTR(500,2)   
9531       SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM  
9532     
9533 C...Initialization of multiple interaction treatment.   

9534       IF(MMUL.EQ.1) THEN    
9535         IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(82)    
9536         ISUB=96 
9537         MINT(1)=96  
9538         VINT(63)=0. 
9539         VINT(64)=0. 
9540         VINT(143)=1.    
9541         VINT(144)=1.    
9542     
9543 C...Loop over phase space points: xT2 choice in 20 bins.    

9544   100   SIGSUM=0.   
9545         DO 120 IXT2=1,20    
9546         NMUL(IXT2)=MSTP(83) 
9547         SIGM(IXT2)=0.   
9548         DO 110 ITRY=1,MSTP(83)  
9549         RSCA=0.05*((21-IXT2)-RLU(0))    
9550         XT2=VINT(149)*(1.+VINT(149))/(VINT(149)+RSCA)-VINT(149) 
9551         XT2=MAX(0.01*VINT(149),XT2) 
9552         VINT(25)=XT2    
9553     
9554 C...Choose tau and y*. Calculate cos(theta-hat).    

9555         IF(RLU(0).LE.COEF(ISUB,1)) THEN 
9556           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)    
9557           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)    
9558         ELSE    
9559           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2) 
9560         ENDIF   
9561         VINT(21)=TAU    
9562         CALL PYKLIM(2)  
9563         RYST=RLU(0) 
9564         MYST=1  
9565         IF(RYST.GT.COEF(ISUB,7)) MYST=2 
9566         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3    
9567         CALL PYKMAP(2,MYST,RLU(0))  
9568         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0)) 
9569     
9570 C...Calculate differential cross-section.   

9571         VINT(71)=0.5*VINT(1)*SQRT(XT2)  
9572         CALL PYSIGH(NCHN,SIGS)  
9573   110   SIGM(IXT2)=SIGM(IXT2)+SIGS  
9574   120   SIGSUM=SIGSUM+SIGM(IXT2)    
9575         SIGSUM=SIGSUM/(20.*MSTP(83))    
9576     
9577 C...Reject result if sigma(parton-parton) is smaller than hadronic one. 

9578         IF(SIGSUM.LT.1.1*VINT(106)) THEN    
9579           IF(MSTP(122).GE.1) WRITE(MSTU(11),1100) PARP(82),SIGSUM   
9580           PARP(82)=0.9*PARP(82) 
9581           VINT(149)=4.*PARP(82)**2/VINT(2)  
9582           GOTO 100  
9583         ENDIF   
9584         IF(MSTP(122).GE.1) WRITE(MSTU(11),1200) PARP(82), SIGSUM    
9585     
9586 C...Start iteration to find k factor.   

9587         YKE=SIGSUM/VINT(106)    
9588         SO=0.5  
9589         XI=0.   
9590         YI=0.   
9591         XK=0.5  
9592         XF=1.
9593         YF=1.
9594         IIT=0   
9595   130   IF(IIT.EQ.0) THEN   
9596           XK=2.*XK  
9597         ELSEIF(IIT.EQ.1) THEN   
9598           XK=0.5*XK 
9599         ELSE    
9600           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)    
9601         ENDIF   
9602     
9603 C...Evaluate overlap integrals.

9604         IF(MSTP(82).EQ.2) THEN  
9605           SP=0.5*PARU(1)*(1.-EXP(-XK))  
9606           SOP=SP/PARU(1)    
9607         ELSE    
9608 cms.. removing to avoid comp warning

9609 cc .. IF(MSTP(82).EQ.3) DELTAB=0.02 

9610           DELTAB=0.02
9611           IF(MSTP(82).EQ.4) DELTAB=MIN(0.01,0.05*PARP(84))  
9612           SP=0. 
9613           SOP=0.    
9614           B=-0.5*DELTAB 
9615   140     B=B+DELTAB    
9616           IF(MSTP(82).EQ.3) THEN    
9617             OV=EXP(-B**2)/PARU(2)   
9618           ELSE  
9619             CQ2=PARP(84)**2 
9620             OV=((1.-PARP(83))**2*EXP(-MIN(100.,B**2))+2.*PARP(83)*  
9621      &      (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B**2*2./(1.+CQ2)))+ 
9622      &      PARP(83)**2/CQ2*EXP(-MIN(100.,B**2/CQ2)))/PARU(2)   
9623           ENDIF 
9624           PACC=1.-EXP(-MIN(100.,PARU(1)*XK*OV)) 
9625           SP=SP+PARU(2)*B*DELTAB*PACC   
9626           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC  
9627           IF(B.LT.1..OR.B*PACC.GT.1E-6) GOTO 140    
9628         ENDIF   
9629         YK=PARU(1)*XK*SO/SP 
9630     
9631 C...Continue iteration until convergence.   

9632         IF(YK.LT.YKE) THEN  
9633           XI=XK 
9634           YI=YK 
9635           IF(IIT.EQ.1) IIT=2    
9636         ELSE    
9637           XF=XK 
9638           YF=YK 
9639           IF(IIT.EQ.0) IIT=1    
9640         ENDIF   
9641         IF(ABS(YK-YKE).GE.1E-5*YKE) GOTO 130    
9642     
9643 C...Store some results for subsequent use.  

9644         VINT(145)=SIGSUM    
9645         VINT(146)=SOP/SO    
9646         VINT(147)=SOP/SP    
9647     
9648 C...Initialize iteration in xT2 for hardest interaction.    

9649       ELSEIF(MMUL.EQ.2) THEN    
9650         IF(MSTP(82).LE.0) THEN  
9651         ELSEIF(MSTP(82).EQ.1) THEN  
9652           XT2=1.    
9653           XT2FAC=XSEC(96,1)/VINT(106)*VINT(149)/(1.-VINT(149))  
9654         ELSEIF(MSTP(82).EQ.2) THEN  
9655           XT2=1.    
9656           XT2FAC=VINT(146)*XSEC(96,1)/VINT(106)*VINT(149)*(1.+VINT(149))    
9657         ELSE    
9658           XC2=4.*CKIN(3)**2/VINT(2) 
9659           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0.    
9660         ENDIF   
9661     
9662       ELSEIF(MMUL.EQ.3) THEN    
9663 C...Low-pT or multiple interactions (first semihard interaction):   

9664 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)    

9665 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).   

9666         ISUB=MINT(1)    
9667         IF(MSTP(82).LE.0) THEN  
9668           XT2=0.    
9669         ELSEIF(MSTP(82).EQ.1) THEN  
9670           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))   
9671         ELSEIF(MSTP(82).EQ.2) THEN  
9672           IF(XT2.LT.1..AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+ 
9673      &    VINT(149)))).GT.RLU(0)) XT2=1.    
9674           IF(XT2.GE.1.) THEN    
9675             XT2=(1.+VINT(149))*XT2FAC/(XT2FAC-(1.+VINT(149))*LOG(1.-    
9676      &      RLU(0)*(1.-EXP(-XT2FAC/(VINT(149)*(1.+VINT(149)))))))-  
9677      &      VINT(149)   
9678           ELSE  
9679             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+RLU(0)*    
9680      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))- 
9681      &      VINT(149)   
9682           ENDIF 
9683           XT2=MAX(0.01*VINT(149),XT2)   
9684         ELSE    
9685           XT2=(XC2+VINT(149))*(1.+VINT(149))/(1.+VINT(149)- 
9686      &    RLU(0)*(1.-XC2))-VINT(149)    
9687           XT2=MAX(0.01*VINT(149),XT2)   
9688         ENDIF   
9689         VINT(25)=XT2    
9690     
9691 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.   

9692         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN 
9693           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1   
9694           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1 
9695           ISUB=95   
9696           MINT(1)=ISUB  
9697           VINT(21)=0.01*VINT(149)   
9698           VINT(22)=0.   
9699           VINT(23)=0.   
9700           VINT(25)=0.01*VINT(149)   
9701     
9702         ELSE    
9703 C...Multiple interactions (first semihard interaction). 

9704 C...Choose tau and y*. Calculate cos(theta-hat).    

9705           IF(RLU(0).LE.COEF(ISUB,1)) THEN   
9706             TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)  
9707             TAU=XT2*(1.+TAUP)**2/(4.*TAUP)  
9708           ELSE  
9709             TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)   
9710           ENDIF 
9711           VINT(21)=TAU  
9712           CALL PYKLIM(2)    
9713           RYST=RLU(0)   
9714           MYST=1    
9715           IF(RYST.GT.COEF(ISUB,7)) MYST=2   
9716           IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3  
9717           CALL PYKMAP(2,MYST,RLU(0))    
9718           VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))   
9719         ENDIF   
9720         VINT(71)=0.5*VINT(1)*SQRT(VINT(25)) 
9721     
9722 C...Store results of cross-section calculation. 

9723       ELSEIF(MMUL.EQ.4) THEN    
9724         ISUB=MINT(1)    
9725         XTS=VINT(25)    
9726         IF(ISET(ISUB).EQ.1) XTS=VINT(21)    
9727         IF(ISET(ISUB).EQ.2) XTS=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/  
9728      &  VINT(2) 
9729         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XTS=VINT(26) 
9730         RBIN=MAX(0.000001,MIN(0.999999,XTS*(1.+VINT(149))/  
9731      &  (XTS+VINT(149))))   
9732         IRBIN=INT(1.+20.*RBIN)  
9733         IF(ISUB.EQ.96) NMUL(IRBIN)=NMUL(IRBIN)+1    
9734         IF(ISUB.EQ.96) SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)    
9735     
9736 C...Choose impact parameter.    

9737       ELSEIF(MMUL.EQ.5) THEN    
9738         IF(MSTP(82).EQ.3) THEN  
9739           VINT(148)=RLU(0)/(PARU(2)*VINT(147))  
9740         ELSE    
9741           RTYPE=RLU(0)  
9742           CQ2=PARP(84)**2   
9743           IF(RTYPE.LT.(1.-PARP(83))**2) THEN    
9744             B2=-LOG(RLU(0)) 
9745           ELSEIF(RTYPE.LT.1.-PARP(83)**2) THEN  
9746             B2=-0.5*(1.+CQ2)*LOG(RLU(0))    
9747           ELSE  
9748             B2=-CQ2*LOG(RLU(0)) 
9749           ENDIF 
9750           VINT(148)=((1.-PARP(83))**2*EXP(-MIN(100.,B2))+2.*PARP(83)*   
9751      &    (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B2*2./(1.+CQ2)))+ 
9752      &    PARP(83)**2/CQ2*EXP(-MIN(100.,B2/CQ2)))/(PARU(2)*VINT(147))   
9753         ENDIF   
9754     
9755 C...Multiple interactions (variable impact parameter) : reject with 

9756 C...probability exp(-overlap*cross-section above pT/normalization). 

9757         RNCOR=(IRBIN-20.*RBIN)*NMUL(IRBIN)  
9758         SIGCOR=(IRBIN-20.*RBIN)*SIGM(IRBIN) 
9759         DO 150 IBIN=IRBIN+1,20  
9760         RNCOR=RNCOR+NMUL(IBIN)  
9761   150   SIGCOR=SIGCOR+SIGM(IBIN)    
9762         SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1.-XTS)/(XTS+VINT(149))    
9763         VINT(150)=EXP(-MIN(100.,VINT(146)*VINT(148)*SIGABV/VINT(106)))  
9764     
9765 C...Generate additional multiple semihard interactions. 

9766       ELSEIF(MMUL.EQ.6) THEN    
9767     
9768 C...Reconstruct strings in hard scattering. 

9769         ISUB=MINT(1)    
9770         NMAX=MINT(84)+4 
9771         IF(ISET(ISUB).EQ.1) NMAX=MINT(84)+2 
9772         NSTR=0  
9773         DO 170 I=MINT(84)+1,NMAX    
9774         KCS=KCHG(LUCOMP(K(I,2)),2)*ISIGN(1,K(I,2))  
9775         IF(KCS.EQ.0) GOTO 170   
9776         DO 160 J=1,4    
9777         IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 160    
9778         IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 160   
9779         IF(J.LE.2) THEN 
9780           IST=MOD(K(I,J+3)/MSTU(5),MSTU(5)) 
9781         ELSE    
9782           IST=MOD(K(I,J+1),MSTU(5)) 
9783         ENDIF   
9784         IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 160    
9785         IF(KCHG(LUCOMP(K(IST,2)),2).EQ.0) GOTO 160  
9786         NSTR=NSTR+1 
9787         IF(J.EQ.1.OR.J.EQ.4) THEN   
9788           KSTR(NSTR,1)=I    
9789           KSTR(NSTR,2)=IST  
9790         ELSE    
9791           KSTR(NSTR,1)=IST  
9792           KSTR(NSTR,2)=I    
9793         ENDIF   
9794   160   CONTINUE    
9795   170   CONTINUE    
9796     
9797 C...Set up starting values for iteration in xT2.    

9798         XT2=VINT(25)    
9799         IF(ISET(ISUB).EQ.1) XT2=VINT(21)    
9800         IF(ISET(ISUB).EQ.2) XT2=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/  
9801      &  VINT(2) 
9802         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XT2=VINT(26) 
9803         ISUB=96 
9804         MINT(1)=96  
9805         IF(MSTP(82).LE.1) THEN  
9806           XT2FAC=XSEC(ISUB,1)*VINT(149)/((1.-VINT(149))*VINT(106))  
9807         ELSE    
9808           XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/VINT(106)*    
9809      &    VINT(149)*(1.+VINT(149))  
9810         ENDIF   
9811         VINT(63)=0. 
9812         VINT(64)=0. 
9813         VINT(151)=0.    
9814         VINT(152)=0.    
9815         VINT(143)=1.-VINT(141)  
9816         VINT(144)=1.-VINT(142)  
9817     
9818 C...Iterate downwards in xT2.   

9819   180   IF(MSTP(82).LE.1) THEN  
9820           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))   
9821           IF(XT2.LT.VINT(149)) GOTO 220 
9822         ELSE    
9823           IF(XT2.LE.0.01*VINT(149)) GOTO 220    
9824           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*   
9825      &    LOG(RLU(0)))-VINT(149)    
9826           IF(XT2.LE.0.) GOTO 220    
9827           XT2=MAX(0.01*VINT(149),XT2)   
9828         ENDIF   
9829         VINT(25)=XT2    
9830     
9831 C...Choose tau and y*. Calculate cos(theta-hat).    

9832         IF(RLU(0).LE.COEF(ISUB,1)) THEN 
9833           TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)    
9834           TAU=XT2*(1.+TAUP)**2/(4.*TAUP)    
9835         ELSE    
9836           TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2) 
9837         ENDIF   
9838         VINT(21)=TAU    
9839         CALL PYKLIM(2)  
9840         RYST=RLU(0) 
9841         MYST=1  
9842         IF(RYST.GT.COEF(ISUB,7)) MYST=2 
9843         IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3    
9844         CALL PYKMAP(2,MYST,RLU(0))  
9845         VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0)) 
9846     
9847 C...Check that x not used up. Accept or reject kinematical variables.   

9848         X1M=SQRT(TAU)*EXP(VINT(22)) 
9849         X2M=SQRT(TAU)*EXP(-VINT(22))    
9850         IF(VINT(143)-X1M.LT.0.01.OR.VINT(144)-X2M.LT.0.01) GOTO 180 
9851         VINT(71)=0.5*VINT(1)*SQRT(XT2)  
9852         CALL PYSIGH(NCHN,SIGS)  
9853         IF(SIGS.LT.XSEC(ISUB,1)*RLU(0)) GOTO 180    
9854     
9855 C...Reset K, P and V vectors. Select some variables.    

9856         DO 190 I=N+1,N+2    
9857         DO 190 J=1,5    
9858         K(I,J)=0    
9859         P(I,J)=0.   
9860   190   V(I,J)=0.   
9861         RFLAV=RLU(0)    
9862         PT=0.5*VINT(1)*SQRT(XT2)    
9863         PHI=PARU(2)*RLU(0)  
9864         CTH=VINT(23)    
9865     
9866 C...Add first parton to event record.   

9867         K(N+1,1)=3  
9868         K(N+1,2)=21 
9869         IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=   
9870      &  1+INT((2.+PARJ(2))*RLU(0))  
9871         P(N+1,1)=PT*COS(PHI)    
9872         P(N+1,2)=PT*SIN(PHI)    
9873         P(N+1,3)=0.25*VINT(1)*(VINT(41)*(1.+CTH)-VINT(42)*(1.-CTH)) 
9874         P(N+1,4)=0.25*VINT(1)*(VINT(41)*(1.+CTH)+VINT(42)*(1.-CTH)) 
9875         P(N+1,5)=0. 
9876     
9877 C...Add second parton to event record.  

9878         K(N+2,1)=3  
9879         K(N+2,2)=21 
9880         IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)   
9881         P(N+2,1)=-P(N+1,1)  
9882         P(N+2,2)=-P(N+1,2)  
9883         P(N+2,3)=0.25*VINT(1)*(VINT(41)*(1.-CTH)-VINT(42)*(1.+CTH)) 
9884         P(N+2,4)=0.25*VINT(1)*(VINT(41)*(1.-CTH)+VINT(42)*(1.+CTH)) 
9885         P(N+2,5)=0. 
9886     
9887         IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN    
9888 C....Choose relevant string pieces to place gluons on.  

9889           IST1=0
9890           IST2=0
9891           ISTM=0
9892           DO 210 I=N+1,N+2  
9893           DMIN=1E8  
9894           DO 200 ISTR=1,NSTR    
9895           I1=KSTR(ISTR,1)   
9896           I2=KSTR(ISTR,2)   
9897           DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-   
9898      &    P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-   
9899      &    P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1.,P(I1,4)*P(I2,4)-    
9900      &    P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))  
9901           IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN    
9902             DMIN=DIST   
9903             IST1=I1 
9904             IST2=I2 
9905             ISTM=ISTR   
9906           ENDIF 
9907   200     CONTINUE  
9908     
9909 C....Colour flow adjustments, new string pieces.    

9910           IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+    
9911      &    MOD(K(IST1,4),MSTU(5))    
9912           IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)= 
9913      &    MSTU(5)*(K(IST1,5)/MSTU(5))+I 
9914           K(I,5)=MSTU(5)*IST1   
9915           K(I,4)=MSTU(5)*IST2   
9916           IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+    
9917      &    MOD(K(IST2,5),MSTU(5))    
9918           IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)= 
9919      &    MSTU(5)*(K(IST2,4)/MSTU(5))+I 
9920           KSTR(ISTM,2)=I    
9921           KSTR(NSTR+1,1)=I  
9922           KSTR(NSTR+1,2)=IST2   
9923   210     NSTR=NSTR+1   
9924     
9925 C...String drawing and colour flow for gluon loop.  

9926         ELSEIF(K(N+1,2).EQ.21) THEN 
9927           K(N+1,4)=MSTU(5)*(N+2)    
9928           K(N+1,5)=MSTU(5)*(N+2)    
9929           K(N+2,4)=MSTU(5)*(N+1)    
9930           K(N+2,5)=MSTU(5)*(N+1)    
9931           KSTR(NSTR+1,1)=N+1    
9932           KSTR(NSTR+1,2)=N+2    
9933           KSTR(NSTR+2,1)=N+2    
9934           KSTR(NSTR+2,2)=N+1    
9935           NSTR=NSTR+2   
9936     
9937 C...String drawing and colour flow for q-qbar pair. 

9938         ELSE    
9939           K(N+1,4)=MSTU(5)*(N+2)    
9940           K(N+2,5)=MSTU(5)*(N+1)    
9941           KSTR(NSTR+1,1)=N+1    
9942           KSTR(NSTR+1,2)=N+2    
9943           NSTR=NSTR+1   
9944         ENDIF   
9945     
9946 C...Update remaining energy; iterate.   

9947         N=N+2   
9948         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN   
9949           CALL LUERRM(11,'(PYMULT:) no more memory left in LUJETS') 
9950           IF(MSTU(21).GE.1) RETURN  
9951         ENDIF   
9952         MINT(31)=MINT(31)+1 
9953         VINT(151)=VINT(151)+VINT(41)    
9954         VINT(152)=VINT(152)+VINT(42)    
9955         VINT(143)=VINT(143)-VINT(41)    
9956         VINT(144)=VINT(144)-VINT(42)    
9957         IF(MINT(31).LT.240) GOTO 180    
9958   220   CONTINUE    
9959       ENDIF 
9960     
9961 C...Format statements for printout. 

9962  1000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter', 
9963      &'actions for MSTP(82) =',I2,' ******')    
9964  1100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,    
9965      &E9.2,' mb: rejected') 
9966  1200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,    
9967      &E9.2,' mb: accepted') 
9968     
9969       RETURN    
9970       END   
9971     
9972 C*********************************************************************  

9973     
9974       SUBROUTINE PYREMN(IPU1,IPU2)  
9975     
9976 C...Adds on target remnants (one or two from each side) and 

9977 C...includes primordial kT. 

9978       COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
9979       SAVE /HPARNT/
9980       COMMON/HSTRNG/NFP(300,15),PPHI(300,15),NFT(300,15),PTHI(300,15)
9981       SAVE /HSTRNG/
9982 C...COMMON BLOCK FROM HIJING

9983       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
9984       SAVE /LUJETS/ 
9985       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
9986       SAVE /LUDAT1/ 
9987       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
9988       SAVE /LUDAT2/ 
9989       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
9990       SAVE /PYPARS/ 
9991       COMMON/PYINT1/MINT(400),VINT(400) 
9992       SAVE /PYINT1/ 
9993       DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)   
9994     
9995 C...Special case for lepton-lepton interaction. 

9996       IF(MINT(43).EQ.1) THEN    
9997         DO 100 JT=1,2   
9998         I=MINT(83)+JT+2 
9999         K(I,1)=21   
10000         K(I,2)=K(I-2,2) 
10001         K(I,3)=I-2  
10002         DO 100 J=1,5    
10003   100   P(I,J)=P(I-2,J) 
10004       ENDIF 
10005     
10006 C...Find event type, set pointers.  

10007 cms.. pre-initialize

10008       IQ=0
10009       IF(IPU1.EQ.0.AND.IPU2.EQ.0) RETURN    
10010       ISUB=MINT(1)  
10011       ILEP=0    
10012       IF(IPU1.EQ.0) ILEP=1  
10013       IF(IPU2.EQ.0) ILEP=2  
10014       IF(ISUB.EQ.95) ILEP=-1    
10015       IF(ILEP.EQ.1) IQ=MINT(84)+1   
10016       IF(ILEP.EQ.2) IQ=MINT(84)+2   
10017       IP=MAX(IPU1,IPU2) 
10018       ILEPR=MINT(83)+5-ILEP 
10019       NS=N  
10020     
10021 C...Define initial partons, including primordial kT.    

10022 cms.. pre-initialize

10023       SHS=0.
10024   110 DO 130 JT=1,2 
10025       I=MINT(83)+JT+2   
10026       IF(JT.EQ.1) IPU=IPU1  
10027       IF(JT.EQ.2) IPU=IPU2  
10028       K(I,1)=21 
10029       K(I,3)=I-2    
10030       IF(ISUB.EQ.95) THEN   
10031         K(I,2)=21   
10032         SHS=0.  
10033       ELSEIF(MINT(40+JT).EQ.1.AND.IPU.NE.0) THEN    
10034         K(I,2)=K(IPU,2) 
10035         P(I,5)=P(IPU,5) 
10036         P(I,1)=0.   
10037         P(I,2)=0.   
10038         PMS(JT)=P(I,5)**2   
10039       ELSEIF(IPU.NE.0) THEN 
10040         K(I,2)=K(IPU,2) 
10041         P(I,5)=P(IPU,5) 
10042 C...No primordial kT or chosen according to truncated Gaussian or   

10043 C...exponential.

10044 C

10045 c     X.N. Wang (7.22.97)

10046 c

10047         RPT1=0.0
10048         RPT2=0.0
10049         ssw2=(PPHI(IHNT2(11),4)+PTHI(IHNT2(12),4))**2
10050      &       -(PPHI(IHNT2(11),1)+PTHI(IHNT2(12),1))**2
10051      &       -(PPHI(IHNT2(11),2)+PTHI(IHNT2(12),2))**2
10052      &       -(PPHI(IHNT2(11),3)+PTHI(IHNT2(12),3))**2
10053 C

10054 C********this is s of the current NN collision

10055         IF(ssw2.LE.4.0*PARP(93)**2) GOTO 1211
10056 c

10057         IF(IHPR2(5).LE.0) THEN
10058 120             IF(MSTP(91).LE.0) THEN
10059                PT=0. 
10060              ELSEIF(MSTP(91).EQ.1) THEN
10061                PT=PARP(91)*SQRT(-LOG(RLU(0)))
10062              ELSE    
10063                RPT1=RLU(0)   
10064                RPT2=RLU(0)   
10065                PT=-PARP(92)*LOG(RPT1*RPT2)   
10066              ENDIF   
10067              IF(PT.GT.PARP(93)) GOTO 120 
10068              PHI=PARU(2)*RLU(0)  
10069              RPT1=PT*COS(PHI)  
10070              RPT2=PT*SIN(PHI)
10071         ELSE IF(IHPR2(5).EQ.1) THEN
10072              IF(JT.EQ.1) JPT=NFP(IHNT2(11),11)
10073              IF(JT.EQ.2) JPT=NFT(IHNT2(12),11)
10074 1205             PTGS=PARP(91)*SQRT(-LOG(RLU(0)))
10075              IF(PTGS.GT.PARP(93)) GO TO 1205
10076              PHI=2.0*HIPR1(40)*RLU(0)
10077              RPT1=PTGS*COS(PHI)
10078              RPT2=PTGS*SIN(PHI)
10079              DO 1210 iint=1,JPT-1
10080                 PKCSQ=PARP(91)*SQRT(-LOG(RLU(0)))
10081                 PHI=2.0*HIPR1(40)*RLU(0)
10082                 RPT1=RPT1+PKCSQ*COS(PHI)
10083                 RPT2=RPT2+PKCSQ*SIN(PHI)
10084 1210             CONTINUE
10085              IF(RPT1**2+RPT2**2.GE.ssw2/4.0) GO TO 1205
10086         ENDIF
10087 C     X.N. Wang

10088 C                     ********When initial interaction among soft partons is

10089 C                             assumed the primordial pt comes from the sum of

10090 C                             pt of JPT-1 number of initial interaction, JPT

10091 C                             is the number of interaction including present

10092 C                             one that nucleon hassuffered 

10093 1211    P(I,1)=RPT1
10094         P(I,2)=RPT2  
10095         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2   
10096       ELSE  
10097         K(I,2)=K(IQ,2)  
10098         Q2=VINT(52) 
10099         P(I,5)=-SQRT(Q2)    
10100         PMS(JT)=-Q2 
10101         SHS=(1.-VINT(43-JT))*Q2/VINT(43-JT)+VINT(5-JT)**2   
10102       ENDIF 
10103   130 CONTINUE  
10104     
10105 C...Kinematics construction for initial partons.    

10106       I1=MINT(83)+3 
10107       I2=MINT(83)+4 
10108       IF(ILEP.EQ.0) SHS=VINT(141)*VINT(142)*VINT(2)+    
10109      &(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2 
10110       SHR=SQRT(MAX(0.,SHS)) 
10111       IF(ILEP.EQ.0) THEN    
10112         IF((SHS-PMS(1)-PMS(2))**2-4.*PMS(1)*PMS(2).LE.0.) GOTO 110  
10113         P(I1,4)=0.5*(SHR+(PMS(1)-PMS(2))/SHR)   
10114         P(I1,3)=SQRT(MAX(0.,P(I1,4)**2-PMS(1))) 
10115         P(I2,4)=SHR-P(I1,4) 
10116         P(I2,3)=-P(I1,3)    
10117       ELSEIF(ILEP.EQ.1) THEN    
10118         P(I1,4)=P(IQ,4) 
10119         P(I1,3)=P(IQ,3) 
10120         P(I2,4)=P(IP,4) 
10121         P(I2,3)=P(IP,3) 
10122       ELSEIF(ILEP.EQ.2) THEN    
10123         P(I1,4)=P(IP,4) 
10124         P(I1,3)=P(IP,3) 
10125         P(I2,4)=P(IQ,4) 
10126         P(I2,3)=P(IQ,3) 
10127       ENDIF 
10128       IF(MINT(43).EQ.1) RETURN  
10129     
10130 C...Transform partons to overall CM-frame (not for leptoproduction).    

10131       IF(ILEP.EQ.0) THEN    
10132         ROBO(3)=(P(I1,1)+P(I2,1))/SHR   
10133         ROBO(4)=(P(I1,2)+P(I2,2))/SHR   
10134         CALL LUDBRB(I1,I2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),0D0)  
10135         ROBO(2)=ULANGL(P(I1,1),P(I1,2)) 
10136         CALL LUDBRB(I1,I2,0.,-ROBO(2),0D0,0D0,0D0)  
10137         ROBO(1)=ULANGL(P(I1,3),P(I1,1)) 
10138         CALL LUDBRB(I1,I2,-ROBO(1),0.,0D0,0D0,0D0)  
10139         NMAX=MAX(MINT(52),IPU1,IPU2)    
10140         CALL LUDBRB(I1,NMAX,ROBO(1),ROBO(2),DBLE(ROBO(3)),DBLE(ROBO(4)),    
10141      &  0D0)    
10142         ROBO(5)=MAX(-0.999999,MIN(0.999999,(VINT(141)-VINT(142))/   
10143      &  (VINT(141)+VINT(142)))) 
10144         CALL LUDBRB(I1,NMAX,0.,0.,0D0,0D0,DBLE(ROBO(5)))    
10145       ENDIF 
10146     
10147 C...Check invariant mass of remnant system: 

10148 C...hadronic events or leptoproduction. 

10149 cms.. pre-initialize to avoid compiler warning

10150       PEH=0.
10151       PZH=0.
10152       PEI=0.
10153       PZI=0.
10154       IF(ILEP.LE.0) THEN    
10155         IF(MSTP(81).LE.0.OR.MSTP(82).LE.0.OR.ISUB.EQ.95) THEN   
10156           VINT(151)=0.  
10157           VINT(152)=0.  
10158         ENDIF   
10159         PEH=P(I1,4)+P(I2,4)+0.5*VINT(1)*(VINT(151)+VINT(152))   
10160         PZH=P(I1,3)+P(I2,3)+0.5*VINT(1)*(VINT(151)-VINT(152))   
10161         SHH=(VINT(1)-PEH)**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+P(I2,2))**2- 
10162      &  PZH**2  
10163         PMMIN=P(MINT(83)+1,5)+P(MINT(83)+2,5)+ULMASS(K(I1,2))+  
10164      &  ULMASS(K(I2,2)) 
10165         IF(SHR.GE.VINT(1).OR.SHH.LE.(PMMIN+PARP(111))**2) THEN  
10166           MINT(51)=1    
10167           RETURN    
10168         ENDIF   
10169         SHR=SQRT(SHH+(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2) 
10170       ELSE  
10171         PEI=P(IQ,4)+P(IP,4) 
10172         PZI=P(IQ,3)+P(IP,3) 
10173         PMS(ILEP)=MAX(0.,PEI**2-PZI**2) 
10174         PMMIN=P(ILEPR-2,5)+ULMASS(K(ILEPR,2))+SQRT(PMS(ILEP))   
10175         IF(SHR.LE.PMMIN+PARP(111)) THEN 
10176           MINT(51)=1    
10177           RETURN    
10178         ENDIF   
10179       ENDIF 
10180     
10181 C...Subdivide remnant if necessary, store first parton. 

10182   140 I=NS  
10183       DO 190 JT=1,2 
10184       IF(JT.EQ.ILEP) GOTO 190   
10185       IF(JT.EQ.1) IPU=IPU1  
10186       IF(JT.EQ.2) IPU=IPU2  
10187       CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))  
10188       I=I+1 
10189       IS(JT)=I  
10190       DO 150 J=1,5  
10191       K(I,J)=0  
10192       P(I,J)=0. 
10193   150 V(I,J)=0. 
10194       K(I,1)=3  
10195       K(I,2)=KFLSP(JT)  
10196       K(I,3)=MINT(83)+JT    
10197       P(I,5)=ULMASS(K(I,2)) 
10198     
10199 C...First parton colour connections and transverse mass.    

10200       KFLS=(3-KCHG(LUCOMP(KFLSP(JT)),2)*ISIGN(1,KFLSP(JT)))/2   
10201       K(I,KFLS+3)=IPU   
10202       K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I    
10203       IF(KFLCH(JT).EQ.0) THEN   
10204         P(I,1)=-P(MINT(83)+JT+2,1)  
10205         P(I,2)=-P(MINT(83)+JT+2,2)  
10206         PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2   
10207     
10208 C...When extra remnant parton or hadron: find relative pT, store.   

10209       ELSE  
10210         CALL LUPTDI(1,P(I,1),P(I,2))    
10211         PMS(JT+2)=P(I,5)**2+P(I,1)**2+P(I,2)**2 
10212         I=I+1   
10213         DO 160 J=1,5    
10214         K(I,J)=0    
10215         P(I,J)=0.   
10216   160   V(I,J)=0.   
10217         K(I,1)=1    
10218         K(I,2)=KFLCH(JT)    
10219         K(I,3)=MINT(83)+JT  
10220         P(I,5)=ULMASS(K(I,2))   
10221         P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1) 
10222         P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2) 
10223         PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 
10224 C...Relative distribution of energy for particle into two jets. 

10225         IMB=1   
10226         IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2 
10227         IF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN   
10228           CHIK=PARP(92+2*IMB)   
10229           IF(MSTP(92).LE.1) THEN    
10230             IF(IMB.EQ.1) CHI(JT)=RLU(0) 
10231             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))    
10232           ELSEIF(MSTP(92).EQ.2) THEN    
10233             CHI(JT)=1.-RLU(0)**(1./(1.+CHIK))   
10234           ELSEIF(MSTP(92).EQ.3) THEN    
10235             CUT=2.*0.3/VINT(1)  
10236   170       CHI(JT)=RLU(0)**2   
10237             IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25*(1.-CHI(JT))**CHIK    
10238      &      .LT.RLU(0)) GOTO 170    
10239           ELSE  
10240             CUT=2.*0.3/VINT(1)  
10241             CUTR=(1.+SQRT(1.+CUT**2))/CUT   
10242   180       CHIR=CUT*CUTR**RLU(0)   
10243             CHI(JT)=(CHIR**2-CUT**2)/(2.*CHIR)  
10244             IF((1.-CHI(JT))**CHIK.LT.RLU(0)) GOTO 180   
10245           ENDIF 
10246 C...Relative distribution of energy for particle into jet plus particle.    

10247         ELSE    
10248           IF(MSTP(92).LE.1) THEN    
10249             IF(IMB.EQ.1) CHI(JT)=RLU(0) 
10250             IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))    
10251           ELSE  
10252             CHI(JT)=1.-RLU(0)**(1./(1.+PARP(93+2*IMB))) 
10253           ENDIF 
10254           IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1.-CHI(JT)    
10255         ENDIF   
10256         PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1.-CHI(JT))    
10257         KFLS=KCHG(LUCOMP(KFLCH(JT)),2)*ISIGN(1,KFLCH(JT))   
10258         IF(KFLS.NE.0) THEN  
10259           K(I,1)=3  
10260           KFLS=(3-KFLS)/2   
10261           K(I,KFLS+3)=IPU   
10262           K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I    
10263         ENDIF   
10264       ENDIF 
10265   190 CONTINUE  
10266       IF(SHR.LE.SQRT(PMS(1))+SQRT(PMS(2))) GOTO 140 
10267       N=I   
10268     
10269 C...Reconstruct kinematics of remnants.

10270 C...cms initialize variable

10271       PZ=0. 
10272       DO 200 JT=1,2 
10273       IF(JT.EQ.ILEP) GOTO 200   
10274       PE=0.5*(SHR+(PMS(JT)-PMS(3-JT))/SHR)  
10275       PZ=SQRT(PE**2-PMS(JT))    
10276       IF(KFLCH(JT).EQ.0) THEN   
10277         P(IS(JT),4)=PE  
10278         P(IS(JT),3)=PZ*(-1)**(JT-1) 
10279       ELSE  
10280         PW1=CHI(JT)*(PE+PZ) 
10281         P(IS(JT)+1,4)=0.5*(PW1+PMS(JT+4)/PW1)   
10282         P(IS(JT)+1,3)=0.5*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)  
10283         P(IS(JT),4)=PE-P(IS(JT)+1,4)    
10284         P(IS(JT),3)=PZ*(-1)**(JT-1)-P(IS(JT)+1,3)   
10285       ENDIF 
10286   200 CONTINUE  
10287     
10288 C...Hadronic events: boost remnants to correct longitudinal frame.  

10289       IF(ILEP.LE.0) THEN    
10290         CALL LUDBRB(NS+1,N,0.,0.,0D0,0D0,-DBLE(PZH/(VINT(1)-PEH)))  
10291 C...Leptoproduction events: boost colliding subsystem.  

10292       ELSE  
10293         NMAX=MAX(IP,MINT(52))   
10294         PEF=SHR-PE  
10295         PZF=PZ*(-1)**(ILEP-1)   
10296         PT2=P(ILEPR,1)**2+P(ILEPR,2)**2 
10297         PHIPT=ULANGL(P(ILEPR,1),P(ILEPR,2)) 
10298         CALL LUDBRB(MINT(84)+1,NMAX,0.,-PHIPT,0D0,0D0,0D0)  
10299         RQP=P(IQ,3)*(PT2+PEI**2)-P(IQ,4)*PEI*PZI    
10300         SINTH=P(IQ,4)*SQRT(PT2*(PT2+PEI**2)/(RQP**2+PT2*    
10301      &  P(IQ,4)**2*PZI**2))*SIGN(1.,-RQP)   
10302         CALL LUDBRB(MINT(84)+1,NMAX,ASIN(SINTH),0.,0D0,0D0,0D0) 
10303         BETAX=(-PEI*PZI*SINTH+SQRT(PT2*(PT2+PEI**2-(PZI*SINTH)**2)))/   
10304      &  (PT2+PEI**2)    
10305         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,DBLE(BETAX),0D0,0D0)  
10306         CALL LUDBRB(MINT(84)+1,NMAX,0.,PHIPT,0D0,0D0,0D0)   
10307         PEM=P(IQ,4)+P(IP,4) 
10308         PZM=P(IQ,3)+P(IP,3) 
10309         BETAZ=(-PEM*PZM+PZF*SQRT(PZF**2+PEM**2-PZM**2))/(PZF**2+PEM**2) 
10310         CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,0D0,0D0,DBLE(BETAZ))  
10311         CALL LUDBRB(I1,I2,ASIN(SINTH),0.,DBLE(BETAX),0D0,0D0)   
10312         CALL LUDBRB(I1,I2,0.,PHIPT,0D0,0D0,DBLE(BETAZ)) 
10313       ENDIF 
10314     
10315       RETURN    
10316       END   
10317     
10318 C*********************************************************************  

10319     
10320       SUBROUTINE PYRESD 
10321     
10322 C...Allows resonances to decay (including parton showers for hadronic   

10323 C...channels).  

10324       IMPLICIT DOUBLE PRECISION(D)  
10325       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10326       SAVE /LUJETS/ 
10327       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10328       SAVE /LUDAT1/ 
10329       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
10330       SAVE /LUDAT2/ 
10331       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
10332       SAVE /LUDAT3/ 
10333       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
10334       SAVE /PYSUBS/ 
10335       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10336       SAVE /PYPARS/ 
10337       COMMON/PYINT1/MINT(400),VINT(400) 
10338       SAVE /PYINT1/ 
10339       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
10340       SAVE /PYINT2/ 
10341       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
10342       SAVE /AMPTPYINT4/ 
10343       DIMENSION IREF(10,6),KDCY(2),KFL1(2),KFL2(2),NSD(2),ILIN(6),  
10344      &COUP(6,4),PK(6,4),PKK(6,6),CTHE(2),PHI(2),WDTP(0:40), 
10345      &WDTE(0:40,0:5)    
10346       COMPLEX FGK,HA(6,6),HC(6,6)   
10347     
10348 C...The F, Xi and Xj functions of Gunion and Kunszt 

10349 C...(Phys. Rev. D33, 665, plus errata from the authors).    

10350       FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)* 
10351      &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))    
10352       DIGK(DT,DU)=-4.d0*D34*D56+DT*(3.d0*DT+4.d0*DU)
10353      &     +DT**2*(DT*DU/(D34*D56)-  
10354      &2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+2.d0*(D34/D56+D56/D34))
10355       DJGK(DT,DU)=8.d0*(D34+D56)**2-8.d0*(D34+D56)*(DT+DU)-6.d0*DT*DU-    
10356      &2.d0*DT*DU*(DT*DU/(D34*D56)-2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+ 
10357      &2.d0*(D34/D56+D56/D34)) 
10358     
10359 C...Define initial two objects, initialize loop.    

10360       ISUB=MINT(1)  
10361       SH=VINT(44)
10362 C...Initialize variable with default value

10363       DO I=1,6
10364          IREF(1,I)=0.0
10365       ENDDO
10366 
10367       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN   
10368         IREF(1,1)=MINT(84)+2+ISET(ISUB) 
10369         IREF(1,2)=0 
10370         IREF(1,3)=MINT(83)+6+ISET(ISUB) 
10371         IREF(1,4)=0 
10372       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN   
10373         IREF(1,1)=MINT(84)+1+ISET(ISUB) 
10374         IREF(1,2)=MINT(84)+2+ISET(ISUB) 
10375         IREF(1,3)=MINT(83)+5+ISET(ISUB) 
10376         IREF(1,4)=MINT(83)+6+ISET(ISUB) 
10377       ENDIF 
10378       NP=1  
10379       IP=0  
10380   100 IP=IP+1   
10381       NINH=0    
10382     
10383 C...Loop over one/two resonances; reset decay rates.    

10384       JTMAX=2   
10385 cms.. pre-intialize

10386       I12=0
10387       IF(IP.EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3)) JTMAX=1  
10388       DO 140 JT=1,JTMAX 
10389       KDCY(JT)=0    
10390       KFL1(JT)=0    
10391       KFL2(JT)=0
10392       NSD(JT)=IREF(IP,JT)   
10393       ID=IREF(IP,JT)    
10394       IF(ID.EQ.0) GOTO 140  
10395       KFA=IABS(K(ID,2)) 
10396       IF(KFA.LT.23.OR.KFA.GT.40) GOTO 140   
10397       IF(MDCY(KFA,1).NE.0) THEN 
10398         IF(ISUB.EQ.1.OR.ISUB.EQ.141) MINT(61)=1 
10399         CALL PYWIDT(KFA,P(ID,5),WDTP,WDTE)  
10400         IF(KCHG(KFA,3).EQ.0) THEN   
10401           IPM=2 
10402         ELSE    
10403           IPM=(5+ISIGN(1,K(ID,2)))/2    
10404         ENDIF   
10405         IF(JTMAX.EQ.1.OR.IABS(K(IREF(IP,1),2)).NE.IABS(K(IREF(IP,2),2)))    
10406      &  THEN    
10407           I12=4 
10408         ELSE    
10409           IF(JT.EQ.1) I12=INT(4.5+RLU(0))   
10410           I12=9-I12 
10411         ENDIF   
10412         RKFL=(WDTE(0,1)+WDTE(0,IPM)+WDTE(0,I12))*RLU(0) 
10413         DO 120 I=1,MDCY(KFA,3)  
10414         IDC=I+MDCY(KFA,2)-1 
10415         KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))   
10416         KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))   
10417         RKFL=RKFL-(WDTE(I,1)+WDTE(I,IPM)+WDTE(I,I12))   
10418         IF(RKFL.LE.0.) GOTO 130 
10419   120   CONTINUE    
10420   130   CONTINUE    
10421       ENDIF 
10422     
10423 C...Summarize result on decay channel chosen.   

10424       IF((KFA.EQ.23.OR.KFA.EQ.24).AND.KFL1(JT).EQ.0) NINH=NINH+1    
10425       IF(KFL1(JT).EQ.0) GOTO 140    
10426       KDCY(JT)=2    
10427       IF(IABS(KFL1(JT)).LE.10.OR.KFL1(JT).EQ.21) KDCY(JT)=1 
10428       IF((IABS(KFL1(JT)).GE.23.AND.IABS(KFL1(JT)).LE.25).OR.    
10429      &(IABS(KFL1(JT)).EQ.37)) KDCY(JT)=3    
10430       NSD(JT)=N 
10431     
10432 C...Fill decay products, prepared for parton showers for quarks.    

10433 clin-8/19/02 avoid actual argument in common blocks of LU2ENT:

10434       pid5=P(ID,5)
10435       IF(KDCY(JT).EQ.1) THEN    
10436 c        CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),P(ID,5))   

10437         CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),pid5)   
10438       ELSE  
10439 c        CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))  

10440         CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),pid5)  
10441       ENDIF 
10442 
10443       IF(JTMAX.EQ.1) THEN   
10444         CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*RLU(0)  
10445         IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)    
10446         PHI(JT)=VINT(24)    
10447       ELSE  
10448         CTHE(JT)=2.*RLU(0)-1.   
10449         PHI(JT)=PARU(2)*RLU(0)  
10450       ENDIF 
10451   140 CONTINUE  
10452       IF(MINT(3).EQ.1.AND.IP.EQ.1) THEN 
10453         MINT(25)=KFL1(1)    
10454         MINT(26)=KFL2(1)    
10455       ENDIF 
10456       IF(JTMAX.EQ.1.AND.KDCY(1).EQ.0) GOTO 530  
10457       IF(JTMAX.EQ.2.AND.KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 530 
10458       IF(MSTP(45).LE.0.OR.IREF(IP,2).EQ.0.OR.NINH.GE.1) GOTO 500    
10459       IF(K(IREF(1,1),2).EQ.25.AND.IP.EQ.1) GOTO 500 
10460       IF(K(IREF(1,1),2).EQ.25.AND.KDCY(1)*KDCY(2).EQ.0) GOTO 500    
10461     
10462 C...Order incoming partons and outgoing resonances. 

10463       ILIN(1)=MINT(84)+1    
10464       IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2   
10465       IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)   
10466       ILIN(2)=2*MINT(84)+3-ILIN(1)  
10467       IMIN=1    
10468       IF(IREF(IP,5).EQ.25) IMIN=3   
10469       IMAX=2    
10470       IORD=1    
10471       IF(K(IREF(IP,1),2).EQ.23) IORD=2  
10472       IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2   
10473       IF(IABS(K(IREF(IP,IORD),2)).EQ.25) IORD=3-IORD    
10474       IF(KDCY(IORD).EQ.0) IORD=3-IORD   
10475     
10476 C...Order decay products of resonances. 

10477       DO 390 JT=IORD,3-IORD,3-2*IORD    
10478       IF(KDCY(JT).EQ.0) THEN    
10479         ILIN(IMAX+1)=NSD(JT)    
10480         IMAX=IMAX+1 
10481       ELSEIF(K(NSD(JT)+1,2).GT.0) THEN  
10482         ILIN(IMAX+1)=N+2*JT-1   
10483         ILIN(IMAX+2)=N+2*JT 
10484         IMAX=IMAX+2 
10485         K(N+2*JT-1,2)=K(NSD(JT)+1,2)    
10486         K(N+2*JT,2)=K(NSD(JT)+2,2)  
10487       ELSE  
10488         ILIN(IMAX+1)=N+2*JT 
10489         ILIN(IMAX+2)=N+2*JT-1   
10490         IMAX=IMAX+2 
10491         K(N+2*JT-1,2)=K(NSD(JT)+1,2)    
10492         K(N+2*JT,2)=K(NSD(JT)+2,2)  
10493       ENDIF 
10494   390 CONTINUE  
10495     
10496 C...Find charge, isospin, left- and righthanded couplings.  

10497       XW=PARU(102)  
10498       DO 410 I=IMIN,IMAX    
10499       DO 400 J=1,4  
10500   400 COUP(I,J)=0.  
10501       KFA=IABS(K(ILIN(I),2))    
10502       IF(KFA.GT.20) GOTO 410    
10503       COUP(I,1)=LUCHGE(KFA)/3.  
10504       COUP(I,2)=(-1)**MOD(KFA,2)    
10505       COUP(I,4)=-2.*COUP(I,1)*XW    
10506       COUP(I,3)=COUP(I,2)+COUP(I,4) 
10507   410 CONTINUE  
10508       SQMZ=PMAS(23,1)**2    
10509       GZMZ=PMAS(23,1)*PMAS(23,2)    
10510       SQMW=PMAS(24,1)**2    
10511       GZMW=PMAS(24,1)*PMAS(24,2)    
10512       SQMZP=PMAS(32,1)**2   
10513       GZMZP=PMAS(32,1)*PMAS(32,2)   
10514     
10515 C...Select random angles; construct massless four-vectors.  

10516   420 DO 430 I=N+1,N+4  
10517       K(I,1)=1  
10518       DO 430 J=1,5  
10519   430 P(I,J)=0. 
10520       DO 440 JT=1,JTMAX 
10521       IF(KDCY(JT).EQ.0) GOTO 440    
10522       ID=IREF(IP,JT)    
10523       P(N+2*JT-1,3)=0.5*P(ID,5) 
10524       P(N+2*JT-1,4)=0.5*P(ID,5) 
10525       P(N+2*JT,3)=-0.5*P(ID,5)  
10526       P(N+2*JT,4)=0.5*P(ID,5)   
10527       CTHE(JT)=2.*RLU(0)-1. 
10528       PHI(JT)=PARU(2)*RLU(0)    
10529       CALL LUDBRB(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),   
10530      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))    
10531   440 CONTINUE  
10532     
10533 C...Store incoming and outgoing momenta, with random rotation to    

10534 C...avoid accidental zeroes in HA expressions.  

10535       DO 450 I=1,IMAX   
10536       K(N+4+I,1)=1  
10537       P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+  
10538      &P(ILIN(I),5)**2)  
10539       P(N+4+I,5)=P(ILIN(I),5)   
10540       DO 450 J=1,3  
10541   450 P(N+4+I,J)=P(ILIN(I),J)   
10542       THERR=ACOS(2.*RLU(0)-1.)  
10543       PHIRR=PARU(2)*RLU(0)  
10544       CALL LUDBRB(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0) 
10545       DO 460 I=1,IMAX   
10546       DO 460 J=1,4  
10547   460 PK(I,J)=P(N+4+I,J)    
10548     
10549 C...Calculate internal products.    

10550       IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25) THEN   
10551         DO 470 I1=IMIN,IMAX-1   
10552         DO 470 I2=I1+1,IMAX 
10553         HA(I1,I2)=SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+PK(I2,3))/ 
10554      &  (1E-20+PK(I1,1)**2+PK(I1,2)**2))*CMPLX(PK(I1,1),PK(I1,2))-  
10555      &  SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/   
10556      &  (1E-20+PK(I2,1)**2+PK(I2,2)**2))*CMPLX(PK(I2,1),PK(I2,2))   
10557         HC(I1,I2)=CONJG(HA(I1,I2))  
10558         IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)    
10559         IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)    
10560         HA(I2,I1)=-HA(I1,I2)    
10561   470   HC(I2,I1)=-HC(I1,I2)    
10562       ENDIF 
10563       DO 480 I=1,2  
10564       DO 480 J=1,4  
10565   480 PK(I,J)=-PK(I,J)  
10566       DO 490 I1=IMIN,IMAX-1 
10567       DO 490 I2=I1+1,IMAX   
10568       PKK(I1,I2)=2.*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-   
10569      &PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))  
10570   490 PKK(I2,I1)=PKK(I1,I2) 
10571    
10572 cms.. pre-initialize

10573       WT=0.
10574       IF(IREF(IP,5).EQ.25) THEN 
10575 C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons 

10576         WT=16.*PKK(3,5)*PKK(4,6)    
10577         IF(IP.EQ.1) WTMAX=SH**2 
10578         IF(IP.GE.2) WTMAX=P(IREF(IP,6),5)**4    
10579     
10580       ELSEIF(ISUB.EQ.1) THEN    
10581         IF(KFA.NE.37) THEN  
10582 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons    

10583           EI=KCHG(IABS(MINT(15)),1)/3.  
10584           AI=SIGN(1.,EI+0.1)    
10585           VI=AI-4.*EI*XW    
10586           EF=KCHG(KFA,1)/3. 
10587           AF=SIGN(1.,EF+0.1)    
10588           VF=AF-4.*EF*XW    
10589           GG=1. 
10590           GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2) 
10591           ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)    
10592           IF(MSTP(43).EQ.1) THEN    
10593 C...Only gamma* production included 

10594             GZ=0.   
10595             ZZ=0.   
10596           ELSEIF(MSTP(43).EQ.2) THEN    
10597 C...Only Z0 production included 

10598             GG=0.   
10599             GZ=0.   
10600           ENDIF 
10601           ASYM=2.*(EI*AI*GZ*EF*AF+4.*VI*AI*ZZ*VF*AF)/(EI**2*GG*EF**2+   
10602      &    EI*VI*GZ*EF*VF+(VI**2+AI**2)*ZZ*(VF**2+AF**2))    
10603           WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2   
10604           WTMAX=2.+ABS(ASYM)    
10605         ELSE    
10606 C...Angular weight for gamma*/Z0 -> H+ + H- 

10607           WT=1.-CTHE(JT)**2 
10608           WTMAX=1.  
10609         ENDIF   
10610     
10611       ELSEIF(ISUB.EQ.2) THEN    
10612 C...Angular weight for W+/- -> 2 quarks/leptons 

10613         WT=(1.+CTHE(JT))**2 
10614         WTMAX=4.    
10615     
10616       ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN 
10617 C...Angular weight for f + fb -> gluon/gamma + Z0 ->    

10618 C...-> gluon/gamma + 2 quarks/leptons   

10619         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)* 
10620      &  (PKK(1,3)**2+PKK(2,4)**2)+((COUP(1,3)*COUP(3,4))**2+    
10621      &  (COUP(1,4)*COUP(3,3))**2)*(PKK(1,4)**2+PKK(2,3)**2) 
10622         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*  
10623      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2) 
10624     
10625       ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN 
10626 C...Angular weight for f + fb' -> gluon/gamma + W+/- -> 

10627 C...-> gluon/gamma + 2 quarks/leptons   

10628         WT=PKK(1,3)**2+PKK(2,4)**2  
10629         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2 
10630     
10631       ELSEIF(ISUB.EQ.22) THEN   
10632 C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons    

10633         S34=P(IREF(IP,IORD),5)**2   
10634         S56=P(IREF(IP,3-IORD),5)**2 
10635         TI=PKK(1,3)+PKK(1,4)+S34    
10636         UI=PKK(1,5)+PKK(1,6)+S56    
10637         WT=COUP(1,3)**4*((COUP(3,3)*COUP(5,3)*ABS(FGK(1,2,3,4,5,6)/ 
10638      &  TI+FGK(1,2,5,6,3,4)/UI))**2+(COUP(3,4)*COUP(5,3)*ABS(   
10639      &  FGK(1,2,4,3,5,6)/TI+FGK(1,2,5,6,4,3)/UI))**2+(COUP(3,3)*    
10640      &  COUP(5,4)*ABS(FGK(1,2,3,4,6,5)/TI+FGK(1,2,6,5,3,4)/UI))**2+ 
10641      &  (COUP(3,4)*COUP(5,4)*ABS(FGK(1,2,4,3,6,5)/TI+FGK(1,2,6,5,4,3)/  
10642      &  UI))**2)+COUP(1,4)**4*((COUP(3,3)*COUP(5,3)*ABS(    
10643      &  FGK(2,1,5,6,3,4)/TI+FGK(2,1,3,4,5,6)/UI))**2+(COUP(3,4)*    
10644      &  COUP(5,3)*ABS(FGK(2,1,6,5,3,4)/TI+FGK(2,1,3,4,6,5)/UI))**2+ 
10645      &  (COUP(3,3)*COUP(5,4)*ABS(FGK(2,1,5,6,4,3)/TI+FGK(2,1,4,3,5,6)/  
10646      &  UI))**2+(COUP(3,4)*COUP(5,4)*ABS(FGK(2,1,6,5,4,3)/TI+   
10647      &  FGK(2,1,4,3,6,5)/UI))**2)   
10648         WTMAX=4.*S34*S56*(COUP(1,3)**4+COUP(1,4)**4)*(COUP(3,3)**2+ 
10649      &  COUP(3,4)**2)*(COUP(5,3)**2+COUP(5,4)**2)*4.*(TI/UI+UI/TI+  
10650      &  2.*SH*(S34+S56)/(TI*UI)-S34*S56*(1./TI**2+1./UI**2))    
10651     
10652       ELSEIF(ISUB.EQ.23) THEN   
10653 C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons    

10654         D34=dble(P(IREF(IP,IORD),5)**2)
10655         D56=dble(P(IREF(IP,3-IORD),5)**2)
10656         DT=dble(PKK(1,3)+PKK(1,4))+D34    
10657         DU=dble(PKK(1,5)+PKK(1,6))+D56    
10658         CAWZ=COUP(2,3)/SNGL(DT)-2.*(1.-XW)*COUP(1,2)/(SH-SQMW)  
10659         CBWZ=COUP(1,3)/SNGL(DU)+2.*(1.-XW)*COUP(1,2)/(SH-SQMW)  
10660         WT=COUP(5,3)**2*ABS(CAWZ*FGK(1,2,3,4,5,6)+CBWZ* 
10661      &  FGK(1,2,5,6,3,4))**2+COUP(5,4)**2*ABS(CAWZ* 
10662      &  FGK(1,2,3,4,6,5)+CBWZ*FGK(1,2,6,5,3,4))**2  
10663         WTMAX=4.*sngl(D34*D56)*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*  
10664      &       sngl(DIGK(DT,DU))+CBWZ**2*sngl(DIGK(DU,DT))
10665      &       +CAWZ*CBWZ*sngl(DJGK(DT,DU)))  
10666     
10667       ELSEIF(ISUB.EQ.24) THEN   
10668 C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0   

10669         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)* 
10670      &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)* 
10671      &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)    
10672         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*  
10673      &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) 
10674     
10675       ELSEIF(ISUB.EQ.25) THEN   
10676 C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons    

10677         D34=dble(P(IREF(IP,IORD),5)**2)
10678         D56=dble(P(IREF(IP,3-IORD),5)**2)
10679         DT=dble(PKK(1,3)+PKK(1,4))+D34    
10680         DU=dble(PKK(1,5)+PKK(1,6))+D56    
10681         CDWW=(COUP(1,3)*SQMZ/(SH-SQMZ)+COUP(1,2))/SH    
10682         CAWW=CDWW+0.5*(COUP(1,2)+1.)/SNGL(DT)   
10683         CBWW=CDWW+0.5*(COUP(1,2)-1.)/SNGL(DU)   
10684         CCWW=COUP(1,4)*SQMZ/(SH-SQMZ)/SH    
10685         WT=ABS(CAWW*FGK(1,2,3,4,5,6)-CBWW*FGK(1,2,5,6,3,4))**2+ 
10686      &  CCWW**2*ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))**2   
10687         WTMAX=4.*sngl(D34*D56)*(CAWW**2*sngl(DIGK(DT,DU))
10688      &       +CBWW**2*sngl(DIGK(DU,DT))-CAWW*CBWW*sngl(DJGK(DT,DU))
10689      &       +CCWW**2*sngl(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10690     
10691       ELSEIF(ISUB.EQ.26) THEN   
10692 C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0    

10693         WT=PKK(1,3)*PKK(2,4)    
10694         WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))   
10695     
10696       ELSEIF(ISUB.EQ.30) THEN   
10697 C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons  

10698         IF(K(ILIN(1),2).GT.0) WT=((COUP(1,3)*COUP(3,3))**2+ 
10699      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,4)**2+PKK(3,5)**2)+    
10700      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*    
10701      &  (PKK(1,3)**2+PKK(4,5)**2)   
10702         IF(K(ILIN(1),2).LT.0) WT=((COUP(1,3)*COUP(3,3))**2+ 
10703      &  (COUP(1,4)*COUP(3,4))**2)*(PKK(1,3)**2+PKK(4,5)**2)+    
10704      &  ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*    
10705      &  (PKK(1,4)**2+PKK(3,5)**2)   
10706         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*  
10707      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2) 
10708     
10709       ELSEIF(ISUB.EQ.31) THEN   
10710 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons  

10711         IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2    
10712         IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2    
10713         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2 
10714     
10715       ELSEIF(ISUB.EQ.141) THEN  
10716 C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons    

10717         EI=KCHG(IABS(MINT(15)),1)/3.    
10718         AI=SIGN(1.,EI+0.1)  
10719         VI=AI-4.*EI*XW  
10720         API=SIGN(1.,EI+0.1) 
10721         VPI=API-4.*EI*XW    
10722         EF=KCHG(KFA,1)/3.   
10723         AF=SIGN(1.,EF+0.1)  
10724         VF=AF-4.*EF*XW  
10725         APF=SIGN(1.,EF+0.1) 
10726         VPF=APF-4.*EF*XW    
10727         GG=1.   
10728         GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)   
10729         GZP=1./(8.*XW*(1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GZMZP**2)   
10730         ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)  
10731         ZZP=2./(16.*XW*(1.-XW))**2* 
10732      &  SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/    
10733      &  (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))   
10734         ZPZP=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZP)**2+GZMZP**2)  
10735         IF(MSTP(44).EQ.1) THEN  
10736 C...Only gamma* production included 

10737           GZ=0. 
10738           GZP=0.    
10739           ZZ=0. 
10740           ZZP=0.    
10741           ZPZP=0.   
10742         ELSEIF(MSTP(44).EQ.2) THEN  
10743 C...Only Z0 production included 

10744           GG=0. 
10745           GZ=0. 
10746           GZP=0.    
10747           ZZP=0.    
10748           ZPZP=0.   
10749         ELSEIF(MSTP(44).EQ.3) THEN  
10750 C...Only Z'0 production included    

10751           GG=0. 
10752           GZ=0. 
10753           GZP=0.    
10754           ZZ=0. 
10755           ZZP=0.    
10756         ELSEIF(MSTP(44).EQ.4) THEN  
10757 C...Only gamma*/Z0 production included  

10758           GZP=0.    
10759           ZZP=0.    
10760           ZPZP=0.   
10761         ELSEIF(MSTP(44).EQ.5) THEN  
10762 C...Only gamma*/Z'0 production included 

10763           GZ=0. 
10764           ZZ=0. 
10765           ZZP=0.    
10766         ELSEIF(MSTP(44).EQ.6) THEN  
10767 C...Only Z0/Z'0 production included 

10768           GG=0. 
10769           GZ=0. 
10770           GZP=0.    
10771         ENDIF   
10772         ASYM=2.*(EI*AI*GZ*EF*AF+EI*API*GZP*EF*APF+4.*VI*AI*ZZ*VF*AF+    
10773      &  (VI*API+VPI*AI)*ZZP*(VF*APF+VPF*AF)+4.*VPI*API*ZPZP*VPF*APF)/   
10774      &  (EI**2*GG*EF**2+EI*VI*GZ*EF*VF+EI*VPI*GZP*EF*VPF+   
10775      &  (VI**2+AI**2)*ZZ*(VF**2+AF**2)+(VI*VPI+AI*API)*ZZP* 
10776      &  (VF*VPF+AF*APF)+(VPI**2+API**2)*ZPZP*(VPF**2+APF**2))   
10777         WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2 
10778         WTMAX=2.+ABS(ASYM)  
10779     
10780       ELSE  
10781         WT=1.   
10782         WTMAX=1.    
10783       ENDIF 
10784 C...Obtain correct angular distribution by rejection techniques.    

10785       IF(WT.LT.RLU(0)*WTMAX) GOTO 420   
10786     
10787 C...Construct massive four-vectors using angles chosen. Mark decayed    

10788 C...resonances, add documentation lines. Shower evolution.  

10789   500 DO 520 JT=1,JTMAX 
10790       IF(KDCY(JT).EQ.0) GOTO 520    
10791       ID=IREF(IP,JT)    
10792       CALL LUDBRB(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),   
10793      &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))    
10794       K(ID,1)=K(ID,1)+10    
10795       K(ID,4)=NSD(JT)+1 
10796       K(ID,5)=NSD(JT)+2 
10797       IDOC=MINT(83)+MINT(4) 
10798       DO 510 I=NSD(JT)+1,NSD(JT)+2  
10799       MINT(4)=MINT(4)+1 
10800       I1=MINT(83)+MINT(4)   
10801       K(I,3)=I1 
10802       K(I1,1)=21    
10803       K(I1,2)=K(I,2)    
10804       K(I1,3)=IREF(IP,JT+2) 
10805       DO 510 J=1,5  
10806   510 P(I1,J)=P(I,J)    
10807       IF(JTMAX.EQ.1) THEN   
10808         MINT(7)=MINT(83)+6+2*ISET(ISUB) 
10809         MINT(8)=MINT(83)+7+2*ISET(ISUB) 
10810       ENDIF 
10811 clin-8/19/02 avoid actual argument in common blocks of LUSHOW:

10812 c      IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,    

10813 c     &NSD(JT)+2,P(ID,5))    

10814       pid5=P(ID,5)
10815       IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,    
10816      &NSD(JT)+2,pid5)    
10817     
10818 C...Check if new resonances were produced, loop back if needed. 

10819       IF(KDCY(JT).NE.3) GOTO 520    
10820       NP=NP+1   
10821       IREF(NP,1)=NSD(JT)+1  
10822       IREF(NP,2)=NSD(JT)+2  
10823       IREF(NP,3)=IDOC+1 
10824       IREF(NP,4)=IDOC+2 
10825       IREF(NP,5)=K(IREF(IP,JT),2)   
10826       IREF(NP,6)=IREF(IP,JT)    
10827   520 CONTINUE  
10828   530 IF(IP.LT.NP) GOTO 100 
10829     
10830       RETURN    
10831       END   
10832     
10833 C*********************************************************************  

10834     
10835       SUBROUTINE PYDIFF 
10836     
10837 C...Handles diffractive and elastic scattering. 

10838       COMMON/LUJETS/N,K(9000,5),P(9000,5),V(9000,5)
10839       SAVE /LUJETS/ 
10840       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10841       SAVE /LUDAT1/ 
10842       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10843       SAVE /PYPARS/ 
10844       COMMON/PYINT1/MINT(400),VINT(400) 
10845       SAVE /PYINT1/ 
10846     
10847 C...Reset K, P and V vectors. Store incoming particles. 

10848       DO 100 JT=1,MSTP(126)+10  
10849       I=MINT(83)+JT 
10850       DO 100 J=1,5  
10851       K(I,J)=0  
10852       P(I,J)=0. 
10853   100 V(I,J)=0. 
10854       N=MINT(84)    
10855       MINT(3)=0 
10856       MINT(21)=0    
10857       MINT(22)=0    
10858       MINT(23)=0    
10859       MINT(24)=0    
10860       MINT(4)=4 
10861       DO 110 JT=1,2 
10862       I=MINT(83)+JT 
10863       K(I,1)=21 
10864       K(I,2)=MINT(10+JT)    
10865       P(I,5)=VINT(2+JT) 
10866       P(I,3)=VINT(5)*(-1)**(JT+1)   
10867   110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)  
10868       MINT(6)=2 
10869     
10870 C...Subprocess; kinematics. 

10871       ISUB=MINT(1)  
10872       SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4.*VINT(63)*VINT(64) 
10873       PZ=SQRT(SQLAM)/(2.*VINT(1))   
10874       DO 150 JT=1,2 
10875       I=MINT(83)+JT 
10876       PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2.*VINT(1)) 
10877     
10878 C...Elastically scattered particle. 

10879       IF(MINT(16+JT).LE.0) THEN 
10880         N=N+1   
10881         K(N,1)=1    
10882         K(N,2)=K(I,2)   
10883         K(N,3)=I+2  
10884         P(N,3)=PZ*(-1)**(JT+1)  
10885         P(N,4)=PE   
10886         P(N,5)=P(I,5)   
10887     
10888 C...Diffracted particle: valence quark kicked out.  

10889       ELSEIF(MSTP(101).EQ.1) THEN   
10890         N=N+2   
10891         K(N-1,1)=2  
10892         K(N,1)=1    
10893         K(N-1,3)=I+2    
10894         K(N,3)=I+2  
10895         CALL PYSPLI(K(I,2),21,K(N,2),K(N-1,2))  
10896         P(N-1,5)=ULMASS(K(N-1,2))   
10897         P(N,5)=ULMASS(K(N,2))   
10898         SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-   
10899      &  4.*P(N-1,5)**2*P(N,5)**2    
10900         P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-   
10901      &  P(N,5)**2))/(2.*VINT(62+JT))*(-1)**(JT+1)   
10902         P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)  
10903         P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3) 
10904         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)    
10905     
10906 C...Diffracted particle: gluon kicked out.  

10907       ELSE  
10908         N=N+3   
10909         K(N-2,1)=2  
10910         K(N-1,1)=2  
10911         K(N,1)=1    
10912         K(N-2,3)=I+2    
10913         K(N-1,3)=I+2    
10914         K(N,3)=I+2  
10915         CALL PYSPLI(K(I,2),21,K(N,2),K(N-2,2))  
10916         K(N-1,2)=21 
10917         P(N-2,5)=ULMASS(K(N-2,2))   
10918         P(N-1,5)=0. 
10919         P(N,5)=ULMASS(K(N,2))   
10920 C...Energy distribution for particle into two jets. 

10921   120   IMB=1   
10922         IF(MOD(K(I,2)/1000,10).NE.0) IMB=2  
10923         CHIK=PARP(92+2*IMB) 
10924         IF(MSTP(92).LE.1) THEN  
10925           IF(IMB.EQ.1) CHI=RLU(0)   
10926           IF(IMB.EQ.2) CHI=1.-SQRT(RLU(0))  
10927         ELSEIF(MSTP(92).EQ.2) THEN  
10928           CHI=1.-RLU(0)**(1./(1.+CHIK)) 
10929         ELSEIF(MSTP(92).EQ.3) THEN  
10930           CUT=2.*0.3/VINT(1)    
10931   130     CHI=RLU(0)**2 
10932           IF((CHI**2/(CHI**2+CUT**2))**0.25*(1.-CHI)**CHIK.LT.  
10933      &    RLU(0)) GOTO 130  
10934         ELSE    
10935           CUT=2.*0.3/VINT(1)    
10936           CUTR=(1.+SQRT(1.+CUT**2))/CUT 
10937   140     CHIR=CUT*CUTR**RLU(0) 
10938           CHI=(CHIR**2-CUT**2)/(2.*CHIR)    
10939           IF((1.-CHI)**CHIK.LT.RLU(0)) GOTO 140 
10940         ENDIF   
10941         IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1.-P(N-2,5)**2/   
10942      &  VINT(62+JT)) GOTO 120   
10943         SQM=P(N-2,5)**2/(1.-CHI)+P(N,5)**2/CHI  
10944         IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 120 
10945         PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/    
10946      &  (2.*VINT(62+JT))    
10947         PEI=SQRT(PZI**2+SQM)    
10948         PQQP=(1.-CHI)*(PEI+PZI) 
10949         P(N-2,3)=0.5*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)   
10950         P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)  
10951         P(N-1,3)=(PZ-PZI)*(-1)**(JT+1)  
10952         P(N-1,4)=ABS(P(N-1,3))  
10953         P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)    
10954         P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)    
10955       ENDIF 
10956     
10957 C...Documentation lines.    

10958       K(I+2,1)=21   
10959       IF(MINT(16+JT).EQ.0) K(I+2,2)=MINT(10+JT) 
10960       IF(MINT(16+JT).NE.0) K(I+2,2)=10*(MINT(10+JT)/10) 
10961       K(I+2,3)=I    
10962       P(I+2,3)=PZ*(-1)**(JT+1)  
10963       P(I+2,4)=PE   
10964       P(I+2,5)=SQRT(VINT(62+JT))    
10965   150 CONTINUE  
10966     
10967 C...Rotate outgoing partons/particles using cos(theta). 

10968       CALL LUDBRB(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) 
10969     
10970       RETURN    
10971       END   
10972     
10973 C*********************************************************************  

10974     
10975       SUBROUTINE PYFRAM(IFRAME) 
10976     
10977 C...Performs transformations between different coordinate frames.   

10978       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
10979       SAVE /LUDAT1/ 
10980       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
10981       SAVE /PYPARS/ 
10982       COMMON/PYINT1/MINT(400),VINT(400) 
10983       SAVE /PYINT1/ 
10984     
10985       IF(IFRAME.LT.1.OR.IFRAME.GT.2) THEN   
10986         WRITE(MSTU(11),1000) IFRAME,MINT(6) 
10987         RETURN  
10988       ENDIF 
10989       IF(IFRAME.EQ.MINT(6)) RETURN  
10990     
10991       IF(MINT(6).EQ.1) THEN 
10992 C...Transform from fixed target or user specified frame to  

10993 C...CM-frame of incoming particles. 

10994         CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))  
10995         CALL LUROBO(0.,-VINT(7),0.,0.,0.)   
10996         CALL LUROBO(-VINT(6),0.,0.,0.,0.)   
10997         MINT(6)=2   
10998     
10999       ELSE  
11000 C...Transform from particle CM-frame to fixed target or user specified  

11001 C...frame.  

11002         CALL LUROBO(VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))   
11003         MINT(6)=1   
11004       ENDIF 
11005       MSTI(6)=MINT(6)   
11006     
11007  1000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,   
11008      &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =', 
11009      &1X,I5)    
11010     
11011       RETURN    
11012       END   
11013     
11014 C*********************************************************************  

11015     
11016       SUBROUTINE PYWIDT(KFLR,RMAS,WDTP,WDTE)    
11017     
11018 C...Calculates full and partial widths of resonances.   

11019       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
11020       SAVE /LUDAT1/ 
11021       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
11022       SAVE /LUDAT2/ 
11023       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
11024       SAVE /LUDAT3/ 
11025       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
11026       SAVE /PYPARS/ 
11027       COMMON/PYINT1/MINT(400),VINT(400) 
11028       SAVE /PYINT1/ 
11029       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
11030       SAVE /AMPTPYINT4/ 
11031       DIMENSION WDTP(0:40),WDTE(0:40,0:5)   
11032     
11033 C...Some common constants.  

11034       KFLA=IABS(KFLR)   
11035       SQM=RMAS**2   
11036       AS=ULALPS(SQM)    
11037       AEM=PARU(101) 
11038       XW=PARU(102)  
11039       RADC=1.+AS/PARU(1)    
11040     
11041 C...Reset width information.    

11042       DO 100 I=0,40 
11043       WDTP(I)=0.    
11044       DO 100 J=0,5  
11045   100 WDTE(I,J)=0.  
11046    
11047 cms... Do a whole bunch of intialization...

11048       GGF=0.
11049       GZF=0.
11050       GZPF=0.
11051       ZZF=0.
11052       ZZPF=0.
11053       ZPZPF=0.
11054 
11055       IF(KFLA.EQ.21) THEN   
11056 C...QCD:    

11057         DO 110 I=1,MDCY(21,3)   
11058         IDC=I+MDCY(21,2)-1  
11059         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
11060         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
11061         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 110  
11062         IF(I.LE.8) THEN 
11063 C...QCD -> q + qb   

11064           WDTP(I)=(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
11065           WID2=1.   
11066         ENDIF   
11067         WDTP(0)=WDTP(0)+WDTP(I) 
11068         IF(MDME(IDC,1).GT.0) THEN   
11069           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
11070           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
11071           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
11072           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
11073         ENDIF   
11074   110   CONTINUE    
11075     
11076       ELSEIF(KFLA.EQ.23) THEN   
11077 C...Z0: 

11078         EI=KCHG(IABS(MINT(15)),1)/3.  
11079         AI=SIGN(1.,EI)    
11080         VI=AI-4.*EI*XW    
11081         SQMZ=PMAS(23,1)**2    
11082         GZMZ=PMAS(23,2)*PMAS(23,1)    
11083         GGI=EI**2 
11084         GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/ 
11085      &  ((SQM-SQMZ)**2+GZMZ**2)   
11086         ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/ 
11087      &  ((SQM-SQMZ)**2+GZMZ**2)   
11088         IF(MINT(61).EQ.1) THEN
11089           IF(MSTP(43).EQ.1) THEN    
11090 C...Only gamma* production included 

11091             GZI=0.  
11092             ZZI=0.  
11093           ELSEIF(MSTP(43).EQ.2) THEN    
11094 C...Only Z0 production included 

11095             GGI=0.  
11096             GZI=0.  
11097           ENDIF 
11098         ELSEIF(MINT(61).EQ.2) THEN  
11099           VINT(111)=0.  
11100           VINT(112)=0.  
11101           VINT(114)=0.  
11102         ENDIF   
11103         DO 120 I=1,MDCY(23,3)   
11104         IDC=I+MDCY(23,2)-1  
11105         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
11106         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
11107         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 120  
11108         IF(I.LE.8) THEN 
11109 C...Z0 -> q + qb    

11110           EF=KCHG(I,1)/3.   
11111           AF=SIGN(1.,EF+0.1)    
11112           VF=AF-4.*EF*XW    
11113           IF(MINT(61).EQ.0) THEN    
11114             WDTP(I)=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*   
11115      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11116           ELSEIF(MINT(61).EQ.1) THEN    
11117             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*    
11118      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))* 
11119      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11120           ELSEIF(MINT(61).EQ.2) THEN    
11121             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
11122             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
11123             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*   
11124      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11125           ENDIF 
11126           WID2=1.   
11127         ELSEIF(I.LE.16) THEN    
11128 C...Z0 -> l+ + l-, nu + nub 

11129           EF=KCHG(I+2,1)/3. 
11130           AF=SIGN(1.,EF+0.1)    
11131           VF=AF-4.*EF*XW    
11132           WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*    
11133      &    SQRT(MAX(0.,1.-4.*RM1))   
11134           IF(MINT(61).EQ.0) THEN    
11135             WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*  
11136      &      SQRT(MAX(0.,1.-4.*RM1)) 
11137           ELSEIF(MINT(61).EQ.1) THEN    
11138             WDTP(I)=((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*   
11139      &      (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))* 
11140      &      SQRT(MAX(0.,1.-4.*RM1)) 
11141           ELSEIF(MINT(61).EQ.2) THEN    
11142             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
11143             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
11144             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*  
11145      &      SQRT(MAX(0.,1.-4.*RM1)) 
11146           ENDIF 
11147           WID2=1.   
11148         ELSE    
11149 C...Z0 -> H+ + H-   

11150           CF=2.*(1.-2.*XW)  
11151           IF(MINT(61).EQ.0) THEN    
11152             WDTP(I)=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))  
11153           ELSEIF(MINT(61).EQ.1) THEN    
11154             WDTP(I)=0.25*(GGI+GZI*CF+ZZI*CF**2)*(1.-4.*RM1)*    
11155      &      SQRT(MAX(0.,1.-4.*RM1)) 
11156           ELSEIF(MINT(61).EQ.2) THEN    
11157             GGF=0.25*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))    
11158             GZF=0.25*CF*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1)) 
11159             ZZF=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))  
11160           ENDIF 
11161           WID2=WIDS(37,1)   
11162         ENDIF   
11163         WDTP(0)=WDTP(0)+WDTP(I) 
11164         IF(MDME(IDC,1).GT.0) THEN   
11165           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
11166           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
11167           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
11168           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
11169 clin-4/2008 modified a la pythia6115.f to avoid undefined values (GGF,GZF,ZZF):

11170 c          VINT(111)=VINT(111)+GGF*WID2  

11171 c          VINT(112)=VINT(112)+GZF*WID2  

11172 c          VINT(114)=VINT(114)+ZZF*WID2  

11173           IF(MINT(61).EQ.2) THEN    
11174              VINT(111)=VINT(111)+GGF*WID2  
11175              VINT(112)=VINT(112)+GZF*WID2  
11176              VINT(114)=VINT(114)+ZZF*WID2  
11177           ENDIF
11178 clin-4/2008-end

11179         ENDIF   
11180   120   CONTINUE    
11181         IF(MSTP(43).EQ.1) THEN  
11182 C...Only gamma* production included 

11183           VINT(112)=0.  
11184           VINT(114)=0.  
11185         ELSEIF(MSTP(43).EQ.2) THEN  
11186 C...Only Z0 production included 

11187           VINT(111)=0.  
11188           VINT(112)=0.  
11189         ENDIF   
11190     
11191       ELSEIF(KFLA.EQ.24) THEN   
11192 C...W+/-:   

11193         DO 130 I=1,MDCY(24,3)   
11194         IDC=I+MDCY(24,2)-1  
11195         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
11196         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
11197         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 130  
11198         IF(I.LE.16) THEN    
11199 C...W+/- -> q + qb' 

11200           WDTP(I)=3.*(2.-RM1-RM2-(RM1-RM2)**2)* 
11201      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))* 
11202      &    VCKM((I-1)/4+1,MOD(I-1,4)+1)*RADC 
11203           WID2=1.   
11204         ELSE    
11205 C...W+/- -> l+/- + nu   

11206           WDTP(I)=(2.-RM1-RM2-(RM1-RM2)**2)*    
11207      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))  
11208           WID2=1.   
11209         ENDIF   
11210         WDTP(0)=WDTP(0)+WDTP(I) 
11211         IF(MDME(IDC,1).GT.0) THEN   
11212           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
11213           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
11214           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
11215           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
11216         ENDIF   
11217   130   CONTINUE    
11218     
11219       ELSEIF(KFLA.EQ.25) THEN   
11220 C...H0: 

11221         DO 170 I=1,MDCY(25,3)   
11222         IDC=I+MDCY(25,2)-1  
11223         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
11224         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
11225         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 170  
11226         IF(I.LE.8) THEN 
11227 C...H0 -> q + qb    

11228           WDTP(I)=3.*RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
11229           WID2=1.   
11230         ELSEIF(I.LE.12) THEN    
11231 C...H0 -> l+ + l-   

11232           WDTP(I)=RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
11233           WID2=1.   
11234         ELSEIF(I.EQ.13) THEN    
11235 C...H0 -> g + g; quark loop contribution only   

11236           ETARE=0.  
11237           ETAIM=0.  
11238           DO 140 J=1,2*MSTP(1)  
11239           EPS=(2.*PMAS(J,1)/RMAS)**2    
11240           IF(EPS.LE.1.) THEN    
11241             IF(EPS.GT.1.E-4) THEN   
11242               ROOT=SQRT(1.-EPS) 
11243               RLN=LOG((1.+ROOT)/(1.-ROOT))  
11244             ELSE    
11245               RLN=LOG(4./EPS-2.)    
11246             ENDIF   
11247             PHIRE=0.25*(RLN**2-PARU(1)**2)  
11248             PHIIM=0.5*PARU(1)*RLN   
11249           ELSE  
11250             PHIRE=-(ASIN(1./SQRT(EPS)))**2  
11251             PHIIM=0.    
11252           ENDIF 
11253           ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)   
11254           ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM    
11255   140     CONTINUE  
11256           ETA2=ETARE**2+ETAIM**2    
11257           WDTP(I)=(AS/PARU(1))**2*ETA2  
11258           WID2=1.   
11259         ELSEIF(I.EQ.14) THEN    
11260 C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions 

11261           ETARE=0.  
11262           ETAIM=0.  
11263           EJ=0.
11264           DO 150 J=1,3*MSTP(1)+1    
11265           IF(J.LE.2*MSTP(1)) THEN   
11266             EJ=KCHG(J,1)/3. 
11267             EPS=(2.*PMAS(J,1)/RMAS)**2  
11268           ELSEIF(J.LE.3*MSTP(1)) THEN   
11269             JL=2*(J-2*MSTP(1))-1    
11270             EJ=KCHG(10+JL,1)/3. 
11271             EPS=(2.*PMAS(10+JL,1)/RMAS)**2  
11272           ELSE  
11273             EPS=(2.*PMAS(24,1)/RMAS)**2 
11274           ENDIF 
11275           IF(EPS.LE.1.) THEN    
11276             IF(EPS.GT.1.E-4) THEN   
11277               ROOT=SQRT(1.-EPS) 
11278               RLN=LOG((1.+ROOT)/(1.-ROOT))  
11279             ELSE    
11280               RLN=LOG(4./EPS-2.)    
11281             ENDIF   
11282             PHIRE=0.25*(RLN**2-PARU(1)**2)  
11283             PHIIM=0.5*PARU(1)*RLN   
11284           ELSE  
11285             PHIRE=-(ASIN(1./SQRT(EPS)))**2  
11286             PHIIM=0.    
11287           ENDIF 
11288           IF(J.LE.2*MSTP(1)) THEN   
11289             ETARE=ETARE+0.5*3.*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)    
11290             ETAIM=ETAIM+0.5*3.*EJ**2*EPS*(EPS-1.)*PHIIM 
11291           ELSEIF(J.LE.3*MSTP(1)) THEN   
11292             ETARE=ETARE+0.5*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)   
11293             ETAIM=ETAIM+0.5*EJ**2*EPS*(EPS-1.)*PHIIM    
11294           ELSE  
11295             ETARE=ETARE-0.5-0.75*EPS*(1.+(EPS-2.)*PHIRE)    
11296             ETAIM=ETAIM+0.75*EPS*(EPS-2.)*PHIIM 
11297           ENDIF 
11298   150     CONTINUE  
11299           ETA2=ETARE**2+ETAIM**2    
11300           WDTP(I)=(AEM/PARU(1))**2*0.5*ETA2 
11301           WID2=1.   
11302         ELSEIF(I.EQ.15) THEN    
11303 C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions    

11304           ETARE=0.  
11305           ETAIM=0.
11306           VJ=0.
11307           EJ=0.  
11308           DO 160 J=1,3*MSTP(1)+1    
11309           IF(J.LE.2*MSTP(1)) THEN   
11310             EJ=KCHG(J,1)/3. 
11311             AJ=SIGN(1.,EJ+0.1)  
11312             VJ=AJ-4.*EJ*XW  
11313             EPS=(2.*PMAS(J,1)/RMAS)**2  
11314             EPSP=(2.*PMAS(J,1)/PMAS(23,1))**2   
11315           ELSEIF(J.LE.3*MSTP(1)) THEN   
11316             JL=2*(J-2*MSTP(1))-1    
11317             EJ=KCHG(10+JL,1)/3. 
11318             AJ=SIGN(1.,EJ+0.1)  
11319             VJ=AJ-4.*EJ*XW  
11320             EPS=(2.*PMAS(10+JL,1)/RMAS)**2  
11321             EPSP=(2.*PMAS(10+JL,1)/PMAS(23,1))**2   
11322           ELSE
11323             EPS=(2.*PMAS(24,1)/RMAS)**2 
11324             EPSP=(2.*PMAS(24,1)/PMAS(23,1))**2  
11325           ENDIF 
11326           IF(EPS.LE.1.) THEN    
11327             ROOT=SQRT(1.-EPS)   
11328             IF(EPS.GT.1.E-4) THEN   
11329               RLN=LOG((1.+ROOT)/(1.-ROOT))  
11330             ELSE    
11331               RLN=LOG(4./EPS-2.)    
11332             ENDIF   
11333             PHIRE=0.25*(RLN**2-PARU(1)**2)  
11334             PHIIM=0.5*PARU(1)*RLN   
11335             PSIRE=-(1.+0.5*ROOT*RLN)    
11336             PSIIM=0.5*PARU(1)*ROOT  
11337           ELSE  
11338             PHIRE=-(ASIN(1./SQRT(EPS)))**2  
11339             PHIIM=0.    
11340             PSIRE=-(1.+SQRT(EPS-1.)*ASIN(1./SQRT(EPS))) 
11341             PSIIM=0.    
11342           ENDIF 
11343           IF(EPSP.LE.1.) THEN   
11344             ROOT=SQRT(1.-EPSP)  
11345             IF(EPSP.GT.1.E-4) THEN  
11346               RLN=LOG((1.+ROOT)/(1.-ROOT))  
11347             ELSE    
11348               RLN=LOG(4./EPSP-2.)   
11349             ENDIF   
11350             PHIREP=0.25*(RLN**2-PARU(1)**2) 
11351             PHIIMP=0.5*PARU(1)*RLN  
11352             PSIREP=-(1.+0.5*ROOT*RLN)   
11353             PSIIMP=0.5*PARU(1)*ROOT 
11354           ELSE  
11355             PHIREP=-(ASIN(1./SQRT(EPSP)))**2    
11356             PHIIMP=0.   
11357             PSIREP=-(1.+SQRT(EPSP-1.)*ASIN(1./SQRT(EPSP)))  
11358             PSIIMP=0.   
11359           ENDIF 
11360           FXYRE=EPS*EPSP/(8.*(EPS-EPSP))*(1.-EPS*EPSP/(EPS-EPSP)*(PHIRE-    
11361      &    PHIREP)+2.*EPS/(EPS-EPSP)*(PSIRE-PSIREP)) 
11362           FXYIM=EPS*EPSP/(8.*(EPS-EPSP))*(-EPS*EPSP/(EPS-EPSP)*(PHIIM-  
11363      &    PHIIMP)+2.*EPS/(EPS-EPSP)*(PSIIM-PSIIMP)) 
11364           F1RE=EPS*EPSP/(2.*(EPS-EPSP))*(PHIRE-PHIREP)  
11365           F1IM=EPS*EPSP/(2.*(EPS-EPSP))*(PHIIM-PHIIMP)  
11366           IF(J.LE.2*MSTP(1)) THEN   
11367             ETARE=ETARE-3.*EJ*VJ*(FXYRE-0.25*F1RE)  
11368             ETAIM=ETAIM-3.*EJ*VJ*(FXYIM-0.25*F1IM)  
11369           ELSEIF(J.LE.3*MSTP(1)) THEN   
11370             ETARE=ETARE-EJ*VJ*(FXYRE-0.25*F1RE) 
11371             ETAIM=ETAIM-EJ*VJ*(FXYIM-0.25*F1IM) 
11372           ELSE  
11373             ETARE=ETARE-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-   
11374      &      (5.+2./EPS))*FXYRE+(3.-XW/SQRT(1.-XW))*F1RE)    
11375             ETAIM=ETAIM-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-   
11376      &      (5.+2./EPS))*FXYIM+(3.-XW/SQRT(1.-XW))*F1IM)    
11377           ENDIF 
11378   160     CONTINUE  
11379           ETA2=ETARE**2+ETAIM**2    
11380           WDTP(I)=(AEM/PARU(1))**2*(1.-(PMAS(23,1)/RMAS)**2)**3/XW*ETA2 
11381           WID2=WIDS(23,2)   
11382         ELSE    
11383 C...H0 -> Z0 + Z0, W+ + W-  

11384           WDTP(I)=(1.-4.*RM1+12.*RM1**2)*SQRT(MAX(0.,1.-4.*RM1))/   
11385      &    (2.*(18-I))   
11386           WID2=WIDS(7+I,1)  
11387         ENDIF   
11388         WDTP(0)=WDTP(0)+WDTP(I) 
11389         IF(MDME(IDC,1).GT.0) THEN   
11390           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
11391           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
11392           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
11393           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
11394         ENDIF   
11395   170   CONTINUE    
11396     
11397       ELSEIF(KFLA.EQ.32) THEN   
11398 C...Z'0:    

11399         EI=KCHG(IABS(MINT(15)),1)/3.  
11400         AI=SIGN(1.,EI)    
11401         VI=AI-4.*EI*XW    
11402         SQMZ=PMAS(23,1)**2    
11403         GZMZ=PMAS(23,2)*PMAS(23,1)    
11404         API=SIGN(1.,EI)   
11405         VPI=API-4.*EI*XW  
11406         SQMZP=PMAS(32,1)**2   
11407         GZPMZP=PMAS(32,2)*PMAS(32,1)  
11408         GGI=EI**2 
11409         GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/ 
11410      &  ((SQM-SQMZ)**2+GZMZ**2)   
11411         GZPI=EI*VPI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZP)/  
11412      &  ((SQM-SQMZP)**2+GZPMZP**2)    
11413         ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/ 
11414      &  ((SQM-SQMZ)**2+GZMZ**2)   
11415         ZZPI=2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*  
11416      &  SQM**2*((SQM-SQMZ)*(SQM-SQMZP)+GZMZ*GZPMZP)/  
11417      &  (((SQM-SQMZ)**2+GZMZ**2)*((SQM-SQMZP)**2+GZPMZP**2))  
11418         ZPZPI=(VPI**2+API**2)/(16.*XW*(1.-XW))**2*SQM**2/ 
11419      &  ((SQM-SQMZP)**2+GZPMZP**2)    
11420         IF(MINT(61).EQ.1) THEN
11421           IF(MSTP(44).EQ.1) THEN    
11422 C...Only gamma* production included 

11423             GZI=0.  
11424             GZPI=0. 
11425             ZZI=0.  
11426             ZZPI=0. 
11427             ZPZPI=0.    
11428           ELSEIF(MSTP(44).EQ.2) THEN    
11429 C...Only Z0 production included 

11430             GGI=0.  
11431             GZI=0.  
11432             GZPI=0. 
11433             ZZPI=0. 
11434             ZPZPI=0.    
11435           ELSEIF(MSTP(44).EQ.3) THEN    
11436 C...Only Z'0 production included    

11437             GGI=0. 
11438             GZI=0.  
11439             GZPI=0. 
11440             ZZI=0.  
11441             ZZPI=0. 
11442           ELSEIF(MSTP(44).EQ.4) THEN    
11443 C...Only gamma*/Z0 production included  

11444             GZPI=0. 
11445             ZZPI=0. 
11446             ZPZPI=0.    
11447           ELSEIF(MSTP(44).EQ.5) THEN    
11448 C...Only gamma*/Z'0 production included 

11449             GZI=0.  
11450             ZZI=0.  
11451             ZZPI=0. 
11452           ELSEIF(MSTP(44).EQ.6) THEN    
11453 C...Only Z0/Z'0 production included 

11454             GGI=0.  
11455             GZI=0.  
11456             GZPI=0. 
11457           ENDIF 
11458         ELSEIF(MINT(61).EQ.2) THEN  
11459           VINT(111)=0.  
11460           VINT(112)=0.  
11461           VINT(113)=0.  
11462           VINT(114)=0.  
11463           VINT(115)=0.  
11464           VINT(116)=0.  
11465         ENDIF   
11466         DO 180 I=1,MDCY(32,3)   
11467         IDC=I+MDCY(32,2)-1  
11468         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
11469         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
11470         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 180  
11471         IF(I.LE.8) THEN 
11472 C...Z'0 -> q + qb   

11473           EF=KCHG(I,1)/3.   
11474           AF=SIGN(1.,EF+0.1)    
11475           VF=AF-4.*EF*XW    
11476           APF=SIGN(1.,EF+0.1)   
11477           VPF=APF-4.*EF*XW  
11478           IF(MINT(61).EQ.0) THEN    
11479             WDTP(I)=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))* 
11480      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11481           ELSEIF(MINT(61).EQ.1) THEN    
11482             WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+ 
11483      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+   
11484      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))* 
11485      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11486           ELSEIF(MINT(61).EQ.2) THEN    
11487             GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
11488             GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC   
11489             GZPF=3.*EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC 
11490             ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*   
11491      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11492             ZZPF=3.*(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*    
11493      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11494             ZPZPF=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*   
11495      &      SQRT(MAX(0.,1.-4.*RM1))*RADC    
11496           ENDIF
11497           WID2=1.   
11498         ELSE    
11499 C...Z'0 -> l+ + l-, nu + nub    

11500           EF=KCHG(I+2,1)/3. 
11501           AF=SIGN(1.,EF+0.1)    
11502           VF=AF-4.*EF*XW    
11503 clin-4/2008 modified above a la pythia6115.f to avoid undefined variable API:

11504 c          APF=SIGN(1.,EF+0.1)   

11505 c          VPF=API-4.*EF*XW  

11506           IF(I.LE.10) THEN
11507              VPF=PARU(127-2*MOD(I,2))
11508              APF=PARU(128-2*MOD(I,2))
11509           ELSEIF(I.LE.12) THEN
11510              VPF=PARJ(186-2*MOD(I,2))
11511              APF=PARJ(187-2*MOD(I,2))
11512           ELSE
11513              VPF=PARJ(194-2*MOD(I,2))
11514              APF=PARJ(195-2*MOD(I,2))
11515           ENDIF
11516 clin-4/2008-end

11517           IF(MINT(61).EQ.0) THEN    
11518             WDTP(I)=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*    
11519      &      SQRT(MAX(0.,1.-4.*RM1)) 
11520           ELSEIF(MINT(61).EQ.1) THEN    
11521             WDTP(I)=((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+    
11522      &      ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+   
11523      &      ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))* 
11524      &      SQRT(MAX(0.,1.-4.*RM1)) 
11525           ELSEIF(MINT(61).EQ.2) THEN    
11526             GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
11527             GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))   
11528             GZPF=EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1)) 
11529             ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*  
11530      &      SQRT(MAX(0.,1.-4.*RM1)) 
11531             ZZPF=(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*   
11532      &      SQRT(MAX(0.,1.-4.*RM1)) 
11533             ZPZPF=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*  
11534      &      SQRT(MAX(0.,1.-4.*RM1))
11535           ENDIF 
11536           WID2=1.   
11537         ENDIF   
11538         WDTP(0)=WDTP(0)+WDTP(I) 
11539         IF(MDME(IDC,1).GT.0) THEN   
11540           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
11541           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
11542           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
11543           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
11544 clin-4/2008:

11545 c          VINT(111)=VINT(111)+GGF   

11546 c          VINT(112)=VINT(112)+GZF   

11547 c          VINT(113)=VINT(113)+GZPF  

11548 c          VINT(114)=VINT(114)+ZZF   

11549 c          VINT(115)=VINT(115)+ZZPF  

11550 c          VINT(116)=VINT(116)+ZPZPF 

11551           IF(MINT(61).EQ.2) THEN    
11552              VINT(111)=VINT(111)+GGF   
11553              VINT(112)=VINT(112)+GZF   
11554              VINT(113)=VINT(113)+GZPF  
11555              VINT(114)=VINT(114)+ZZF   
11556              VINT(115)=VINT(115)+ZZPF  
11557              VINT(116)=VINT(116)+ZPZPF 
11558           ENDIF
11559 clin-4/2008-end

11560         ENDIF   
11561   180   CONTINUE    
11562         IF(MSTP(44).EQ.1) THEN  
11563 C...Only gamma* production included 

11564           VINT(112)=0.  
11565           VINT(113)=0.  
11566           VINT(114)=0.  
11567           VINT(115)=0.  
11568           VINT(116)=0.  
11569         ELSEIF(MSTP(44).EQ.2) THEN  
11570 C...Only Z0 production included 

11571           VINT(111)=0.  
11572           VINT(112)=0.  
11573           VINT(113)=0.  
11574           VINT(115)=0.  
11575           VINT(116)=0.  
11576         ELSEIF(MSTP(44).EQ.3) THEN  
11577 C...Only Z'0 production included    

11578           VINT(111)=0.  
11579           VINT(112)=0.  
11580           VINT(113)=0.  
11581           VINT(114)=0.  
11582           VINT(115)=0.  
11583         ELSEIF(MSTP(44).EQ.4) THEN  
11584 C...Only gamma*/Z0 production included  

11585           VINT(113)=0.  
11586           VINT(115)=0.  
11587           VINT(116)=0.  
11588         ELSEIF(MSTP(44).EQ.5) THEN  
11589 C...Only gamma*/Z'0 production included 

11590           VINT(112)=0.  
11591           VINT(114)=0.  
11592           VINT(115)=0.  
11593         ELSEIF(MSTP(44).EQ.6) THEN  
11594 C...Only Z0/Z'0 production included 

11595           VINT(111)=0.  
11596           VINT(112)=0.  
11597           VINT(113)=0.  
11598         ENDIF   
11599     
11600       ELSEIF(KFLA.EQ.37) THEN   
11601 C...H+/-:   

11602         DO 190 I=1,MDCY(37,3)   
11603         IDC=I+MDCY(37,2)-1  
11604         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
11605         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
11606         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 190  
11607         IF(I.LE.4) THEN 
11608 C...H+/- -> q + qb' 

11609           WDTP(I)=3.*((RM1*PARU(121)+RM2/PARU(121))*    
11610      &    (1.-RM1-RM2)-4.*RM1*RM2)* 
11611      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*RADC 
11612           WID2=1.   
11613         ELSE    
11614 C...H+/- -> l+/- + nu   

11615           WDTP(I)=((RM1*PARU(121)+RM2/PARU(121))*   
11616      &    (1.-RM1-RM2)-4.*RM1*RM2)* 
11617      &    SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))  
11618           WID2=1.   
11619         ENDIF   
11620         WDTP(0)=WDTP(0)+WDTP(I) 
11621         IF(MDME(IDC,1).GT.0) THEN   
11622           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
11623           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
11624           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
11625           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
11626         ENDIF   
11627   190   CONTINUE    
11628     
11629       ELSEIF(KFLA.EQ.40) THEN   
11630 C...R:  

11631         DO 200 I=1,MDCY(40,3)   
11632         IDC=I+MDCY(40,2)-1  
11633         RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2 
11634         RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2 
11635         IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 200  
11636         IF(I.LE.4) THEN 
11637 C...R -> q + qb'    

11638           WDTP(I)=3.*RADC   
11639           WID2=1.   
11640         ELSE    
11641 C...R -> l+ + l'-   

11642           WDTP(I)=1.    
11643           WID2=1.   
11644         ENDIF   
11645         WDTP(0)=WDTP(0)+WDTP(I) 
11646         IF(MDME(IDC,1).GT.0) THEN   
11647           WDTE(I,MDME(IDC,1))=WDTP(I)*WID2  
11648           WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))   
11649           WDTE(I,0)=WDTE(I,MDME(IDC,1)) 
11650           WDTE(0,0)=WDTE(0,0)+WDTE(I,0) 
11651         ENDIF   
11652   200   CONTINUE    
11653     
11654       ENDIF 
11655       MINT(61)=0    
11656     
11657       RETURN    
11658       END   
11659     
11660 C***********************************************************************    

11661     
11662       SUBROUTINE PYKLIM(ILIM)   
11663     
11664 C...Checks generated variables against pre-set kinematical limits;  

11665 C...also calculates limits on variables used in generation. 

11666       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
11667       SAVE /LUDAT1/ 
11668       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
11669       SAVE /LUDAT2/ 
11670       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
11671       SAVE /LUDAT3/ 
11672       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
11673       SAVE /PYPARS/ 
11674       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
11675       SAVE /PYSUBS/ 
11676       COMMON/PYINT1/MINT(400),VINT(400) 
11677       SAVE /PYINT1/ 
11678       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
11679       SAVE /PYINT2/ 
11680     
11681 C...Common kinematical expressions. 

11682       ISUB=MINT(1)  
11683       IF(ISUB.EQ.96) GOTO 110   
11684       SQM3=VINT(63) 
11685       SQM4=VINT(64) 
11686       IF(ILIM.NE.1) THEN    
11687         TAU=VINT(21)    
11688         RM3=SQM3/(TAU*VINT(2))  
11689         RM4=SQM4/(TAU*VINT(2))  
11690         BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)   
11691       ENDIF 
11692       PTHMIN=CKIN(3)    
11693       IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) PTHMIN=MAX(CKIN(3),CKIN(5))  
11694       IF(ILIM.EQ.0) THEN    
11695 C...Check generated values of tau, y*, cos(theta-hat), and tau' against 

11696 C...pre-set kinematical limits. 

11697         YST=VINT(22)    
11698         CTH=VINT(23)    
11699         TAUP=VINT(26)   
11700         IF(ISET(ISUB).LE.2) THEN    
11701           X1=SQRT(TAU)*EXP(YST) 
11702           X2=SQRT(TAU)*EXP(-YST)    
11703         ELSE    
11704           X1=SQRT(TAUP)*EXP(YST)    
11705           X2=SQRT(TAUP)*EXP(-YST)   
11706         ENDIF   
11707         XF=X1-X2    
11708         IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1    
11709         IF(CKIN(2).GE.0..AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1  
11710         IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1 
11711         IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1 
11712         IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1 
11713         IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1 
11714         IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN 
11715           PTH=0.5*BE34*SQRT(TAU*VINT(2)*(1.-CTH**2))    
11716           Y3=YST+0.5*LOG((1.+RM3-RM4+BE34*CTH)/(1.+RM3-RM4-BE34*CTH))   
11717           Y4=YST+0.5*LOG((1.+RM4-RM3-BE34*CTH)/(1.+RM4-RM3+BE34*CTH))   
11718           YLARGE=MAX(Y3,Y4) 
11719           YSMALL=MIN(Y3,Y4) 
11720           ETALAR=10.    
11721           ETASMA=-10.   
11722           STH=SQRT(1.-CTH**2)   
11723           IF(STH.LT.1.E-6) GOTO 100 
11724           EXPET3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+    
11725      &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3))/ 
11726      &    (BE34*STH)    
11727           EXPET4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+    
11728      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4))/ 
11729      &    (BE34*STH)    
11730           ETA3=LOG(MIN(1.E10,MAX(1.E-10,EXPET3)))   
11731           ETA4=LOG(MIN(1.E10,MAX(1.E-10,EXPET4)))   
11732           ETALAR=MAX(ETA3,ETA4) 
11733           ETASMA=MIN(ETA3,ETA4) 
11734   100     CTS3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/ 
11735      &    SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3)   
11736           CTS4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/ 
11737      &    SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4)   
11738           CTSLAR=MAX(CTS3,CTS4) 
11739           CTSSMA=MIN(CTS3,CTS4) 
11740           IF(PTH.LT.PTHMIN) MINT(51)=1  
11741           IF(CKIN(4).GE.0..AND.PTH.GT.CKIN(4)) MINT(51)=1   
11742           IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1    
11743           IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1   
11744           IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1   
11745           IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1   
11746           IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1   
11747           IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1   
11748           IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1 
11749         ENDIF   
11750         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN 
11751           IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1    
11752           IF(CKIN(32).GE.0..AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1 
11753         ENDIF   
11754     
11755       ELSEIF(ILIM.EQ.1) THEN    
11756 C...Calculate limits on tau 

11757 C...0) due to definition    

11758         TAUMN0=0.   
11759         TAUMX0=1.   
11760 C...1) due to limits on subsystem mass  

11761         TAUMN1=CKIN(1)**2/VINT(2)   
11762         TAUMX1=1.   
11763         IF(CKIN(2).GE.0.) TAUMX1=CKIN(2)**2/VINT(2) 
11764 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) 

11765         TM3=SQRT(SQM3+PTHMIN**2)    
11766         TM4=SQRT(SQM4+PTHMIN**2)    
11767         YDCOSH=1.   
11768         IF(CKIN(9).GT.CKIN(12)) YDCOSH=COSH(CKIN(9)-CKIN(12))   
11769         TAUMN2=(TM3**2+2.*TM3*TM4*YDCOSH+TM4**2)/VINT(2)    
11770         TAUMX2=1.   
11771 C...3) due to limits on pT-hat and cos(theta-hat)   

11772         CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2) 
11773         CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2) 
11774         TAUMN3=0.   
11775         IF(CKIN(27)*CKIN(28).GT.0.) TAUMN3= 
11776      &  (SQRT(SQM3+PTHMIN**2/(1.-CTH2MN))+  
11777      &  SQRT(SQM4+PTHMIN**2/(1.-CTH2MN)))**2/VINT(2)    
11778         TAUMX3=1.   
11779         IF(CKIN(4).GE.0..AND.CTH2MX.LT.1.) TAUMX3=  
11780      &  (SQRT(SQM3+CKIN(4)**2/(1.-CTH2MX))+ 
11781      &  SQRT(SQM4+CKIN(4)**2/(1.-CTH2MX)))**2/VINT(2)   
11782 C...4) due to limits on x1 and x2   

11783         TAUMN4=CKIN(21)*CKIN(23)    
11784         TAUMX4=CKIN(22)*CKIN(24)    
11785 C...5) due to limits on xF  

11786         TAUMN5=0.   
11787         TAUMX5=MAX(1.-CKIN(25),1.+CKIN(26)) 
11788         VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5) 
11789         VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5) 
11790         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN 
11791           VINT(11)=0.99999  
11792           VINT(31)=1.00001  
11793         ENDIF   
11794         IF(VINT(31).LE.VINT(11)) MINT(51)=1 
11795     
11796       ELSEIF(ILIM.EQ.2) THEN    
11797 C...Calculate limits on y*  

11798         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) TAU=VINT(26) 
11799         TAURT=SQRT(TAU) 
11800 C...0) due to kinematics    

11801         YSTMN0=LOG(TAURT)   
11802         YSTMX0=-YSTMN0  
11803 C...1) due to explicit limits   

11804         YSTMN1=CKIN(7)  
11805         YSTMX1=CKIN(8)  
11806 C...2) due to limits on x1  

11807         YSTMN2=LOG(MAX(TAU,CKIN(21))/TAURT) 
11808         YSTMX2=LOG(MAX(TAU,CKIN(22))/TAURT) 
11809 C...3) due to limits on x2  

11810         YSTMN3=-LOG(MAX(TAU,CKIN(24))/TAURT)    
11811         YSTMX3=-LOG(MAX(TAU,CKIN(23))/TAURT)    
11812 C...4) due to limits on xF  

11813         YEPMN4=0.5*ABS(CKIN(25))/TAURT  
11814         YSTMN4=SIGN(LOG(SQRT(1.+YEPMN4**2)+YEPMN4),CKIN(25))    
11815         YEPMX4=0.5*ABS(CKIN(26))/TAURT  
11816         YSTMX4=SIGN(LOG(SQRT(1.+YEPMX4**2)+YEPMX4),CKIN(26))    
11817 C...5) due to simultaneous limits on y-large and y-small    

11818         YEPSMN=(RM3-RM4)*SINH(CKIN(9)-CKIN(11)) 
11819         YEPSMX=(RM3-RM4)*SINH(CKIN(10)-CKIN(12))    
11820         YDIFMN=ABS(LOG(SQRT(1.+YEPSMN**2)-YEPSMN))  
11821         YDIFMX=ABS(LOG(SQRT(1.+YEPSMX**2)-YEPSMX))  
11822         YSTMN5=0.5*(CKIN(9)+CKIN(11)-YDIFMN)    
11823         YSTMX5=0.5*(CKIN(10)+CKIN(12)+YDIFMX)   
11824 C...6) due to simultaneous limits on cos(theta-hat) and y-large or  

11825 C...   y-small  

11826         CTHLIM=SQRT(1.-4.*PTHMIN**2/(BE34*TAU*VINT(2))) 
11827         RZMN=BE34*MAX(CKIN(27),-CTHLIM) 
11828         RZMX=BE34*MIN(CKIN(28),CTHLIM)  
11829         YEX3MX=(1.+RM3-RM4+RZMX)/MAX(1E-10,1.+RM3-RM4-RZMX) 
11830         YEX4MX=(1.+RM4-RM3-RZMN)/MAX(1E-10,1.+RM4-RM3+RZMN) 
11831         YEX3MN=MAX(1E-10,1.+RM3-RM4+RZMN)/(1.+RM3-RM4-RZMN) 
11832         YEX4MN=MAX(1E-10,1.+RM4-RM3-RZMX)/(1.+RM4-RM3+RZMX) 
11833         YSTMN6=CKIN(9)-0.5*LOG(MAX(YEX3MX,YEX4MX))  
11834         YSTMX6=CKIN(12)-0.5*LOG(MIN(YEX3MN,YEX4MN)) 
11835         VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)  
11836         VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)  
11837         IF(MINT(43).EQ.1) THEN  
11838           VINT(12)=-0.00001 
11839           VINT(32)=0.00001  
11840         ELSEIF(MINT(43).EQ.2) THEN  
11841           VINT(12)=0.99999*YSTMX0   
11842           VINT(32)=1.00001*YSTMX0   
11843         ELSEIF(MINT(43).EQ.3) THEN  
11844           VINT(12)=-1.00001*YSTMX0  
11845           VINT(32)=-0.99999*YSTMX0  
11846         ENDIF   
11847         IF(VINT(32).LE.VINT(12)) MINT(51)=1 
11848     
11849       ELSEIF(ILIM.EQ.3) THEN    
11850 C...Calculate limits on cos(theta-hat)  

11851         YST=VINT(22)    
11852 C...0) due to definition    

11853         CTNMN0=-1.  
11854         CTNMX0=0.   
11855         CTPMN0=0.   
11856         CTPMX0=1.   
11857 C...1) due to explicit limits   

11858         CTNMN1=MIN(0.,CKIN(27)) 
11859         CTNMX1=MIN(0.,CKIN(28)) 
11860         CTPMN1=MAX(0.,CKIN(27)) 
11861         CTPMX1=MAX(0.,CKIN(28)) 
11862 C...2) due to limits on pT-hat  

11863         CTNMN2=-SQRT(1.-4.*PTHMIN**2/(BE34**2*TAU*VINT(2))) 
11864         CTPMX2=-CTNMN2  
11865         CTNMX2=0.   
11866         CTPMN2=0.   
11867         IF(CKIN(4).GE.0.) THEN  
11868           CTNMX2=-SQRT(MAX(0.,1.-4.*CKIN(4)**2/(BE34**2*TAU*VINT(2))))  
11869           CTPMN2=-CTNMX2    
11870         ENDIF   
11871 C...3) due to limits on y-large and y-small 

11872         CTNMN3=MIN(0.,MAX((1.+RM3-RM4)/BE34*TANH(CKIN(11)-YST), 
11873      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(10)-YST))) 
11874         CTNMX3=MIN(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(12)-YST), 
11875      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(9)-YST))   
11876         CTPMN3=MAX(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(9)-YST),  
11877      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(12)-YST))  
11878         CTPMX3=MAX(0.,MIN((1.+RM3-RM4)/BE34*TANH(CKIN(10)-YST), 
11879      &  -(1.-RM3+RM4)/BE34*TANH(CKIN(11)-YST))) 
11880         VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3)   
11881         VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3)   
11882         VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3)   
11883         VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3)   
11884         IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1    
11885     
11886       ELSEIF(ILIM.EQ.4) THEN    
11887 C...Calculate limits on tau'    

11888 C...0) due to kinematics    

11889 cms.. reinitializing tau due to compiler warning        

11890         TAU=VINT(21)
11891         TAPMN0=TAU  
11892         TAPMX0=1.   
11893 C...1) due to explicit limits   

11894         TAPMN1=CKIN(31)**2/VINT(2)  
11895         TAPMX1=1.   
11896         IF(CKIN(32).GE.0.) TAPMX1=CKIN(32)**2/VINT(2)   
11897         VINT(16)=MAX(TAPMN0,TAPMN1) 
11898         VINT(36)=MIN(TAPMX0,TAPMX1) 
11899         IF(MINT(43).EQ.1) THEN  
11900           VINT(16)=0.99999  
11901           VINT(36)=1.00001  
11902         ENDIF   
11903         IF(VINT(36).LE.VINT(16)) MINT(51)=1 
11904     
11905       ENDIF 
11906       RETURN    
11907     
11908 C...Special case for low-pT and multiple interactions:  

11909 C...effective kinematical limits for tau, y*, cos(theta-hat).   

11910   110 IF(ILIM.EQ.0) THEN    
11911       ELSEIF(ILIM.EQ.1) THEN    
11912         IF(MSTP(82).LE.1) VINT(11)=4.*PARP(81)**2/VINT(2)   
11913         IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)  
11914         VINT(31)=1. 
11915       ELSEIF(ILIM.EQ.2) THEN    
11916         VINT(12)=0.5*LOG(VINT(21))  
11917         VINT(32)=-VINT(12)  
11918       ELSEIF(ILIM.EQ.3) THEN    
11919         IF(MSTP(82).LE.1) ST2EFF=4.*PARP(81)**2/(VINT(21)*VINT(2))  
11920         IF(MSTP(82).GE.2) ST2EFF=0.01*PARP(82)**2/(VINT(21)*VINT(2))    
11921         VINT(13)=-SQRT(MAX(0.,1.-ST2EFF))   
11922         VINT(33)=0. 
11923         VINT(14)=0. 
11924         VINT(34)=-VINT(13)  
11925       ENDIF 
11926     
11927       RETURN    
11928       END   
11929     
11930 C*********************************************************************  

11931     
11932       SUBROUTINE PYKMAP(IVAR,MVAR,VVAR) 
11933     
11934 C...Maps a uniform distribution into a distribution of a kinematical    

11935 C...variable according to one of the possibilities allowed. It is   

11936 C...assumed that kinematical limits have been set by a PYKLIM call. 

11937       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
11938       SAVE /LUDAT2/ 
11939       COMMON/PYINT1/MINT(400),VINT(400) 
11940       SAVE /PYINT1/ 
11941       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
11942       SAVE /PYINT2/ 
11943     
11944 C...Convert VVAR to tau variable.   

11945       ISUB=MINT(1)  
11946       IF(IVAR.EQ.1) THEN    
11947         TAUMIN=VINT(11) 
11948         TAUMAX=VINT(31) 
11949         IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN 
11950           TAURE=VINT(73)    
11951           GAMRE=VINT(74)    
11952         ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN 
11953           TAURE=VINT(75)    
11954           GAMRE=VINT(76)    
11955         ELSE
11956 cms..   needed re-initialization to avoid compiler warning

11957           TAURE=VINT(75)
11958           GAMRE=VINT(76)
11959         ENDIF   
11960         IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN 
11961           TAU=1.    
11962         ELSEIF(MVAR.EQ.1) THEN  
11963           TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR  
11964         ELSEIF(MVAR.EQ.2) THEN  
11965           TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)   
11966         ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN 
11967           RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX    
11968           TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN) 
11969         ELSE    
11970           AUPP=ATAN((TAUMAX-TAURE)/GAMRE)   
11971           ALOW=ATAN((TAUMIN-TAURE)/GAMRE)   
11972           TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)    
11973         ENDIF   
11974         VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))    
11975 
11976 C...Convert VVAR to y* variable.    

11977       ELSEIF(IVAR.EQ.2) THEN    
11978         YSTMIN=VINT(12) 
11979         YSTMAX=VINT(32) 
11980         IF(MINT(43).EQ.1) THEN  
11981           YST=0.    
11982         ELSEIF(MINT(43).EQ.2) THEN  
11983           IF(ISET(ISUB).LE.2) YST=-0.5*LOG(VINT(21))    
11984           IF(ISET(ISUB).GE.3) YST=-0.5*LOG(VINT(26))    
11985         ELSEIF(MINT(43).EQ.3) THEN  
11986           IF(ISET(ISUB).LE.2) YST=0.5*LOG(VINT(21)) 
11987           IF(ISET(ISUB).GE.3) YST=0.5*LOG(VINT(26)) 
11988         ELSEIF(MVAR.EQ.1) THEN  
11989           YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR) 
11990         ELSEIF(MVAR.EQ.2) THEN  
11991           YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1.-VVAR)  
11992         ELSE    
11993           AUPP=ATAN(EXP(YSTMAX))    
11994           ALOW=ATAN(EXP(YSTMIN))    
11995           YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))   
11996         ENDIF   
11997         VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))    
11998     
11999 C...Convert VVAR to cos(theta-hat) variable.    

12000       ELSEIF(IVAR.EQ.3) THEN    
12001         RM34=2.*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2 
12002         RSQM=1.+RM34    
12003         IF(2.*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001) RM34=MAX(RM34,  
12004      &  2.*VINT(71)**2/(VINT(21)*VINT(2)))  
12005         CTNMIN=VINT(13) 
12006         CTNMAX=VINT(33) 
12007         CTPMIN=VINT(14) 
12008         CTPMAX=VINT(34) 
12009         IF(MVAR.EQ.1) THEN  
12010           ANEG=CTNMAX-CTNMIN    
12011           APOS=CTPMAX-CTPMIN    
12012           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
12013             VCTN=VVAR*(ANEG+APOS)/ANEG  
12014             CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN 
12015           ELSE  
12016             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
12017             CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP 
12018           ENDIF 
12019         ELSEIF(MVAR.EQ.2) THEN  
12020           RMNMIN=MAX(RM34,RSQM-CTNMIN)  
12021           RMNMAX=MAX(RM34,RSQM-CTNMAX)  
12022           RMPMIN=MAX(RM34,RSQM-CTPMIN)  
12023           RMPMAX=MAX(RM34,RSQM-CTPMAX)  
12024           ANEG=LOG(RMNMIN/RMNMAX)   
12025           APOS=LOG(RMPMIN/RMPMAX)   
12026           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
12027             VCTN=VVAR*(ANEG+APOS)/ANEG  
12028             CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN   
12029           ELSE  
12030             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
12031             CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP   
12032           ENDIF 
12033         ELSEIF(MVAR.EQ.3) THEN  
12034           RMNMIN=MAX(RM34,RSQM+CTNMIN)  
12035           RMNMAX=MAX(RM34,RSQM+CTNMAX)  
12036           RMPMIN=MAX(RM34,RSQM+CTPMIN)  
12037           RMPMAX=MAX(RM34,RSQM+CTPMAX)  
12038           ANEG=LOG(RMNMAX/RMNMIN)   
12039           APOS=LOG(RMPMAX/RMPMIN)   
12040           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
12041             VCTN=VVAR*(ANEG+APOS)/ANEG  
12042             CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM   
12043           ELSE  
12044             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
12045             CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM   
12046           ENDIF 
12047         ELSEIF(MVAR.EQ.4) THEN  
12048           RMNMIN=MAX(RM34,RSQM-CTNMIN)  
12049           RMNMAX=MAX(RM34,RSQM-CTNMAX)  
12050           RMPMIN=MAX(RM34,RSQM-CTPMIN)  
12051           RMPMAX=MAX(RM34,RSQM-CTPMAX)  
12052           ANEG=1./RMNMAX-1./RMNMIN  
12053           APOS=1./RMPMAX-1./RMPMIN  
12054           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
12055             VCTN=VVAR*(ANEG+APOS)/ANEG  
12056             CTH=RSQM-1./(1./RMNMIN+ANEG*VCTN)   
12057           ELSE  
12058             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
12059             CTH=RSQM-1./(1./RMPMIN+APOS*VCTP)   
12060           ENDIF 
12061         ELSEIF(MVAR.EQ.5) THEN  
12062           RMNMIN=MAX(RM34,RSQM+CTNMIN)  
12063           RMNMAX=MAX(RM34,RSQM+CTNMAX)  
12064           RMPMIN=MAX(RM34,RSQM+CTPMIN)  
12065           RMPMAX=MAX(RM34,RSQM+CTPMAX)  
12066           ANEG=1./RMNMIN-1./RMNMAX  
12067           APOS=1./RMPMIN-1./RMPMAX  
12068           IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN  
12069             VCTN=VVAR*(ANEG+APOS)/ANEG  
12070             CTH=1./(1./RMNMIN-ANEG*VCTN)-RSQM   
12071           ELSE  
12072             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS   
12073             CTH=1./(1./RMPMIN-APOS*VCTP)-RSQM   
12074           ENDIF
12075         ELSE
12076 cms ...  needed to avoid compiler warning - should do nothing

12077           CTH=CTNMIN
12078         ENDIF   
12079         IF(CTH.LT.0.) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))   
12080         IF(CTH.GT.0.) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))   
12081         VINT(23)=CTH    
12082     
12083 C...Convert VVAR to tau' variable.  

12084       ELSEIF(IVAR.EQ.4) THEN    
12085         TAU=VINT(11)    
12086         TAUPMN=VINT(16) 
12087         TAUPMX=VINT(36) 
12088         IF(MINT(43).EQ.1) THEN  
12089           TAUP=1.   
12090         ELSEIF(MVAR.EQ.1) THEN  
12091           TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR 
12092         ELSE    
12093           AUPP=(1.-TAU/TAUPMX)**4   
12094           ALOW=(1.-TAU/TAUPMN)**4   
12095           TAUP=TAU/(1.-(ALOW+(AUPP-ALOW)*VVAR)**0.25)   
12096         ENDIF   
12097         VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))   
12098       ENDIF 
12099     
12100       RETURN    
12101       END   
12102     
12103 C***********************************************************************    

12104     
12105       SUBROUTINE PYSIGH(NCHN,SIGS)  
12106     
12107 C...Differential matrix elements for all included subprocesses. 

12108 C...Note that what is coded is (disregarding the COMFAC factor) 

12109 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,  

12110 C...when d(sigma-hat) is given in the zero-width limit, the delta   

12111 C...function in tau is replaced by a Breit-Wigner:  

12112 C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);   

12113 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);   

12114 C...i.e., dimensionless quantities. COMFAC contains the factor  

12115 C...pi/s and the conversion factor from GeV^-2 to mb.   

12116       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
12117       SAVE /LUDAT1/ 
12118       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
12119       SAVE /LUDAT2/ 
12120       COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)    
12121       SAVE /LUDAT3/ 
12122       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
12123       SAVE /PYSUBS/ 
12124       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
12125       SAVE /PYPARS/ 
12126       COMMON/PYINT1/MINT(400),VINT(400) 
12127       SAVE /PYINT1/ 
12128       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
12129       SAVE /PYINT2/ 
12130       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
12131       SAVE /PYINT3/ 
12132       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
12133       SAVE /AMPTPYINT4/ 
12134       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
12135       SAVE /PYINT5/ 
12136       DIMENSION X(2),XPQ(-6:6),KFAC(2,-40:40),WDTP(0:40),WDTE(0:40,0:5) 
12137 
12138 C...Reset number of channels and cross-section. 

12139       NCHN=0    
12140       SIGS=0.   
12141     
12142 C...Read kinematical variables and limits.  

12143       ISUB=MINT(1)  
12144       TAUMIN=VINT(11)   
12145       YSTMIN=VINT(12)   
12146       CTNMIN=VINT(13)   
12147       CTPMIN=VINT(14)   
12148       XT2MIN=VINT(15)   
12149       TAUPMN=VINT(16)   
12150       TAU=VINT(21)  
12151       YST=VINT(22)  
12152       CTH=VINT(23)  
12153       XT2=VINT(25)  
12154       TAUP=VINT(26) 
12155       TAUMAX=VINT(31)   
12156       YSTMAX=VINT(32)   
12157       CTNMAX=VINT(33)   
12158       CTPMAX=VINT(34)   
12159       XT2MAX=VINT(35)   
12160       TAUPMX=VINT(36)   
12161 
12162 C...Common conversion factors (including Jacobian) for subprocesses.    

12163 cms.. rearranged to avoid compiler warnings

12164       SQMZ=PMAS(23,1)**2    
12165       GMMZ=PMAS(23,1)*PMAS(23,2)    
12166       SQMW=PMAS(24,1)**2    
12167       GMMW=PMAS(24,1)*PMAS(24,2)    
12168       SQMH=PMAS(25,1)**2    
12169       GMMH=PMAS(25,1)*PMAS(25,2)    
12170       SQMZP=PMAS(32,1)**2   
12171       GMMZP=PMAS(32,1)*PMAS(32,2)   
12172       SQMHC=PMAS(37,1)**2   
12173       GMMHC=PMAS(37,1)*PMAS(37,2)   
12174       SQMR=PMAS(40,1)**2    
12175       GMMR=PMAS(40,1)*PMAS(40,2)    
12176       AEM=PARU(101) 
12177       XW=PARU(102)   
12178       MIN1=0    
12179       MAX1=0    
12180       MIN2=0    
12181       MAX2=0 
12182       MINA=MIN(MIN1,MIN2)   
12183       MAXA=MAX(MAX1,MAX2) 
12184       FACA=1.
12185       COMFAC=PARU(1)*PARU(5)/VINT(2)
12186       AS=ULALPS(Q2)
12187 
12188 C...Derive kinematical quantities.  

12189       IF(ISET(ISUB).LE.2.OR.ISET(ISUB).EQ.5) THEN   
12190         X(1)=SQRT(TAU)*EXP(YST) 
12191         X(2)=SQRT(TAU)*EXP(-YST)    
12192       ELSE  
12193         X(1)=SQRT(TAUP)*EXP(YST)    
12194         X(2)=SQRT(TAUP)*EXP(-YST)   
12195       ENDIF 
12196       IF(MINT(43).EQ.4.AND.ISET(ISUB).GE.1.AND. 
12197      &(X(1).GT.0.999.OR.X(2).GT.0.999)) RETURN  
12198       SH=TAU*VINT(2)    
12199       SQM3=VINT(63) 
12200       SQM4=VINT(64) 
12201       RM3=SQM3/SH   
12202       RM4=SQM4/SH   
12203       BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4) 
12204       RPTS=4.*VINT(71)**2/SH    
12205       BE34L=SQRT(MAX(0.,(1.-RM3-RM4)**2-4.*RM3*RM4-RPTS))   
12206       RM34=2.*RM3*RM4   
12207       RSQM=1.+RM34  
12208       RTHM=(4.*RM3*RM4+RPTS)/(1.-RM3-RM4+BE34L) 
12209       TH=-0.5*SH*MAX(RTHM,1.-RM3-RM4-BE34*CTH)  
12210       UH=-0.5*SH*MAX(RTHM,1.-RM3-RM4+BE34*CTH)  
12211       SQPTH=0.25*SH*BE34**2*(1.-CTH**2) 
12212       SH2=SH**2 
12213       TH2=TH**2 
12214       UH2=UH**2 
12215     
12216 C...Choice of Q2 scale. 

12217       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN   
12218         Q2=SH   
12219       ELSEIF(MOD(ISET(ISUB),2).EQ.0.OR.ISET(ISUB).EQ.5) THEN    
12220         IF(MSTP(32).EQ.1) THEN  
12221           Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)    
12222         ELSEIF(MSTP(32).EQ.2) THEN  
12223           Q2=SQPTH+0.5*(SQM3+SQM4)  
12224         ELSEIF(MSTP(32).EQ.3) THEN  
12225           Q2=MIN(-TH,-UH)   
12226         ELSEIF(MSTP(32).EQ.4) THEN  
12227           Q2=SH 
12228         ENDIF   
12229         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2=Q2+PARP(82)**2 
12230       ENDIF 
12231     
12232 C...Store derived kinematical quantities.   

12233       VINT(41)=X(1) 
12234       VINT(42)=X(2) 
12235       VINT(44)=SH   
12236       VINT(43)=SQRT(SH) 
12237       VINT(45)=TH   
12238       VINT(46)=UH   
12239       VINT(48)=SQPTH    
12240       VINT(47)=SQRT(SQPTH)  
12241       VINT(50)=TAUP*VINT(2) 
12242       VINT(49)=SQRT(MAX(0.,VINT(50)))   
12243       VINT(52)=Q2   
12244       VINT(51)=SQRT(Q2) 
12245     
12246 C...Calculate parton structure functions.   

12247       IF(ISET(ISUB).LE.0) GOTO 145  
12248       IF(MINT(43).GE.2) THEN    
12249         Q2SF=Q2 
12250         IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN 
12251           Q2SF=PMAS(23,1)**2    
12252           IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2SF=PMAS(24,1)**2  
12253         ENDIF   
12254         DO 100 I=3-MINT(41),MINT(42)    
12255         XSF=X(I)    
12256         IF(ISET(ISUB).EQ.5) XSF=X(I)/VINT(142+I)    
12257         CALL PYSTFU(MINT(10+I),XSF,Q2SF,XPQ,I)    
12258         DO 100 KFL=-6,6 
12259   100   XSFX(I,KFL)=XPQ(KFL)
12260       ENDIF 
12261     
12262 C...Calculate alpha_strong and K-factor.    

12263       IF(MSTP(33).NE.3) AS=ULALPS(Q2)   
12264       FACK=1.   
12265       FACA=1.   
12266       IF(MSTP(33).EQ.1) THEN    
12267         FACK=PARP(31)   
12268       ELSEIF(MSTP(33).EQ.2) THEN    
12269         FACK=PARP(31)   
12270         FACA=PARP(32)/PARP(31)  
12271       ELSEIF(MSTP(33).EQ.3) THEN    
12272         Q2AS=PARP(33)*Q2    
12273         IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2AS=Q2AS+    
12274      &  PARU(112)*PARP(82)  
12275         AS=ULALPS(Q2AS) 
12276       ENDIF 
12277       RADC=1.+AS/PARU(1)    
12278     
12279 C...Set flags for allowed reacting partons/leptons. 

12280       DO 130 I=1,2  
12281       DO 110 J=-40,40   
12282   110 KFAC(I,J)=0   
12283       IF(MINT(40+I).EQ.1) THEN  
12284         KFAC(I,MINT(10+I))=1    
12285       ELSE  
12286         DO 120 J=-40,40 
12287         KFAC(I,J)=KFIN(I,J) 
12288         IF(ABS(J).GT.MSTP(54).AND.J.NE.21) KFAC(I,J)=0  
12289         IF(ABS(J).LE.6) THEN    
12290           IF(XSFX(I,J).LT.1.E-10) KFAC(I,J)=0   
12291         ELSEIF(J.EQ.21) THEN    
12292           IF(XSFX(I,0).LT.1.E-10) KFAC(I,21)=0  
12293         ENDIF   
12294   120   CONTINUE    
12295       ENDIF 
12296   130 CONTINUE  
12297     
12298 C...Lower and upper limit for flavour loops.    

12299       DO 140 J=-20,20   
12300       IF(KFAC(1,-J).EQ.1) MIN1=-J   
12301       IF(KFAC(1,J).EQ.1) MAX1=J 
12302       IF(KFAC(2,-J).EQ.1) MIN2=-J   
12303       IF(KFAC(2,J).EQ.1) MAX2=J 
12304   140 CONTINUE  
12305       MINA=MIN(MIN1,MIN2)   
12306       MAXA=MAX(MAX1,MAX2)   
12307     
12308 C...Phase space integral in tau and y*. 

12309       COMFAC=PARU(1)*PARU(5)/VINT(2)    
12310       IF(MINT(43).EQ.4) COMFAC=COMFAC*FACK  
12311       IF((MINT(43).GE.2.OR.ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4).AND. 
12312      &ISET(ISUB).NE.5) THEN 
12313         ATAU0=LOG(TAUMAX/TAUMIN)    
12314         ATAU1=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)   
12315         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/TAU  
12316         IF(MINT(72).GE.1) THEN  
12317           TAUR1=VINT(73)    
12318           GAMR1=VINT(74)    
12319           ATAU2=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1  
12320           ATAU3=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/    
12321      &    GAMR1 
12322           H1=H1+(ATAU0/ATAU2)*COEF(ISUB,3)/(TAU+TAUR1)+ 
12323      &    (ATAU0/ATAU3)*COEF(ISUB,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)  
12324         ENDIF   
12325         IF(MINT(72).EQ.2) THEN  
12326           TAUR2=VINT(75)    
12327           GAMR2=VINT(76)    
12328           ATAU4=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2  
12329           ATAU5=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/    
12330      &    GAMR2 
12331           H1=H1+(ATAU0/ATAU4)*COEF(ISUB,5)/(TAU+TAUR2)+ 
12332      &    (ATAU0/ATAU5)*COEF(ISUB,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)  
12333         ENDIF   
12334         COMFAC=COMFAC*ATAU0/(TAU*H1)    
12335       ENDIF 
12336       IF(MINT(43).EQ.4.AND.ISET(ISUB).NE.5) THEN    
12337         AYST0=YSTMAX-YSTMIN 
12338         AYST1=0.5*(YSTMAX-YSTMIN)**2    
12339         AYST2=AYST1 
12340         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))  
12341         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST2)*   
12342      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)  
12343         COMFAC=COMFAC*AYST0/H2  
12344       ENDIF 
12345     
12346 C...2 -> 1 processes: reduction in angular part of phase space integral 

12347 C...for case of decaying resonance. 

12348       ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN 
12349 clin-4/2008 modified a la pythia6115.f to avoid invalid MDCY subcript#1,

12350 c     also break up compound IF statements:

12351 c      IF((ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3).AND.  

12352 c     &MDCY(KFPR(ISUB,1),1).EQ.1) THEN   

12353 c        IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN   

12354 c          COMFAC=COMFAC*0.5*ACTH0   

12355 c        ELSE    

12356 c          COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+    

12357 c     &    CTPMAX**3-CTPMIN**3)  

12358 c        ENDIF   

12359       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12360          if(MDCY(LUCOMP(KFPR(ISUB,1)),1).EQ.1) then
12361             IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN   
12362                COMFAC=COMFAC*0.5*ACTH0   
12363             ELSE    
12364                COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+    
12365      &              CTPMAX**3-CTPMIN**3)  
12366             ENDIF
12367          endif
12368 c

12369 C...2 -> 2 processes: angular part of phase space integral. 

12370       ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN   
12371         ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/    
12372      &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))  
12373         ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/    
12374      &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))  
12375         ACTH3=1./MAX(RM34,RSQM-CTNMAX)-1./MAX(RM34,RSQM-CTNMIN)+    
12376      &  1./MAX(RM34,RSQM-CTPMAX)-1./MAX(RM34,RSQM-CTPMIN)   
12377         ACTH4=1./MAX(RM34,RSQM+CTNMIN)-1./MAX(RM34,RSQM+CTNMAX)+    
12378      &  1./MAX(RM34,RSQM+CTPMIN)-1./MAX(RM34,RSQM+CTPMAX)   
12379         H3=COEF(ISUB,10)+   
12380      &  (ACTH0/ACTH1)*COEF(ISUB,11)/MAX(RM34,RSQM-CTH)+ 
12381      &  (ACTH0/ACTH2)*COEF(ISUB,12)/MAX(RM34,RSQM+CTH)+ 
12382      &  (ACTH0/ACTH3)*COEF(ISUB,13)/MAX(RM34,RSQM-CTH)**2+  
12383      &  (ACTH0/ACTH4)*COEF(ISUB,14)/MAX(RM34,RSQM+CTH)**2   
12384         COMFAC=COMFAC*ACTH0*0.5*BE34/H3 
12385       ENDIF 
12386     
12387 C...2 -> 3, 4 processes: phace space integral in tau'.  

12388       IF(MINT(43).GE.2.AND.(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4)) THEN   
12389         ATAUP0=LOG(TAUPMX/TAUPMN)   
12390         ATAUP1=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU) 
12391         H4=COEF(ISUB,15)+   
12392      &  ATAUP0/ATAUP1*COEF(ISUB,16)/TAUP*(1.-TAU/TAUP)**3   
12393         IF(1.-TAU/TAUP.GT.1.E-4) THEN   
12394           FZW=(1.+TAU/TAUP)*LOG(TAUP/TAU)-2.*(1.-TAU/TAUP)  
12395         ELSE    
12396           FZW=1./6.*(1.-TAU/TAUP)**3*TAU/TAUP   
12397         ENDIF   
12398         COMFAC=COMFAC*ATAUP0*FZW/H4 
12399       ENDIF 
12400     
12401 C...Phase space integral for low-pT and multiple interactions.  

12402       IF(ISET(ISUB).EQ.5) THEN  
12403         COMFAC=PARU(1)*PARU(5)*FACK*0.5*VINT(2)/SH2 
12404         ATAU0=LOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)  
12405         ATAU1=2.*ATAN(1./XT2-1.)/SQRT(XT2)  
12406         H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/SQRT(TAU)    
12407         COMFAC=COMFAC*ATAU0/H1  
12408         AYST0=YSTMAX-YSTMIN 
12409         AYST1=0.5*(YSTMAX-YSTMIN)**2    
12410         AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))  
12411         H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST1)*   
12412      &  COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)  
12413         COMFAC=COMFAC*AYST0/H2  
12414         IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1./VINT(149)-1.)    
12415 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is 

12416 C...introduced to make cross-section finite for xT2 -> 0.   

12417         IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*  
12418      &  (1.+VINT(149))) 
12419       ENDIF 
12420     
12421 C...A: 2 -> 1, tree diagrams.   

12422     
12423   145 IF(ISUB.LE.10) THEN   
12424       IF(ISUB.EQ.1) THEN    
12425 C...f + fb -> gamma*/Z0.    

12426         MINT(61)=2  
12427         CALL PYWIDT(23,SQRT(SH),WDTP,WDTE)  
12428         FACZ=COMFAC*AEM**2*4./3.    
12429         DO 150 I=MINA,MAXA  
12430         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150    
12431         EI=KCHG(IABS(I),1)/3.   
12432         AI=SIGN(1.,EI)  
12433         VI=AI-4.*EI*XW  
12434         FACF=1. 
12435         IF(IABS(I).LE.10) FACF=FACA/3.  
12436         NCHN=NCHN+1 
12437         ISIG(NCHN,1)=I  
12438         ISIG(NCHN,2)=-I 
12439         ISIG(NCHN,3)=1  
12440         SIGH(NCHN)=FACF*FACZ*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*    
12441      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+(VI**2+AI**2)/    
12442      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*VINT(114))   
12443   150   CONTINUE    
12444     
12445       ELSEIF(ISUB.EQ.2) THEN    
12446 C...f + fb' -> W+/-.    

12447         CALL PYWIDT(24,SQRT(SH),WDTP,WDTE)  
12448         FACW=COMFAC*(AEM/XW)**2*1./24*SH2/((SH-SQMW)**2+GMMW**2)    
12449         DO 170 I=MIN1,MAX1  
12450         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 170   
12451         IA=IABS(I)  
12452         DO 160 J=MIN2,MAX2  
12453         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 160   
12454         JA=IABS(J)  
12455         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160  
12456         IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) GOTO 160 
12457         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
12458         FACF=1. 
12459         IF(IA.LE.10) FACF=VCKM((IA+1)/2,(JA+1)/2)*FACA/3.   
12460         NCHN=NCHN+1 
12461         ISIG(NCHN,1)=I  
12462         ISIG(NCHN,2)=J  
12463         ISIG(NCHN,3)=1  
12464         SIGH(NCHN)=FACF*FACW*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))   
12465   160   CONTINUE    
12466   170   CONTINUE    
12467     
12468       ELSEIF(ISUB.EQ.3) THEN    
12469 C...f + fb -> H0.   

12470         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
12471         FACH=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*    
12472      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))  
12473         DO 180 I=MINA,MAXA  
12474         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180    
12475         RMQ=PMAS(IABS(I),1)**2/SH   
12476         NCHN=NCHN+1 
12477         ISIG(NCHN,1)=I  
12478         ISIG(NCHN,2)=-I 
12479         ISIG(NCHN,3)=1  
12480         SIGH(NCHN)=FACH*RMQ*SQRT(MAX(0.,1.-4.*RMQ)) 
12481   180   CONTINUE    
12482     
12483       ELSEIF(ISUB.EQ.4) THEN    
12484 C...gamma + W+/- -> W+/-.   

12485     
12486       ELSEIF(ISUB.EQ.5) THEN    
12487 C...Z0 + Z0 -> H0.  

12488         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
12489         FACH=COMFAC*1./(128.*PARU(1)**2*16.*(1.-XW)**3)*(AEM/XW)**4*    
12490      &  (SH/SQMW)**2*SH2/((SH-SQMH)**2+GMMH**2)*    
12491      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) 
12492         DO 200 I=MIN1,MAX1  
12493         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200   
12494         DO 190 J=MIN2,MAX2  
12495         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190   
12496         EI=KCHG(IABS(I),1)/3.   
12497         AI=SIGN(1.,EI)  
12498         VI=AI-4.*EI*XW  
12499         EJ=KCHG(IABS(J),1)/3.   
12500         AJ=SIGN(1.,EJ)  
12501         VJ=AJ-4.*EJ*XW  
12502         NCHN=NCHN+1 
12503         ISIG(NCHN,1)=I  
12504         ISIG(NCHN,2)=J  
12505         ISIG(NCHN,3)=1  
12506         SIGH(NCHN)=FACH*(VI**2+AI**2)*(VJ**2+AJ**2) 
12507   190   CONTINUE    
12508   200   CONTINUE    
12509     
12510       ELSEIF(ISUB.EQ.6) THEN    
12511 C...Z0 + W+/- -> W+/-.  

12512     
12513       ELSEIF(ISUB.EQ.7) THEN    
12514 C...W+ + W- -> Z0.  

12515     
12516       ELSEIF(ISUB.EQ.8) THEN    
12517 C...W+ + W- -> H0.  

12518         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
12519         FACH=COMFAC*1./(128*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*   
12520      &  SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))  
12521         DO 220 I=MIN1,MAX1  
12522         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 220   
12523         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)    
12524         DO 210 J=MIN2,MAX2  
12525         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 210   
12526         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)    
12527         IF(EI*EJ.GT.0.) GOTO 210    
12528         NCHN=NCHN+1 
12529         ISIG(NCHN,1)=I  
12530         ISIG(NCHN,2)=J  
12531         ISIG(NCHN,3)=1  
12532         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J) 
12533   210   CONTINUE    
12534   220   CONTINUE    
12535       ENDIF 
12536     
12537 C...B: 2 -> 2, tree diagrams.   

12538     
12539       ELSEIF(ISUB.LE.20) THEN   
12540       IF(ISUB.EQ.11) THEN   
12541 C...f + f' -> f + f'.   

12542         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2 
12543         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-  
12544      &  MSTP(34)*2./3.*UH2/(SH*TH)) 
12545         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-   
12546      &  MSTP(34)*2./3.*SH2/(TH*UH)) 
12547         DO 240 I=MIN1,MAX1  
12548         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240   
12549         DO 230 J=MIN2,MAX2  
12550         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230   
12551         NCHN=NCHN+1 
12552         ISIG(NCHN,1)=I  
12553         ISIG(NCHN,2)=J  
12554         ISIG(NCHN,3)=1  
12555         SIGH(NCHN)=FACQQ1   
12556         IF(I.EQ.-J) SIGH(NCHN)=FACQQB   
12557         IF(I.EQ.J) THEN 
12558           SIGH(NCHN)=0.5*SIGH(NCHN) 
12559           NCHN=NCHN+1   
12560           ISIG(NCHN,1)=I    
12561           ISIG(NCHN,2)=J    
12562           ISIG(NCHN,3)=2    
12563           SIGH(NCHN)=0.5*FACQQ2 
12564         ENDIF   
12565   230   CONTINUE    
12566   240   CONTINUE    
12567     
12568       ELSEIF(ISUB.EQ.12) THEN   
12569 C...f + fb -> f' + fb' (q + qb -> q' + qb' only).   

12570         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)  
12571         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+   
12572      &  WDTE(0,3)+WDTE(0,4))    
12573         DO 250 I=MINA,MAXA  
12574         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 250    
12575         NCHN=NCHN+1 
12576         ISIG(NCHN,1)=I  
12577         ISIG(NCHN,2)=-I 
12578         ISIG(NCHN,3)=1  
12579         SIGH(NCHN)=FACQQB   
12580   250   CONTINUE    
12581     
12582       ELSEIF(ISUB.EQ.13) THEN   
12583 C...f + fb -> g + g (q + qb -> g + g only). 

12584         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2) 
12585         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2) 
12586         DO 260 I=MINA,MAXA  
12587         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260    
12588         NCHN=NCHN+1 
12589         ISIG(NCHN,1)=I  
12590         ISIG(NCHN,2)=-I 
12591         ISIG(NCHN,3)=1  
12592         SIGH(NCHN)=0.5*FACGG1   
12593         NCHN=NCHN+1 
12594         ISIG(NCHN,1)=I  
12595         ISIG(NCHN,2)=-I 
12596         ISIG(NCHN,3)=2  
12597         SIGH(NCHN)=0.5*FACGG2   
12598   260   CONTINUE    
12599     
12600       ELSEIF(ISUB.EQ.14) THEN   
12601 C...f + fb -> g + gamma (q + qb -> g + gamma only). 

12602         FACGG=COMFAC*AS*AEM*8./9.*(TH2+UH2)/(TH*UH) 
12603         DO 270 I=MINA,MAXA  
12604         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270    
12605         EI=KCHG(IABS(I),1)/3.   
12606         NCHN=NCHN+1 
12607         ISIG(NCHN,1)=I  
12608         ISIG(NCHN,2)=-I 
12609         ISIG(NCHN,3)=1  
12610         SIGH(NCHN)=FACGG*EI**2  
12611   270   CONTINUE    
12612     
12613       ELSEIF(ISUB.EQ.15) THEN   
12614 C...f + fb -> g + Z0 (q + qb -> g + Z0 only).   

12615         FACZG=COMFAC*AS*AEM/(XW*(1.-XW))*1./18.*    
12616      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)    
12617         FACZG=FACZG*WIDS(23,2)  
12618         DO 280 I=MINA,MAXA  
12619         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280    
12620         EI=KCHG(IABS(I),1)/3.   
12621         AI=SIGN(1.,EI)  
12622         VI=AI-4.*EI*XW  
12623         NCHN=NCHN+1 
12624         ISIG(NCHN,1)=I  
12625         ISIG(NCHN,2)=-I 
12626         ISIG(NCHN,3)=1  
12627         SIGH(NCHN)=FACZG*(VI**2+AI**2)  
12628   280   CONTINUE    
12629     
12630       ELSEIF(ISUB.EQ.16) THEN   
12631 C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only). 

12632         FACWG=COMFAC*AS*AEM/XW*2./9.*(TH2+UH2+2.*SQM4*SH)/(TH*UH)   
12633         DO 300 I=MIN1,MAX1  
12634         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300   
12635         IA=IABS(I)  
12636         DO 290 J=MIN2,MAX2  
12637         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290   
12638         JA=IABS(J)  
12639         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290  
12640         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
12641         FCKM=1. 
12642         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
12643         NCHN=NCHN+1 
12644         ISIG(NCHN,1)=I  
12645         ISIG(NCHN,2)=J  
12646         ISIG(NCHN,3)=1  
12647         SIGH(NCHN)=FACWG*FCKM*WIDS(24,(5-KCHW)/2)   
12648   290   CONTINUE    
12649   300   CONTINUE    
12650     
12651       ELSEIF(ISUB.EQ.17) THEN   
12652 C...f + fb -> g + H0 (q + qb -> g + H0 only).   

12653     
12654       ELSEIF(ISUB.EQ.18) THEN   
12655 C...f + fb -> gamma + gamma.    

12656         FACGG=COMFAC*FACA*AEM**2*1./3.*(TH2+UH2)/(TH*UH)    
12657         DO 310 I=MINA,MAXA  
12658         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310    
12659         EI=KCHG(IABS(I),1)/3.   
12660         NCHN=NCHN+1 
12661         ISIG(NCHN,1)=I  
12662         ISIG(NCHN,2)=-I 
12663         ISIG(NCHN,3)=1  
12664         SIGH(NCHN)=FACGG*EI**4  
12665   310   CONTINUE    
12666     
12667       ELSEIF(ISUB.EQ.19) THEN   
12668 C...f + fb -> gamma + Z0.   

12669         FACGZ=COMFAC*FACA*AEM**2/(XW*(1.-XW))*1./24.*   
12670      &  (TH2+UH2+2.*SQM4*SH)/(TH*UH)    
12671         FACGZ=FACGZ*WIDS(23,2)  
12672         DO 320 I=MINA,MAXA  
12673         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320    
12674         EI=KCHG(IABS(I),1)/3.   
12675         AI=SIGN(1.,EI)  
12676         VI=AI-4.*EI*XW  
12677         NCHN=NCHN+1 
12678         ISIG(NCHN,1)=I  
12679         ISIG(NCHN,2)=-I 
12680         ISIG(NCHN,3)=1  
12681         SIGH(NCHN)=FACGZ*EI**2*(VI**2+AI**2)    
12682   320   CONTINUE    
12683     
12684       ELSEIF(ISUB.EQ.20) THEN   
12685 C...f + fb' -> gamma + W+/-.    

12686         FACGW=COMFAC*FACA*AEM**2/XW*1./6.*  
12687      &  ((2.*UH-TH)/(3.*(SH-SQM4)))**2*(TH2+UH2+2.*SQM4*SH)/(TH*UH) 
12688         DO 340 I=MIN1,MAX1  
12689         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340   
12690         IA=IABS(I)  
12691         DO 330 J=MIN2,MAX2  
12692         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330   
12693         JA=IABS(J)  
12694         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 330  
12695         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
12696         FCKM=1. 
12697         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
12698         NCHN=NCHN+1 
12699         ISIG(NCHN,1)=I  
12700         ISIG(NCHN,2)=J  
12701         ISIG(NCHN,3)=1  
12702         SIGH(NCHN)=FACGW*FCKM*WIDS(24,(5-KCHW)/2)   
12703   330   CONTINUE    
12704   340   CONTINUE    
12705       ENDIF 
12706     
12707       ELSEIF(ISUB.LE.30) THEN   
12708       IF(ISUB.EQ.21) THEN   
12709 C...f + fb -> gamma + H0.   

12710     
12711       ELSEIF(ISUB.EQ.22) THEN   
12712 C...f + fb -> Z0 + Z0.  

12713         FACZZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./768.*    
12714      &  (UH/TH+TH/UH+2.*(SQM3+SQM4)*SH/(TH*UH)- 
12715      &  SQM3*SQM4*(1./TH2+1./UH2))  
12716         FACZZ=FACZZ*WIDS(23,1)  
12717         DO 350 I=MINA,MAXA  
12718         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350    
12719         EI=KCHG(IABS(I),1)/3.   
12720         AI=SIGN(1.,EI)  
12721         VI=AI-4.*EI*XW  
12722         NCHN=NCHN+1 
12723         ISIG(NCHN,1)=I  
12724         ISIG(NCHN,2)=-I 
12725         ISIG(NCHN,3)=1  
12726         SIGH(NCHN)=FACZZ*(VI**4+6.*VI**2*AI**2+AI**4)   
12727   350   CONTINUE    
12728     
12729       ELSEIF(ISUB.EQ.23) THEN   
12730 C...f + fb' -> Z0 + W+/-.   

12731         FACZW=COMFAC*FACA*(AEM/XW)**2*1./6. 
12732         FACZW=FACZW*WIDS(23,2)  
12733         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
12734         DO 370 I=MIN1,MAX1  
12735         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370   
12736         IA=IABS(I)  
12737         DO 360 J=MIN2,MAX2  
12738         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360   
12739         JA=IABS(J)  
12740         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360  
12741         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
12742         EI=KCHG(IA,1)/3.    
12743         AI=SIGN(1.,EI)  
12744         VI=AI-4.*EI*XW  
12745         EJ=KCHG(JA,1)/3.    
12746         AJ=SIGN(1.,EJ)  
12747         VJ=AJ-4.*EJ*XW  
12748         IF(VI+AI.GT.0) THEN 
12749           VISAV=VI  
12750           AISAV=AI  
12751           VI=VJ 
12752           AI=AJ 
12753           VJ=VISAV  
12754           AJ=AISAV  
12755         ENDIF   
12756         FCKM=1. 
12757         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
12758         NCHN=NCHN+1 
12759         ISIG(NCHN,1)=I  
12760         ISIG(NCHN,2)=J  
12761         ISIG(NCHN,3)=1  
12762         SIGH(NCHN)=FACZW*FCKM*(1./(SH-SQMW)**2* 
12763      &  ((9.-8.*XW)/4.*THUH+(8.*XW-6.)/4.*SH*(SQM3+SQM4))+  
12764      &  (THUH-SH*(SQM3+SQM4))/(2.*(SH-SQMW))*((VJ+AJ)/TH-(VI+AI)/UH)+   
12765      &  THUH/(16.*(1.-XW))*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+ 
12766      &  SH*(SQM3+SQM4)/(8.*(1.-XW))*(VI+AI)*(VJ+AJ)/(TH*UH))*   
12767      &  WIDS(24,(5-KCHW)/2) 
12768   360   CONTINUE    
12769   370   CONTINUE    
12770     
12771       ELSEIF(ISUB.EQ.24) THEN   
12772 C...f + fb -> Z0 + H0.  

12773         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
12774         FACHZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./96.* 
12775      &  (THUH+2.*SH*SQMZ)/(SH-SQMZ)**2  
12776         FACHZ=FACHZ*WIDS(23,2)*WIDS(25,2)   
12777         DO 380 I=MINA,MAXA  
12778         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380    
12779         EI=KCHG(IABS(I),1)/3.   
12780         AI=SIGN(1.,EI)  
12781         VI=AI-4.*EI*XW  
12782         NCHN=NCHN+1 
12783         ISIG(NCHN,1)=I  
12784         ISIG(NCHN,2)=-I 
12785         ISIG(NCHN,3)=1  
12786         SIGH(NCHN)=FACHZ*(VI**2+AI**2)  
12787   380   CONTINUE    
12788     
12789       ELSEIF(ISUB.EQ.25) THEN   
12790 C...f + fb -> W+ + W-.  

12791         FACWW=COMFAC*FACA*(AEM/XW)**2*1./12.    
12792         FACWW=FACWW*WIDS(24,1)  
12793         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
12794         DO 390 I=MINA,MAXA  
12795         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390    
12796         EI=KCHG(IABS(I),1)/3.   
12797         AI=SIGN(1.,EI)  
12798         VI=AI-4.*EI*XW  
12799         DSIGWW=THUH/SH2*(3.-(SH-3.*(SQM3+SQM4))/(SH-SQMZ)*  
12800      &  (VI+AI)/(2.*AI*(1.-XW))+(SH/(SH-SQMZ))**2*  
12801      &  (1.-2.*(SQM3+SQM4)/SH+12.*SQM3*SQM4/SH2)*(VI**2+AI**2)/ 
12802      &  (8.*(1.-XW)**2))-2.*SQMZ/(SH-SQMZ)*(VI+AI)/AI+  
12803      &  SQMZ*SH/(SH-SQMZ)**2*(1.-2.*(SQM3+SQM4)/SH)*(VI**2+AI**2)/  
12804      &  (2.*(1.-XW))    
12805         IF(KCHG(IABS(I),1).LT.0) THEN   
12806           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))* 
12807      &    (THUH/(SH*TH)-(SQM3+SQM4)/TH)+THUH/TH2    
12808         ELSE    
12809           DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))* 
12810      &    (THUH/(SH*UH)-(SQM3+SQM4)/UH)+THUH/UH2    
12811         ENDIF   
12812         NCHN=NCHN+1 
12813         ISIG(NCHN,1)=I  
12814         ISIG(NCHN,2)=-I 
12815         ISIG(NCHN,3)=1  
12816         SIGH(NCHN)=FACWW*DSIGWW 
12817   390   CONTINUE    
12818     
12819       ELSEIF(ISUB.EQ.26) THEN   
12820 C...f + fb' -> W+/- + H0.   

12821         THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) 
12822         FACHW=COMFAC*FACA*(AEM/XW)**2*1./24.*(THUH+2.*SH*SQMW)/ 
12823      &  (SH-SQMW)**2    
12824         FACHW=FACHW*WIDS(25,2)  
12825         DO 410 I=MIN1,MAX1  
12826         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410   
12827         IA=IABS(I)  
12828         DO 400 J=MIN2,MAX2  
12829         IF(J.EQ.0.OR.KFAC(1,J).EQ.0) GOTO 400   
12830         JA=IABS(J)  
12831         IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400  
12832         KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3    
12833         FCKM=1. 
12834         IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)  
12835         NCHN=NCHN+1 
12836         ISIG(NCHN,1)=I  
12837         ISIG(NCHN,2)=J  
12838         ISIG(NCHN,3)=1  
12839         SIGH(NCHN)=FACHW*FCKM*WIDS(24,(5-KCHW)/2)   
12840   400   CONTINUE    
12841   410   CONTINUE    
12842     
12843       ELSEIF(ISUB.EQ.27) THEN   
12844 C...f + fb -> H0 + H0.  

12845     
12846       ELSEIF(ISUB.EQ.28) THEN   
12847 C...f + g -> f + g (q + g -> q + g only).   

12848         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*  
12849      &  FACA    
12850         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)   
12851         DO 430 I=MINA,MAXA  
12852         IF(I.EQ.0) GOTO 430 
12853         DO 420 ISDE=1,2 
12854         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420    
12855         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420    
12856         NCHN=NCHN+1 
12857         ISIG(NCHN,ISDE)=I   
12858         ISIG(NCHN,3-ISDE)=21    
12859         ISIG(NCHN,3)=1  
12860         SIGH(NCHN)=FACQG1   
12861         NCHN=NCHN+1 
12862         ISIG(NCHN,ISDE)=I   
12863         ISIG(NCHN,3-ISDE)=21    
12864         ISIG(NCHN,3)=2  
12865         SIGH(NCHN)=FACQG2   
12866   420   CONTINUE    
12867   430   CONTINUE    
12868     
12869       ELSEIF(ISUB.EQ.29) THEN   
12870 C...f + g -> f + gamma (q + g -> q + gamma only).   

12871         FGQ=COMFAC*FACA*AS*AEM*1./3.*(SH2+UH2)/(-SH*UH) 
12872         DO 450 I=MINA,MAXA  
12873         IF(I.EQ.0) GOTO 450 
12874         EI=KCHG(IABS(I),1)/3.   
12875         FACGQ=FGQ*EI**2 
12876         DO 440 ISDE=1,2 
12877         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 440    
12878         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 440    
12879         NCHN=NCHN+1 
12880         ISIG(NCHN,ISDE)=I   
12881         ISIG(NCHN,3-ISDE)=21    
12882         ISIG(NCHN,3)=1  
12883         SIGH(NCHN)=FACGQ    
12884   440   CONTINUE    
12885   450   CONTINUE    
12886     
12887       ELSEIF(ISUB.EQ.30) THEN   
12888 C...f + g -> f + Z0 (q + g -> q + Z0 only). 

12889         FZQ=COMFAC*FACA*AS*AEM/(XW*(1.-XW))*1./48.* 
12890      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)   
12891         FZQ=FZQ*WIDS(23,2)  
12892         DO 470 I=MINA,MAXA  
12893         IF(I.EQ.0) GOTO 470 
12894         EI=KCHG(IABS(I),1)/3.   
12895         AI=SIGN(1.,EI)  
12896         VI=AI-4.*EI*XW  
12897         FACZQ=FZQ*(VI**2+AI**2) 
12898         DO 460 ISDE=1,2 
12899         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 460    
12900         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 460    
12901         NCHN=NCHN+1 
12902         ISIG(NCHN,ISDE)=I   
12903         ISIG(NCHN,3-ISDE)=21    
12904         ISIG(NCHN,3)=1  
12905         SIGH(NCHN)=FACZQ    
12906   460   CONTINUE    
12907   470   CONTINUE    
12908       ENDIF 
12909     
12910       ELSEIF(ISUB.LE.40) THEN   
12911       IF(ISUB.EQ.31) THEN   
12912 C...f + g -> f' + W+/- (q + g -> q' + W+/- only).   

12913         FACWQ=COMFAC*FACA*AS*AEM/XW*1./12.* 
12914      &  (SH2+UH2+2.*SQM4*TH)/(-SH*UH)   
12915         DO 490 I=MINA,MAXA  
12916         IF(I.EQ.0) GOTO 490 
12917         IA=IABS(I)  
12918         KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) 
12919         DO 480 ISDE=1,2 
12920         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 480    
12921         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 480    
12922         NCHN=NCHN+1 
12923         ISIG(NCHN,ISDE)=I   
12924         ISIG(NCHN,3-ISDE)=21    
12925         ISIG(NCHN,3)=1  
12926         SIGH(NCHN)=FACWQ*VINT(180+I)*WIDS(24,(5-KCHW)/2)    
12927   480   CONTINUE    
12928   490   CONTINUE    
12929     
12930       ELSEIF(ISUB.EQ.32) THEN   
12931 C...f + g -> f + H0 (q + g -> q + H0 only). 

12932     
12933       ELSEIF(ISUB.EQ.33) THEN   
12934 C...f + gamma -> f + g (q + gamma -> q + g only).   

12935     
12936       ELSEIF(ISUB.EQ.34) THEN   
12937 C...f + gamma -> f + gamma. 

12938     
12939       ELSEIF(ISUB.EQ.35) THEN   
12940 C...f + gamma -> f + Z0.    

12941     
12942       ELSEIF(ISUB.EQ.36) THEN   
12943 C...f + gamma -> f' + W+/-. 

12944     
12945       ELSEIF(ISUB.EQ.37) THEN   
12946 C...f + gamma -> f + H0.    

12947     
12948       ELSEIF(ISUB.EQ.38) THEN   
12949 C...f + Z0 -> f + g (q + Z0 -> q + g only). 

12950     
12951       ELSEIF(ISUB.EQ.39) THEN   
12952 C...f + Z0 -> f + gamma.    

12953     
12954       ELSEIF(ISUB.EQ.40) THEN   
12955 C...f + Z0 -> f + Z0.   

12956       ENDIF 
12957     
12958       ELSEIF(ISUB.LE.50) THEN   
12959       IF(ISUB.EQ.41) THEN   
12960 C...f + Z0 -> f' + W+/-.    

12961     
12962       ELSEIF(ISUB.EQ.42) THEN   
12963 C...f + Z0 -> f + H0.   

12964     
12965       ELSEIF(ISUB.EQ.43) THEN   
12966 C...f + W+/- -> f' + g (q + W+/- -> q' + g only).   

12967     
12968       ELSEIF(ISUB.EQ.44) THEN   
12969 C...f + W+/- -> f' + gamma. 

12970     
12971       ELSEIF(ISUB.EQ.45) THEN   
12972 C...f + W+/- -> f' + Z0.    

12973     
12974       ELSEIF(ISUB.EQ.46) THEN   
12975 C...f + W+/- -> f' + W+/-.  

12976     
12977       ELSEIF(ISUB.EQ.47) THEN   
12978 C...f + W+/- -> f' + H0.    

12979     
12980       ELSEIF(ISUB.EQ.48) THEN   
12981 C...f + H0 -> f + g (q + H0 -> q + g only). 

12982     
12983       ELSEIF(ISUB.EQ.49) THEN   
12984 C...f + H0 -> f + gamma.    

12985     
12986       ELSEIF(ISUB.EQ.50) THEN   
12987 C...f + H0 -> f + Z0.   

12988       ENDIF 
12989     
12990       ELSEIF(ISUB.LE.60) THEN   
12991       IF(ISUB.EQ.51) THEN   
12992 C...f + H0 -> f' + W+/-.    

12993     
12994       ELSEIF(ISUB.EQ.52) THEN   
12995 C...f + H0 -> f + H0.   

12996     
12997       ELSEIF(ISUB.EQ.53) THEN   
12998 C...g + g -> f + fb (g + g -> q + qb only). 

12999         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)  
13000         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*  
13001      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
13002         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*  
13003      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
13004         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500 
13005         NCHN=NCHN+1 
13006         ISIG(NCHN,1)=21 
13007         ISIG(NCHN,2)=21 
13008         ISIG(NCHN,3)=1  
13009         SIGH(NCHN)=FACQQ1   
13010         NCHN=NCHN+1 
13011         ISIG(NCHN,1)=21 
13012         ISIG(NCHN,2)=21 
13013         ISIG(NCHN,3)=2  
13014         SIGH(NCHN)=FACQQ2   
13015   500   CONTINUE    
13016     
13017       ELSEIF(ISUB.EQ.54) THEN   
13018 C...g + gamma -> f + fb (g + gamma -> q + qb only). 

13019     
13020       ELSEIF(ISUB.EQ.55) THEN   
13021 C...g + gamma -> f + fb (g + gamma -> q + qb only). 

13022     
13023       ELSEIF(ISUB.EQ.56) THEN   
13024 C...g + gamma -> f + fb (g + gamma -> q + qb only). 

13025     
13026       ELSEIF(ISUB.EQ.57) THEN   
13027 C...g + gamma -> f + fb (g + gamma -> q + qb only). 

13028     
13029       ELSEIF(ISUB.EQ.58) THEN   
13030 C...gamma + gamma -> f + fb.    

13031     
13032       ELSEIF(ISUB.EQ.59) THEN   
13033 C...gamma + Z0 -> f + fb.   

13034     
13035       ELSEIF(ISUB.EQ.60) THEN   
13036 C...gamma + W+/- -> f + fb'.    

13037       ENDIF 
13038     
13039       ELSEIF(ISUB.LE.70) THEN   
13040       IF(ISUB.EQ.61) THEN   
13041 C...gamma + H0 -> f + fb.   

13042     
13043       ELSEIF(ISUB.EQ.62) THEN   
13044 C...Z0 + Z0 -> f + fb.  

13045     
13046       ELSEIF(ISUB.EQ.63) THEN   
13047 C...Z0 + W+/- -> f + fb'.   

13048     
13049       ELSEIF(ISUB.EQ.64) THEN   
13050 C...Z0 + H0 -> f + fb.  

13051     
13052       ELSEIF(ISUB.EQ.65) THEN   
13053 C...W+ + W- -> f + fb.  

13054     
13055       ELSEIF(ISUB.EQ.66) THEN   
13056 C...W+/- + H0 -> f + fb'.   

13057     
13058       ELSEIF(ISUB.EQ.67) THEN   
13059 C...H0 + H0 -> f + fb.  

13060     
13061       ELSEIF(ISUB.EQ.68) THEN   
13062 C...g + g -> g + g. 

13063         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+    
13064      &  TH2/SH2)*FACA   
13065         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+    
13066      &  SH2/UH2)*FACA   
13067         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2) 
13068         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510 
13069         NCHN=NCHN+1 
13070         ISIG(NCHN,1)=21 
13071         ISIG(NCHN,2)=21 
13072         ISIG(NCHN,3)=1  
13073         SIGH(NCHN)=0.5*FACGG1   
13074         NCHN=NCHN+1 
13075         ISIG(NCHN,1)=21 
13076         ISIG(NCHN,2)=21 
13077         ISIG(NCHN,3)=2  
13078         SIGH(NCHN)=0.5*FACGG2   
13079         NCHN=NCHN+1 
13080         ISIG(NCHN,1)=21 
13081         ISIG(NCHN,2)=21 
13082         ISIG(NCHN,3)=3  
13083         SIGH(NCHN)=0.5*FACGG3   
13084   510   CONTINUE    
13085     
13086       ELSEIF(ISUB.EQ.69) THEN   
13087 C...gamma + gamma -> W+ + W-.   

13088     
13089       ELSEIF(ISUB.EQ.70) THEN   
13090 C...gamma + W+/- -> gamma + W+/-.   

13091       ENDIF 
13092     
13093       ELSEIF(ISUB.LE.80) THEN   
13094       IF(ISUB.EQ.71) THEN   
13095 C...Z0 + Z0 -> Z0 + Z0. 

13096         BE2=1.-4.*SQMZ/SH   
13097         TH=-0.5*SH*BE2*(1.-CTH) 
13098         UH=-0.5*SH*BE2*(1.+CTH) 
13099         SHANG=1./(1.-XW)*SQMW/SQMZ*(1.+BE2)**2  
13100         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
13101         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
13102         THANG=1./(1.-XW)*SQMW/SQMZ*(BE2-CTH)**2 
13103         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG    
13104         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG    
13105         UHANG=1./(1.-XW)*SQMW/SQMZ*(BE2+CTH)**2 
13106         AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG    
13107         AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG    
13108         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*   
13109      &  (AEM/XW)**4*(SH/SQMW)**2*((ASHRE+ATHRE+AUHRE)**2+   
13110      &  (ASHIM+ATHIM+AUHIM)**2)*SQMZ/SQMW   
13111         DO 530 I=MIN1,MAX1  
13112         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530   
13113         EI=KCHG(IABS(I),1)/3.   
13114         AI=SIGN(1.,EI)  
13115         VI=AI-4.*EI*XW  
13116         AVI=AI**2+VI**2 
13117         DO 520 J=MIN2,MAX2  
13118         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520   
13119         EJ=KCHG(IABS(J),1)/3.   
13120         AJ=SIGN(1.,EJ)  
13121         VJ=AJ-4.*EJ*XW  
13122         AVJ=AJ**2+VJ**2 
13123         NCHN=NCHN+1 
13124         ISIG(NCHN,1)=I  
13125         ISIG(NCHN,2)=J  
13126         ISIG(NCHN,3)=1  
13127         SIGH(NCHN)=FACH*AVI*AVJ 
13128   520   CONTINUE    
13129   530   CONTINUE    
13130     
13131       ELSEIF(ISUB.EQ.72) THEN   
13132 C...Z0 + Z0 -> W+ + W-. 

13133         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))   
13134         CTH2=CTH**2 
13135         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)   
13136         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)   
13137         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)* 
13138      &  (1.-2.*SQMZ/SH) 
13139         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
13140         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
13141         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-    
13142      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
13143      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
13144      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))   
13145         ATWIM=0.    
13146         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-    
13147      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
13148      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
13149      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))   
13150         AUWIM=0.    
13151         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)    
13152         A4IM=0. 
13153         FACH=COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*(AEM/XW)**4*   
13154      &  (SH/SQMW)**2*((ASHRE+ATWRE+AUWRE+A4RE)**2+  
13155      &  (ASHIM+ATWIM+AUWIM+A4IM)**2)*SQMZ/SQMW  
13156         DO 550 I=MIN1,MAX1  
13157         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 550   
13158         EI=KCHG(IABS(I),1)/3.   
13159         AI=SIGN(1.,EI)  
13160         VI=AI-4.*EI*XW  
13161         AVI=AI**2+VI**2 
13162         DO 540 J=MIN2,MAX2  
13163         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 540   
13164         EJ=KCHG(IABS(J),1)/3.   
13165         AJ=SIGN(1.,EJ)  
13166         VJ=AJ-4.*EJ*XW  
13167         AVJ=AJ**2+VJ**2 
13168         NCHN=NCHN+1 
13169         ISIG(NCHN,1)=I  
13170         ISIG(NCHN,2)=J  
13171         ISIG(NCHN,3)=1  
13172         SIGH(NCHN)=FACH*AVI*AVJ 
13173   540   CONTINUE    
13174   550   CONTINUE    
13175     
13176       ELSEIF(ISUB.EQ.73) THEN   
13177 C...Z0 + W+/- -> Z0 + W+/-. 

13178         BE2=1.-2.*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2    
13179         EP1=1.+(SQMZ-SQMW)/SH   
13180         EP2=1.-(SQMZ-SQMW)/SH   
13181         TH=-0.5*SH*BE2*(1.-CTH) 
13182         UH=(SQMZ-SQMW)**2/SH-0.5*SH*BE2*(1.+CTH)    
13183         THANG=SQRT(SQMW/(SQMZ*(1.-XW)))*(BE2-EP1*CTH)*(BE2-EP2*CTH) 
13184         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG    
13185         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG    
13186         ASWRE=(1.-XW)/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+ 
13187      &  1./4.*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4.*BE2*CTH)+   
13188      &  2.*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-  
13189      &  1./16.*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2) 
13190         ASWIM=0.    
13191         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*    
13192      &  (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*  
13193      &  (BE2+EP1*EP2*CTH)*(2.*EP2-EP2*CTH+EP1)-BE2*(EP2+EP1*CTH)**2*    
13194      &  (BE2-EP2**2*CTH)-1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+  
13195      &  2.*BE2*(1.-CTH))+1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*   
13196      &  (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)* 
13197      &  (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*  
13198      &  (2.*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*(BE2-EP1**2*CTH)- 
13199      &  1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2.*BE2*(1.-CTH))+  
13200      &  1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2) 
13201         AUWIM=0.    
13202         A4RE=(1.-XW)/SQMZ*(EP1**2*EP2**2*(CTH**2-1.)-   
13203      &  2.*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2.*BE2*EP1*EP2)  
13204         A4IM=0. 
13205         FACH=COMFAC*1./(4096.*PARU(1)**2*4.*(1.-XW))*(AEM/XW)**4*   
13206      &  (SH/SQMW)**2*((ATHRE+ASWRE+AUWRE+A4RE)**2+  
13207      &  (ATHIM+ASWIM+AUWIM+A4IM)**2)*SQRT(SQMZ/SQMW)    
13208         DO 570 I=MIN1,MAX1  
13209         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 570   
13210         EI=KCHG(IABS(I),1)/3.   
13211         AI=SIGN(1.,EI)  
13212         VI=AI-4.*EI*XW  
13213         AVI=AI**2+VI**2 
13214         DO 560 J=MIN2,MAX2  
13215         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 560   
13216         EJ=KCHG(IABS(J),1)/3.   
13217         AJ=SIGN(1.,EJ)  
13218         VJ=AI-4.*EJ*XW  
13219         AVJ=AJ**2+VJ**2 
13220         NCHN=NCHN+1 
13221         ISIG(NCHN,1)=I  
13222         ISIG(NCHN,2)=J  
13223         ISIG(NCHN,3)=1  
13224         SIGH(NCHN)=FACH*(AVI*VINT(180+J)+VINT(180+I)*AVJ)   
13225   560   CONTINUE    
13226   570   CONTINUE    
13227     
13228       ELSEIF(ISUB.EQ.75) THEN   
13229 C...W+ + W- -> gamma + gamma.   

13230     
13231       ELSEIF(ISUB.EQ.76) THEN   
13232 C...W+ + W- -> Z0 + Z0. 

13233         BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))   
13234         CTH2=CTH**2 
13235         TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)   
13236         UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)   
13237         SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)* 
13238      &  (1.-2.*SQMZ/SH) 
13239         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
13240         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
13241         ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-    
13242      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
13243      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
13244      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))   
13245         ATWIM=0.    
13246         AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-    
13247      &  (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*    
13248      &  (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+ 
13249      &  4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))   
13250         AUWIM=0.    
13251         A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)    
13252         A4IM=0. 
13253         FACH=0.5*COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2* 
13254      &  ((ASHRE+ATWRE+AUWRE+A4RE)**2+(ASHIM+ATWIM+AUWIM+A4IM)**2)   
13255         DO 590 I=MIN1,MAX1  
13256         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 590   
13257         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)    
13258         DO 580 J=MIN2,MAX2  
13259         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 580   
13260         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)    
13261         IF(EI*EJ.GT.0.) GOTO 580    
13262         NCHN=NCHN+1 
13263         ISIG(NCHN,1)=I  
13264         ISIG(NCHN,2)=J  
13265         ISIG(NCHN,3)=1  
13266         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J) 
13267   580   CONTINUE    
13268   590   CONTINUE    
13269     
13270       ELSEIF(ISUB.EQ.77) THEN   
13271 C...W+/- + W+/- -> W+/- + W+/-. 

13272         BE2=1.-4.*SQMW/SH   
13273         BE4=BE2**2  
13274         CTH2=CTH**2 
13275         CTH3=CTH**3 
13276         TH=-0.5*SH*BE2*(1.-CTH) 
13277         UH=-0.5*SH*BE2*(1.+CTH) 
13278         SHANG=(1.+BE2)**2   
13279         ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG    
13280         ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG    
13281         THANG=(BE2-CTH)**2  
13282         ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG    
13283         ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG    
13284         SGZANG=1./SQMW*BE2*(3.-BE2)**2*CTH  
13285         ASGRE=XW*SGZANG 
13286         ASGIM=0.    
13287         ASZRE=(1.-XW)*SH/(SH-SQMZ)*SGZANG   
13288         ASZIM=0.    
13289         TGZANG=1./SQMW*(BE2*(4.-2.*BE2+BE4)+BE2*(4.-10.*BE2+BE4)*CTH+   
13290      &  (2.-11.*BE2+10.*BE4)*CTH2+BE2*CTH3) 
13291         ATGRE=0.5*XW*SH/TH*TGZANG   
13292         ATGIM=0.    
13293         ATZRE=0.5*(1.-XW)*SH/(TH-SQMZ)*TGZANG   
13294         ATZIM=0.    
13295         A4RE=1./SQMW*(1.+2.*BE2-6.*BE2*CTH-CTH2)    
13296         A4IM=0. 
13297         FACH=COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2* 
13298      &  ((ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4RE)**2+ 
13299      &  (ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4IM)**2)  
13300         DO 610 I=MIN1,MAX1  
13301         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 610   
13302         EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)    
13303         DO 600 J=MIN2,MAX2  
13304         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 600   
13305         EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)    
13306         IF(EI*EJ.GT.0.) GOTO 600    
13307         NCHN=NCHN+1 
13308         ISIG(NCHN,1)=I  
13309         ISIG(NCHN,2)=J  
13310         ISIG(NCHN,3)=1  
13311         SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J) 
13312   600   CONTINUE    
13313   610   CONTINUE    
13314     
13315       ELSEIF(ISUB.EQ.78) THEN   
13316 C...W+/- + H0 -> W+/- + H0. 

13317     
13318       ELSEIF(ISUB.EQ.79) THEN   
13319 C...H0 + H0 -> H0 + H0. 

13320     
13321       ENDIF 
13322     
13323 C...C: 2 -> 2, tree diagrams with masses.   

13324     
13325       ELSEIF(ISUB.LE.90) THEN   
13326       IF(ISUB.EQ.81) THEN   
13327 C...q + qb -> Q + QB.   

13328         FACQQB=COMFAC*AS**2*4./9.*(((TH-SQM3)**2+   
13329      &  (UH-SQM3)**2)/SH2+2.*SQM3/SH)   
13330         IF(MSTP(35).GE.1) THEN  
13331           IF(MSTP(35).EQ.1) THEN    
13332             ALSSG=PARP(35)  
13333           ELSE  
13334             MST115=MSTU(115)    
13335             MSTU(115)=MSTP(36)  
13336             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))   
13337             ALSSG=ULALPS(Q2BN)  
13338             MSTU(115)=MST115    
13339           ENDIF 
13340           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))   
13341           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.) 
13342           PARI(81)=FREPU    
13343           FACQQB=FACQQB*FREPU   
13344         ENDIF   
13345         DO 620 I=MINA,MAXA  
13346         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 620    
13347         NCHN=NCHN+1 
13348         ISIG(NCHN,1)=I  
13349         ISIG(NCHN,2)=-I 
13350         ISIG(NCHN,3)=1  
13351         SIGH(NCHN)=FACQQB   
13352   620   CONTINUE    
13353     
13354       ELSEIF(ISUB.EQ.82) THEN   
13355 C...g + g -> Q + QB.    

13356         FACQQ1=COMFAC*FACA*AS**2*1./6.*((UH-SQM3)/(TH-SQM3)-    
13357      &  2.*(UH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(TH-SQM3)**2)    
13358         FACQQ2=COMFAC*FACA*AS**2*1./6.*((TH-SQM3)/(UH-SQM3)-    
13359      &  2.*(TH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(UH-SQM3)**2)    
13360         IF(MSTP(35).GE.1) THEN  
13361           IF(MSTP(35).EQ.1) THEN    
13362             ALSSG=PARP(35)  
13363           ELSE  
13364             MST115=MSTU(115)    
13365             MSTU(115)=MSTP(36)  
13366             Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))   
13367             ALSSG=ULALPS(Q2BN)  
13368             MSTU(115)=MST115    
13369           ENDIF 
13370           XATTR=4.*PARU(1)*ALSSG/(3.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))    
13371           FATTR=XATTR/(1.-EXP(-MIN(100.,XATTR)))    
13372           XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))   
13373           FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.) 
13374           FATRE=(2.*FATTR+5.*FREPU)/7.  
13375           PARI(81)=FATRE    
13376           FACQQ1=FACQQ1*FATRE   
13377           FACQQ2=FACQQ2*FATRE   
13378         ENDIF   
13379         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 630 
13380         NCHN=NCHN+1 
13381         ISIG(NCHN,1)=21 
13382         ISIG(NCHN,2)=21 
13383         ISIG(NCHN,3)=1  
13384         SIGH(NCHN)=FACQQ1   
13385         NCHN=NCHN+1 
13386         ISIG(NCHN,1)=21 
13387         ISIG(NCHN,2)=21 
13388         ISIG(NCHN,3)=2  
13389         SIGH(NCHN)=FACQQ2   
13390   630   CONTINUE    
13391     
13392       ENDIF 
13393     
13394 C...D: Mimimum bias processes.  

13395     
13396       ELSEIF(ISUB.LE.100) THEN  
13397       IF(ISUB.EQ.91) THEN   
13398 C...Elastic scattering. 

13399         SIGS=XSEC(ISUB,1)   
13400     
13401       ELSEIF(ISUB.EQ.92) THEN   
13402 C...Single diffractive scattering.  

13403         SIGS=XSEC(ISUB,1)   
13404     
13405       ELSEIF(ISUB.EQ.93) THEN   
13406 C...Double diffractive scattering.  

13407         SIGS=XSEC(ISUB,1)   
13408     
13409       ELSEIF(ISUB.EQ.94) THEN   
13410 C...Central diffractive scattering. 

13411         SIGS=XSEC(ISUB,1)   
13412     
13413       ELSEIF(ISUB.EQ.95) THEN   
13414 C...Low-pT scattering.  

13415         SIGS=XSEC(ISUB,1)   
13416     
13417       ELSEIF(ISUB.EQ.96) THEN   
13418 C...Multiple interactions: sum of QCD processes.    

13419         CALL PYWIDT(21,SQRT(SH),WDTP,WDTE)  
13420     
13421 C...q + q' -> q + q'.   

13422         FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2 
13423         FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-  
13424      &  MSTP(34)*2./3.*UH2/(SH*TH)) 
13425         FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-   
13426      &  MSTP(34)*2./3.*SH2/(TH*UH)) 
13427         DO 650 I=-3,3   
13428         IF(I.EQ.0) GOTO 650 
13429         DO 640 J=-3,3   
13430         IF(J.EQ.0) GOTO 640 
13431         NCHN=NCHN+1 
13432         ISIG(NCHN,1)=I  
13433         ISIG(NCHN,2)=J  
13434         ISIG(NCHN,3)=111    
13435         SIGH(NCHN)=FACQQ1   
13436         IF(I.EQ.-J) SIGH(NCHN)=FACQQB   
13437         IF(I.EQ.J) THEN 
13438           SIGH(NCHN)=0.5*SIGH(NCHN) 
13439           NCHN=NCHN+1   
13440           ISIG(NCHN,1)=I    
13441           ISIG(NCHN,2)=J    
13442           ISIG(NCHN,3)=112  
13443           SIGH(NCHN)=0.5*FACQQ2 
13444         ENDIF   
13445   640   CONTINUE    
13446   650   CONTINUE    
13447     
13448 C...q + qb -> q' + qb' or g + g.    

13449         FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+   
13450      &  WDTE(0,3)+WDTE(0,4))    
13451         FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2) 
13452         FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2) 
13453         DO 660 I=-3,3   
13454         IF(I.EQ.0) GOTO 660 
13455         NCHN=NCHN+1 
13456         ISIG(NCHN,1)=I  
13457         ISIG(NCHN,2)=-I 
13458         ISIG(NCHN,3)=121    
13459         SIGH(NCHN)=FACQQB   
13460         NCHN=NCHN+1 
13461         ISIG(NCHN,1)=I  
13462         ISIG(NCHN,2)=-I 
13463         ISIG(NCHN,3)=131    
13464         SIGH(NCHN)=0.5*FACGG1   
13465         NCHN=NCHN+1 
13466         ISIG(NCHN,1)=I  
13467         ISIG(NCHN,2)=-I 
13468         ISIG(NCHN,3)=132    
13469         SIGH(NCHN)=0.5*FACGG2   
13470   660   CONTINUE    
13471     
13472 C...q + g -> q + g. 

13473         FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*  
13474      &  FACA    
13475         FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)   
13476         DO 680 I=-3,3   
13477         IF(I.EQ.0) GOTO 680 
13478         DO 670 ISDE=1,2 
13479         NCHN=NCHN+1 
13480         ISIG(NCHN,ISDE)=I   
13481         ISIG(NCHN,3-ISDE)=21    
13482         ISIG(NCHN,3)=281    
13483         SIGH(NCHN)=FACQG1   
13484         NCHN=NCHN+1 
13485         ISIG(NCHN,ISDE)=I   
13486         ISIG(NCHN,3-ISDE)=21    
13487         ISIG(NCHN,3)=282    
13488         SIGH(NCHN)=FACQG2   
13489   670   CONTINUE    
13490   680   CONTINUE    
13491     
13492 C...g + g -> q + qb or g + g.   

13493         FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*  
13494      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
13495         FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*  
13496      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA  
13497         FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+    
13498      &  TH2/SH2)*FACA   
13499         FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+    
13500      &  SH2/UH2)*FACA   
13501         FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2) 
13502         NCHN=NCHN+1 
13503         ISIG(NCHN,1)=21 
13504         ISIG(NCHN,2)=21 
13505         ISIG(NCHN,3)=531    
13506         SIGH(NCHN)=FACQQ1   
13507         NCHN=NCHN+1 
13508         ISIG(NCHN,1)=21 
13509         ISIG(NCHN,2)=21 
13510         ISIG(NCHN,3)=532    
13511         SIGH(NCHN)=FACQQ2   
13512         NCHN=NCHN+1 
13513         ISIG(NCHN,1)=21 
13514         ISIG(NCHN,2)=21 
13515         ISIG(NCHN,3)=681    
13516         SIGH(NCHN)=0.5*FACGG1   
13517         NCHN=NCHN+1 
13518         ISIG(NCHN,1)=21 
13519         ISIG(NCHN,2)=21 
13520         ISIG(NCHN,3)=682    
13521         SIGH(NCHN)=0.5*FACGG2   
13522         NCHN=NCHN+1 
13523         ISIG(NCHN,1)=21 
13524         ISIG(NCHN,2)=21 
13525         ISIG(NCHN,3)=683    
13526         SIGH(NCHN)=0.5*FACGG3   
13527       ENDIF 
13528     
13529 C...E: 2 -> 1, loop diagrams.   

13530     
13531       ELSEIF(ISUB.LE.110) THEN  
13532       IF(ISUB.EQ.101) THEN  
13533 C...g + g -> gamma*/Z0. 

13534     
13535       ELSEIF(ISUB.EQ.102) THEN  
13536 C...g + g -> H0.    

13537         CALL PYWIDT(25,SQRT(SH),WDTP,WDTE)  
13538         ETARE=0.    
13539         ETAIM=0.    
13540         DO 690 I=1,2*MSTP(1)    
13541         EPS=4.*PMAS(I,1)**2/SH  
13542         IF(EPS.LE.1.) THEN  
13543           IF(EPS.GT.1.E-4) THEN 
13544             ROOT=SQRT(1.-EPS)   
13545             RLN=LOG((1.+ROOT)/(1.-ROOT))    
13546           ELSE  
13547             RLN=LOG(4./EPS-2.)  
13548           ENDIF 
13549           PHIRE=0.25*(RLN**2-PARU(1)**2)    
13550           PHIIM=0.5*PARU(1)*RLN 
13551         ELSE    
13552           PHIRE=-(ASIN(1./SQRT(EPS)))**2    
13553           PHIIM=0.  
13554         ENDIF   
13555         ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE) 
13556         ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM  
13557   690   CONTINUE    
13558         ETA2=ETARE**2+ETAIM**2  
13559         FACH=COMFAC*FACA*(AS/PARU(1)*AEM/XW)**2*1./512.*    
13560      &  (SH/SQMW)**2*ETA2*SH2/((SH-SQMH)**2+GMMH**2)*   
13561      &  (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) 
13562         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 700 
13563         NCHN=NCHN+1 
13564         ISIG(NCHN,1)=21 
13565         ISIG(NCHN,2)=21 
13566         ISIG(NCHN,3)=1  
13567         SIGH(NCHN)=FACH 
13568   700   CONTINUE    
13569     
13570       ENDIF 
13571     
13572 C...F: 2 -> 2, box diagrams.    

13573     
13574       ELSEIF(ISUB.LE.120) THEN  
13575       IF(ISUB.EQ.111) THEN  
13576 C...f + fb -> g + H0 (q + qb -> g + H0 only).   

13577         A5STUR=0.   
13578         A5STUI=0.   
13579         DO 710 I=1,2*MSTP(1)    
13580         SQMQ=PMAS(I,1)**2   
13581         EPSS=4.*SQMQ/SH 
13582         EPSH=4.*SQMQ/SQMH   
13583         A5STUR=A5STUR+SQMQ/SQMH*(4.+4.*SH/(TH+UH)*(PYW1AU(EPSS,1)-  
13584      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,1)-   
13585      &  PYW2AU(EPSH,1)))    
13586         A5STUI=A5STUI+SQMQ/SQMH*(4.*SH/(TH+UH)*(PYW1AU(EPSS,2)- 
13587      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,2)-   
13588      &  PYW2AU(EPSH,2)))    
13589   710   CONTINUE    
13590         FACGH=COMFAC*FACA/(144.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* 
13591      &  SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)  
13592         FACGH=FACGH*WIDS(25,2)  
13593         DO 720 I=MINA,MAXA  
13594         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 720    
13595         NCHN=NCHN+1 
13596         ISIG(NCHN,1)=I  
13597         ISIG(NCHN,2)=-I 
13598         ISIG(NCHN,3)=1  
13599         SIGH(NCHN)=FACGH    
13600   720   CONTINUE    
13601     
13602       ELSEIF(ISUB.EQ.112) THEN  
13603 C...f + g -> f + H0 (q + g -> q + H0 only). 

13604         A5TSUR=0.   
13605         A5TSUI=0.   
13606         DO 730 I=1,2*MSTP(1)    
13607         SQMQ=PMAS(I,1)**2   
13608         EPST=4.*SQMQ/TH 
13609         EPSH=4.*SQMQ/SQMH   
13610         A5TSUR=A5TSUR+SQMQ/SQMH*(4.+4.*TH/(SH+UH)*(PYW1AU(EPST,1)-  
13611      &  PYW1AU(EPSH,1))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,1)-   
13612      &  PYW2AU(EPSH,1)))    
13613         A5TSUI=A5TSUI+SQMQ/SQMH*(4.*TH/(SH+UH)*(PYW1AU(EPST,2)- 
13614      &  PYW1AU(EPSH,2))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,2)-   
13615      &  PYW2AU(EPSH,2)))    
13616   730   CONTINUE    
13617         FACQH=COMFAC*FACA/(384.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* 
13618      &  SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)   
13619         FACQH=FACQH*WIDS(25,2)  
13620         DO 750 I=MINA,MAXA  
13621         IF(I.EQ.0) GOTO 750 
13622         DO 740 ISDE=1,2 
13623         IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 740    
13624         IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 740    
13625         NCHN=NCHN+1 
13626         ISIG(NCHN,ISDE)=I   
13627         ISIG(NCHN,3-ISDE)=21    
13628         ISIG(NCHN,3)=1  
13629         SIGH(NCHN)=FACQH    
13630   740   CONTINUE    
13631   750   CONTINUE    
13632     
13633       ELSEIF(ISUB.EQ.113) THEN  
13634 C...g + g -> g + H0.    

13635         A2STUR=0.   
13636         A2STUI=0.   
13637         A2USTR=0.   
13638         A2USTI=0.   
13639         A2TUSR=0.   
13640         A2TUSI=0.   
13641         A4STUR=0.   
13642         A4STUI=0.   
13643         DO 760 I=6,2*MSTP(1)    
13644 C'''Only t-quarks yet included  

13645         SQMQ=PMAS(I,1)**2   
13646         EPSS=4.*SQMQ/SH 
13647         EPST=4.*SQMQ/TH 
13648         EPSU=4.*SQMQ/UH 
13649         EPSH=4.*SQMQ/SQMH   
13650         IF(EPSH.LT.1.E-6) GOTO 760  
13651         BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))  
13652         BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))  
13653         BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))  
13654         BEUTS=BESTU 
13655         BETSU=BEUST 
13656         BESUT=BETUS 
13657         W3STUR=PYI3AU(BESTU,EPSH,1)-PYI3AU(BESTU,EPSS,1)-   
13658      &  PYI3AU(BESTU,EPSU,1)    
13659         W3STUI=PYI3AU(BESTU,EPSH,2)-PYI3AU(BESTU,EPSS,2)-   
13660      &  PYI3AU(BESTU,EPSU,2)    
13661         W3SUTR=PYI3AU(BESUT,EPSH,1)-PYI3AU(BESUT,EPSS,1)-   
13662      &  PYI3AU(BESUT,EPST,1)    
13663         W3SUTI=PYI3AU(BESUT,EPSH,2)-PYI3AU(BESUT,EPSS,2)-   
13664      &  PYI3AU(BESUT,EPST,2)    
13665         W3TSUR=PYI3AU(BETSU,EPSH,1)-PYI3AU(BETSU,EPST,1)-   
13666      &  PYI3AU(BETSU,EPSU,1)    
13667         W3TSUI=PYI3AU(BETSU,EPSH,2)-PYI3AU(BETSU,EPST,2)-   
13668      &  PYI3AU(BETSU,EPSU,2)    
13669         W3TUSR=PYI3AU(BETUS,EPSH,1)-PYI3AU(BETUS,EPST,1)-   
13670      &  PYI3AU(BETUS,EPSS,1)    
13671         W3TUSI=PYI3AU(BETUS,EPSH,2)-PYI3AU(BETUS,EPST,2)-   
13672      &  PYI3AU(BETUS,EPSS,2)    
13673         W3USTR=PYI3AU(BEUST,EPSH,1)-PYI3AU(BEUST,EPSU,1)-   
13674      &  PYI3AU(BEUST,EPST,1)    
13675         W3USTI=PYI3AU(BEUST,EPSH,2)-PYI3AU(BEUST,EPSU,2)-   
13676      &  PYI3AU(BEUST,EPST,2)    
13677         W3UTSR=PYI3AU(BEUTS,EPSH,1)-PYI3AU(BEUTS,EPSU,1)-   
13678      &  PYI3AU(BEUTS,EPSS,1)    
13679         W3UTSI=PYI3AU(BEUTS,EPSH,2)-PYI3AU(BEUTS,EPSU,2)-   
13680      &  PYI3AU(BEUTS,EPSS,2)    
13681         B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2.*TH*UH*(UH+2.*SH)/    
13682      &  (SH+UH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*    
13683      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3STUR)+  
13684      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,1)- 
13685      &  PYW2AU(EPSH,1))+0.5*TH*UH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+    
13686      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUR) 
13687         B2STUI=SQMQ/SQMH**2*(2.*TH*UH*(UH+2.*SH)/(SH+UH)**2*    
13688      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*   
13689      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3STUI)+  
13690      &  SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,2)- 
13691      &  PYW2AU(EPSH,2))+0.5*TH*UH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+    
13692      &  0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUI) 
13693         B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2.*UH*TH*(TH+2.*SH)/    
13694      &  (SH+TH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*    
13695      &  (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3SUTR)+  
13696      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,1)- 
13697      &  PYW2AU(EPSH,1))+0.5*UH*TH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+    
13698      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTR) 
13699         B2SUTI=SQMQ/SQMH**2*(2.*UH*TH*(TH+2.*SH)/(SH+TH)**2*    
13700      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*   
13701      &  (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3SUTI)+  
13702      &  SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,2)- 
13703      &  PYW2AU(EPSH,2))+0.5*UH*TH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+    
13704      &  0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTI) 
13705         B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2.*SH*UH*(UH+2.*TH)/    
13706      &  (TH+UH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*    
13707      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3TSUR)+  
13708      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,1)- 
13709      &  PYW2AU(EPSH,1))+0.5*SH*UH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+    
13710      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUR) 
13711         B2TSUI=SQMQ/SQMH**2*(2.*SH*UH*(UH+2.*TH)/(TH+UH)**2*    
13712      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*   
13713      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3TSUI)+  
13714      &  TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,2)- 
13715      &  PYW2AU(EPSH,2))+0.5*SH*UH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+    
13716      &  0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUI) 
13717         B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2.*UH*SH*(SH+2.*TH)/    
13718      &  (TH+SH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*    
13719      &  (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3TUSR)+  
13720      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,1)- 
13721      &  PYW2AU(EPSH,1))+0.5*UH*SH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+    
13722      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSR) 
13723         B2TUSI=SQMQ/SQMH**2*(2.*UH*SH*(SH+2.*TH)/(TH+SH)**2*    
13724      &  (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*   
13725      &  (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3TUSI)+  
13726      &  TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,2)- 
13727      &  PYW2AU(EPSH,2))+0.5*UH*SH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+    
13728      &  0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSI) 
13729         B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2.*SH*TH*(TH+2.*UH)/    
13730      &  (UH+TH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*    
13731      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3USTR)+  
13732      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,1)- 
13733      &  PYW2AU(EPSH,1))+0.5*SH*TH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+    
13734      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTR) 
13735         B2USTI=SQMQ/SQMH**2*(2.*SH*TH*(TH+2.*UH)/(UH+TH)**2*    
13736      &  (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*   
13737      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3USTI)+  
13738      &  UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,2)- 
13739      &  PYW2AU(EPSH,2))+0.5*SH*TH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+    
13740      &  0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTI) 
13741         B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2.*TH*SH*(SH+2.*UH)/    
13742      &  (UH+SH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*    
13743      &  (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3UTSR)+  
13744      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,1)- 
13745      &  PYW2AU(EPSH,1))+0.5*TH*SH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+    
13746      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSR) 
13747         B2UTSI=SQMQ/SQMH**2*(2.*TH*SH*(SH+2.*UH)/(UH+SH)**2*    
13748      &  (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*   
13749      &  (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3UTSI)+  
13750      &  UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,2)- 
13751      &  PYW2AU(EPSH,2))+0.5*TH*SH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+    
13752      &  0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSI) 
13753         B4STUR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,1)- 
13754      &  PYW2AU(EPSH,1)+W3STUR)) 
13755         B4STUI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,2)- 
13756      &  PYW2AU(EPSH,2)+W3STUI)  
13757         B4TUSR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,1)- 
13758      &  PYW2AU(EPSH,1)+W3TUSR)) 
13759         B4TUSI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,2)- 
13760      &  PYW2AU(EPSH,2)+W3TUSI)  
13761         B4USTR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,1)- 
13762      &  PYW2AU(EPSH,1)+W3USTR)) 
13763         B4USTI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,2)- 
13764      &  PYW2AU(EPSH,2)+W3USTI)  
13765         A2STUR=A2STUR+B2STUR+B2SUTR 
13766         A2STUI=A2STUI+B2STUI+B2SUTI 
13767         A2USTR=A2USTR+B2USTR+B2UTSR 
13768         A2USTI=A2USTI+B2USTI+B2UTSI 
13769         A2TUSR=A2TUSR+B2TUSR+B2TSUR 
13770         A2TUSI=A2TUSI+B2TUSI+B2TSUI 
13771         A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR  
13772         A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI  
13773   760   CONTINUE    
13774         FACGH=COMFAC*FACA*3./(128.*PARU(1)**2)*AEM/XW*AS**3*    
13775      &  SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+    
13776      &  A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)  
13777         FACGH=FACGH*WIDS(25,2)  
13778         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 770 
13779         NCHN=NCHN+1 
13780         ISIG(NCHN,1)=21 
13781         ISIG(NCHN,2)=21 
13782         ISIG(NCHN,3)=1  
13783         SIGH(NCHN)=FACGH    
13784   770   CONTINUE    
13785     
13786       ELSEIF(ISUB.EQ.114) THEN  
13787 C...g + g -> gamma + gamma. 

13788         ASRE=0. 
13789         ASIM=0. 
13790         DO 780 I=1,2*MSTP(1)    
13791         EI=KCHG(IABS(I),1)/3.   
13792         SQMQ=PMAS(I,1)**2   
13793         EPSS=4.*SQMQ/SH 
13794         EPST=4.*SQMQ/TH 
13795         EPSU=4.*SQMQ/UH 
13796         IF(EPSS+ABS(EPST)+ABS(EPSU).LT.3.E-6) THEN  
13797           A0STUR=1.+(TH-UH)/SH*LOG(TH/UH)+0.5*(TH2+UH2)/SH2*    
13798      &    (LOG(TH/UH)**2+PARU(1)**2)    
13799           A0STUI=0. 
13800           A0TSUR=1.+(SH-UH)/TH*LOG(-SH/UH)+0.5*(SH2+UH2)/TH2*   
13801      &    LOG(-SH/UH)**2    
13802           A0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*LOG(-SH/UH))    
13803           A0UTSR=1.+(TH-SH)/UH*LOG(-TH/SH)+0.5*(TH2+SH2)/UH2*   
13804      &    LOG(-TH/SH)**2    
13805           A0UTSI=PARU(1)*((TH-SH)/UH+(TH2+SH2)/UH2*LOG(-TH/SH)) 
13806           A1STUR=-1.    
13807           A1STUI=0. 
13808           A2STUR=-1.    
13809           A2STUI=0. 
13810         ELSE    
13811           BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))    
13812           BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))    
13813           BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))    
13814           BEUTS=BESTU   
13815           BETSU=BEUST   
13816           BESUT=BETUS   
13817           A0STUR=1.+(1.+2.*TH/SH)*PYW1AU(EPST,1)+(1.+2.*UH/SH)* 
13818      &    PYW1AU(EPSU,1)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,1)+  
13819      &    PYW2AU(EPSU,1))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,1)+    
13820      &    PYI3AU(BESUT,EPST,1))-0.25*EPSU*(1.-0.5*EPSS)*    
13821      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))+  
13822      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)* 
13823      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))   
13824           A0STUI=(1.+2.*TH/SH)*PYW1AU(EPST,2)+(1.+2.*UH/SH)*    
13825      &    PYW1AU(EPSU,2)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,2)+  
13826      &    PYW2AU(EPSU,2))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AU(BESUT,EPSS,2)+    
13827      &    PYI3AU(BESUT,EPST,2))-0.25*EPSU*(1.-0.5*EPSS)*    
13828      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))+  
13829      &    0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)* 
13830      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))   
13831           A0TSUR=1.+(1.+2.*SH/TH)*PYW1AU(EPSS,1)+(1.+2.*UH/TH)* 
13832      &    PYW1AU(EPSU,1)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,1)+  
13833      &    PYW2AU(EPSU,1))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,1)+    
13834      &    PYI3AU(BETUS,EPSS,1))-0.25*EPSU*(1.-0.5*EPST)*    
13835      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))+  
13836      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)* 
13837      &    (PYI3AU(BESTU,EPSS,1)+PYI3AU(BESTU,EPSU,1))   
13838           A0TSUI=(1.+2.*SH/TH)*PYW1AU(EPSS,2)+(1.+2.*UH/TH)*    
13839      &    PYW1AU(EPSU,2)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,2)+  
13840      &    PYW2AU(EPSU,2))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AU(BETUS,EPST,2)+    
13841      &    PYI3AU(BETUS,EPSS,2))-0.25*EPSU*(1.-0.5*EPST)*    
13842      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))+  
13843      &    0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)* 
13844      &    (PYI3AU(BESTU,EPSS,2)+PYI3AU(BESTU,EPSU,2))   
13845           A0UTSR=1.+(1.+2.*TH/UH)*PYW1AU(EPST,1)+(1.+2.*SH/UH)* 
13846      &    PYW1AU(EPSS,1)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,1)+  
13847      &    PYW2AU(EPSS,1))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,1)+    
13848      &    PYI3AU(BEUST,EPST,1))-0.25*EPSS*(1.-0.5*EPSU)*    
13849      &    (PYI3AU(BEUTS,EPSU,1)+PYI3AU(BEUTS,EPSS,1))+  
13850      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)* 
13851      &    (PYI3AU(BETUS,EPST,1)+PYI3AU(BETUS,EPSS,1))   
13852           A0UTSI=(1.+2.*TH/UH)*PYW1AU(EPST,2)+(1.+2.*SH/UH)*    
13853      &    PYW1AU(EPSS,2)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,2)+  
13854      &    PYW2AU(EPSS,2))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AU(BEUST,EPSU,2)+    
13855      &    PYI3AU(BEUST,EPST,2))-0.25*EPSS*(1.-0.5*EPSU)*    
13856      &    (PYI3AU(BEUTS,EPSU,2)+PYI3AU(BEUTS,EPSS,2))+  
13857      &    0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)* 
13858      &    (PYI3AU(BETUS,EPST,2)+PYI3AU(BETUS,EPSS,2))   
13859           A1STUR=-1.-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,1)+ 
13860      &    PYW2AU(EPST,1)+PYW2AU(EPSU,1))+0.25*(EPSU+0.5*EPSS*EPST)* 
13861      &    (PYI3AU(BESUT,EPSS,1)+PYI3AU(BESUT,EPST,1))+  
13862      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,1)+  
13863      &    PYI3AU(BESTU,EPSU,1))+0.25*(EPSS+0.5*EPST*EPSU)*  
13864      &    (PYI3AU(BETSU,EPST,1)+PYI3AU(BETSU,EPSU,1))   
13865           A1STUI=-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,2)+PYW2AU(EPST,2)+ 
13866      &    PYW2AU(EPSU,2))+0.25*(EPSU+0.5*EPSS*EPST)*    
13867      &    (PYI3AU(BESUT,EPSS,2)+PYI3AU(BESUT,EPST,2))+  
13868      &    0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AU(BESTU,EPSS,2)+  
13869      &    PYI3AU(BESTU,EPSU,2))+0.25*(EPSS+0.5*EPST*EPSU)*  
13870      &    (PYI3AU(BETSU,EPST,2)+PYI3AU(BETSU,EPSU,2))   
13871           A2STUR=-1.+0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,1)+ 
13872      &    PYI3AU(BESUT,EPST,1))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,1)+  
13873      &    PYI3AU(BESTU,EPSU,1))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,1)+  
13874      &    PYI3AU(BETSU,EPSU,1)) 
13875           A2STUI=0.125*EPSS*EPST*(PYI3AU(BESUT,EPSS,2)+ 
13876      &    PYI3AU(BESUT,EPST,2))+0.125*EPSS*EPSU*(PYI3AU(BESTU,EPSS,2)+  
13877      &    PYI3AU(BESTU,EPSU,2))+0.125*EPST*EPSU*(PYI3AU(BETSU,EPST,2)+  
13878      &    PYI3AU(BETSU,EPSU,2)) 
13879         ENDIF   
13880         ASRE=ASRE+EI**2*(A0STUR+A0TSUR+A0UTSR+4.*A1STUR+A2STUR) 
13881         ASIM=ASIM+EI**2*(A0STUI+A0TSUI+A0UTSI+4.*A1STUI+A2STUI) 
13882   780   CONTINUE    
13883         FACGG=COMFAC*FACA/(8.*PARU(1)**2)*AS**2*AEM**2*(ASRE**2+ASIM**2)    
13884         IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 790 
13885         NCHN=NCHN+1 
13886         ISIG(NCHN,1)=21 
13887         ISIG(NCHN,2)=21 
13888         ISIG(NCHN,3)=1  
13889         SIGH(NCHN)=FACGG    
13890   790   CONTINUE    
13891     
13892       ELSEIF(ISUB.EQ.115) THEN  
13893 C...g + g -> gamma + Z0.    

13894     
13895       ELSEIF(ISUB.EQ.116) THEN  
13896 C...g + g -> Z0 + Z0.   

13897     
13898       ELSEIF(ISUB.EQ.117) THEN  
13899 C...g + g -> W+ + W-.   

13900     
13901       ENDIF 
13902     
13903 C...G: 2 -> 3, tree diagrams.   

13904     
13905       ELSEIF(ISUB.LE.140) THEN  
13906       IF(ISUB.EQ.121) THEN  
13907 C...g + g -> f + fb + H0.   

13908     
13909       ENDIF 
13910     
13911 C...H: 2 -> 1, tree diagrams, non-standard model processes. 

13912     
13913       ELSEIF(ISUB.LE.160) THEN  
13914       IF(ISUB.EQ.141) THEN  
13915 C...f + fb -> gamma*/Z0/Z'0.    

13916         MINT(61)=2  
13917         CALL PYWIDT(32,SQRT(SH),WDTP,WDTE)  
13918         FACZP=COMFAC*AEM**2*4./9.   
13919         DO 800 I=MINA,MAXA  
13920         IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 800    
13921         EI=KCHG(IABS(I),1)/3.   
13922         AI=SIGN(1.,EI)  
13923         VI=AI-4.*EI*XW  
13924         API=SIGN(1.,EI) 
13925         VPI=API-4.*EI*XW    
13926         NCHN=NCHN+1 
13927         ISIG(NCHN,1)=I  
13928         ISIG(NCHN,2)=-I 
13929         ISIG(NCHN,3)=1  
13930         SIGH(NCHN)=FACZP*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*    
13931      &  SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+EI*VPI/(8.*XW*    
13932      &  (1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GMMZP**2)*VINT(113)+  
13933      &  (VI**2+AI**2)/(16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*   
13934      &  VINT(114)+2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*SH2*   
13935      &  ((SH-SQMZ)*(SH-SQMZP)+GMMZ*GMMZP)/(((SH-SQMZ)**2+GMMZ**2)*  
13936      &  ((SH-SQMZP)**2+GMMZP**2))*VINT(115)+(VPI**2+API**2)/    
13937      &  (16.*XW*(1.-XW))**2*SH2/((SH-SQMZP)**2+GMMZP**2)*VINT(116)) 
13938   800   CONTINUE    
13939     
13940       ELSEIF(ISUB.EQ.142) THEN  
13941 C...f + fb' -> H+/-.    

13942         CALL PYWIDT(37,SQRT(SH),WDTP,WDTE)  
13943         FHC=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/ 
13944      &  ((SH-SQMHC)**2+GMMHC**2)    
13945 C'''No construction yet for leptons 

13946         DO 840 I=1,MSTP(54)/2   
13947         IL=2*I-1    
13948         IU=2*I  
13949         RMQL=PMAS(IL,1)**2/SH   
13950         RMQU=PMAS(IU,1)**2/SH   
13951         FACHC=FHC*((RMQL*PARU(121)+RMQU/PARU(121))*(1.-RMQL-RMQU)-  
13952      &  4.*RMQL*RMQU)/SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))  
13953         IF(KFAC(1,IL)*KFAC(2,-IU).EQ.0) GOTO 810    
13954         KCHHC=(KCHG(IL,1)-KCHG(IU,1))/3 
13955         NCHN=NCHN+1 
13956         ISIG(NCHN,1)=IL 
13957         ISIG(NCHN,2)=-IU    
13958         ISIG(NCHN,3)=1  
13959         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
13960   810   IF(KFAC(1,-IL)*KFAC(2,IU).EQ.0) GOTO 820    
13961         KCHHC=(-KCHG(IL,1)+KCHG(IU,1))/3    
13962         NCHN=NCHN+1 
13963         ISIG(NCHN,1)=-IL    
13964         ISIG(NCHN,2)=IU 
13965         ISIG(NCHN,3)=1  
13966         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
13967   820   IF(KFAC(1,IU)*KFAC(2,-IL).EQ.0) GOTO 830    
13968         KCHHC=(KCHG(IU,1)-KCHG(IL,1))/3 
13969         NCHN=NCHN+1 
13970         ISIG(NCHN,1)=IU 
13971         ISIG(NCHN,2)=-IL    
13972         ISIG(NCHN,3)=1  
13973         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
13974   830   IF(KFAC(1,-IU)*KFAC(2,IL).EQ.0) GOTO 840    
13975         KCHHC=(-KCHG(IU,1)+KCHG(IL,1))/3    
13976         NCHN=NCHN+1 
13977         ISIG(NCHN,1)=-IU    
13978         ISIG(NCHN,2)=IL 
13979         ISIG(NCHN,3)=1  
13980         SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))  
13981   840   CONTINUE    
13982     
13983       ELSEIF(ISUB.EQ.143) THEN  
13984 C...f + fb -> R.    

13985         CALL PYWIDT(40,SQRT(SH),WDTP,WDTE)  
13986         FACR=COMFAC*(AEM/XW)**2*1./9.*SH2/((SH-SQMR)**2+GMMR**2)    
13987         DO 860 I=MIN1,MAX1  
13988         IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860   
13989         IA=IABS(I)  
13990         DO 850 J=MIN2,MAX2  
13991         IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850   
13992         JA=IABS(J)  
13993         IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 850   
13994         NCHN=NCHN+1 
13995         ISIG(NCHN,1)=I  
13996         ISIG(NCHN,2)=J  
13997         ISIG(NCHN,3)=1  
13998         SIGH(NCHN)=FACR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))  
13999   850   CONTINUE    
14000   860   CONTINUE    
14001     
14002       ENDIF 
14003     
14004 C...I: 2 -> 2, tree diagrams, non-standard model processes. 

14005     
14006       ELSE  
14007       IF(ISUB.EQ.161) THEN  
14008 
14009 clin-7/2018 add "CALL PYWIDT()" to get rid of compiler warning message;

14010 c     however, expect this statement not to be reached:

14011         CALL PYWIDT(40,SQRT(SH),WDTP,WDTE)  
14012 C...f + g -> f' + H+/- (q + g -> q' + H+/- only).   

14013 c     if reached, write a message to standard output and then stop the run:

14014         write(6,*) 'ISUB=161 reached: check arguments of CALL PYWIDT()'
14015         stop
14016 clin-7/2018-end

14017 
14018         FHCQ=COMFAC*FACA*AS*AEM/XW*1./24    
14019         DO 900 I=1,MSTP(54) 
14020         IU=I+MOD(I,2)   
14021         SQMQ=PMAS(IU,1)**2  
14022         FACHCQ=FHCQ/PARU(121)*SQMQ/SQMW*(SH/(SQMQ-UH)+  
14023      &  2.*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+   
14024      &  2.*SQMQ/(SQMQ-UH)+2.*(SQMHC-UH)/(SQMQ-UH)*(SQMHC-SQMQ-SH)/SH)   
14025         IF(KFAC(1,-I)*KFAC(2,21).EQ.0) GOTO 870 
14026         KCHHC=ISIGN(1,-KCHG(I,1))   
14027         NCHN=NCHN+1 
14028         ISIG(NCHN,1)=-I 
14029         ISIG(NCHN,2)=21 
14030         ISIG(NCHN,3)=1  
14031         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
14032   870   IF(KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 880  
14033         KCHHC=ISIGN(1,KCHG(I,1))    
14034         NCHN=NCHN+1 
14035         ISIG(NCHN,1)=I  
14036         ISIG(NCHN,2)=21 
14037         ISIG(NCHN,3)=1  
14038         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
14039   880   IF(KFAC(1,21)*KFAC(2,-I).EQ.0) GOTO 890 
14040         KCHHC=ISIGN(1,-KCHG(I,1))   
14041         NCHN=NCHN+1 
14042         ISIG(NCHN,1)=21 
14043         ISIG(NCHN,2)=-I 
14044         ISIG(NCHN,3)=1  
14045         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
14046   890   IF(KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 900  
14047         KCHHC=ISIGN(1,KCHG(I,1))    
14048         NCHN=NCHN+1 
14049         ISIG(NCHN,1)=21 
14050         ISIG(NCHN,2)=I  
14051         ISIG(NCHN,3)=1  
14052         SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) 
14053   900   CONTINUE    
14054     
14055       ENDIF 
14056       ENDIF 
14057     
14058 C...Multiply with structure functions.  

14059       IF(ISUB.LE.90.OR.ISUB.GE.96) THEN 
14060         DO 910 ICHN=1,NCHN  
14061         IF(MINT(41).EQ.2) THEN  
14062           KFL1=ISIG(ICHN,1) 
14063           IF(KFL1.EQ.21) KFL1=0 
14064           SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)    
14065         ENDIF   
14066         IF(MINT(42).EQ.2) THEN  
14067           KFL2=ISIG(ICHN,2) 
14068           IF(KFL2.EQ.21) KFL2=0 
14069           SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)    
14070         ENDIF   
14071   910   SIGS=SIGS+SIGH(ICHN)    
14072       ENDIF 
14073     
14074       RETURN    
14075       END   
14076     
14077 C*********************************************************************  

14078     
14079       SUBROUTINE PYSTFU(KF,X,Q2,XPQ,JBT)    
14080 
14081 C                        *******JBT specifies beam or target of the particle

14082 C...Gives proton and pi+ parton structure functions according to a few  

14083 C...different parametrizations. Note that what is coded is x times the  

14084 C...probability distribution, i.e. xq(x,Q2) etc.    

14085       COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
14086       SAVE /HPARNT/
14087       COMMON/hjcrdn/YP(3,300),YT(3,300)
14088       SAVE /hjcrdn/
14089 C                        ********COMMON BLOCK FROM HIJING

14090       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14091       SAVE /LUDAT1/ 
14092       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
14093       SAVE /LUDAT2/ 
14094       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
14095       SAVE /PYPARS/ 
14096       COMMON/PYINT1/MINT(400),VINT(400) 
14097       SAVE /PYINT1/ 
14098       DIMENSION XPQ(-6:6),XQ(6),TX(6),TT(6),TS(6),NEHLQ(8,2),   
14099      &CEHLQ(6,6,2,8,2),CDO(3,6,5,2),COW(3,5,4,2)    
14100     
14101 C...The following data lines are coefficients needed in the 

14102 C...Eichten, Hinchliffe, Lane, Quigg proton structure function  

14103 C...parametrizations, see below.    

14104 C...Powers of 1-x in different cases.   

14105       DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/   
14106 C...Expansion coefficients for up valence quark distribution.   

14107       DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/  
14108      1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,    
14109      2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,    
14110      3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,    
14111      4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,    
14112      5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,    
14113      6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,    
14114      1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,    
14115      2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,    
14116      3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,    
14117      4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,    
14118      5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,    
14119      6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/    
14120       DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/  
14121      1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,    
14122      2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,    
14123      3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,    
14124      4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,    
14125      5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,    
14126      6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,    
14127      1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,    
14128      2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,    
14129      3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,    
14130      4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,    
14131      5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,    
14132      6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/    
14133 C...Expansion coefficients for down valence quark distribution. 

14134       DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/  
14135      1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,    
14136      2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,    
14137      3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,    
14138      4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,    
14139      5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,    
14140      6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,    
14141      1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,    
14142      2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,    
14143      3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,    
14144      4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,    
14145      5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,    
14146      6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/    
14147       DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/  
14148      1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,    
14149      2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,    
14150      3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,    
14151      4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,    
14152      5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,    
14153      6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,    
14154      1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,    
14155      2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,    
14156      3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,    
14157      4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,    
14158      5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,    
14159      6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/    
14160 C...Expansion coefficients for up and down sea quark distributions. 

14161       DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/  
14162      1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,    
14163      2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,    
14164      3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,    
14165      4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,    
14166      5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,    
14167      6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,    
14168      1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,    
14169      2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,    
14170      3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,    
14171      4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,    
14172      5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,    
14173      6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/    
14174       DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/  
14175      1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,    
14176      2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,    
14177      3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,    
14178      4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,    
14179      5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,    
14180      6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,    
14181      1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,    
14182      2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,    
14183      3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,    
14184      4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,    
14185      5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,    
14186      6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/    
14187 C...Expansion coefficients for gluon distribution.  

14188       DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/  
14189      1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,    
14190      2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,    
14191      3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,    
14192      4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,    
14193      5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,    
14194      6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,    
14195      1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,    
14196      2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,    
14197      3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,    
14198      4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,    
14199      5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,    
14200      6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/    
14201       DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/  
14202      1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,    
14203      2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,    
14204      3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,    
14205      4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,    
14206      5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,    
14207      6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,    
14208      1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,    
14209      2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,    
14210      3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,    
14211      4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,    
14212      5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,    
14213      6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/    
14214 C...Expansion coefficients for strange sea quark distribution.  

14215       DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/  
14216      1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,    
14217      2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,    
14218      3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,    
14219      4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,    
14220      5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,    
14221      6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,    
14222      1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,    
14223      2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,    
14224      3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,    
14225      4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,    
14226      5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,    
14227      6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/    
14228       DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/  
14229      1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,    
14230      2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,    
14231      3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,    
14232      4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,    
14233      5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,    
14234      6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,    
14235      1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,    
14236      2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,    
14237      3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,    
14238      4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,    
14239      5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,    
14240      6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/    
14241 C...Expansion coefficients for charm sea quark distribution.    

14242       DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/  
14243      1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,    
14244      2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,    
14245      3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,    
14246      4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,    
14247      5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,    
14248      6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,    
14249      1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,    
14250      2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,    
14251      3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,    
14252      4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,    
14253      5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,    
14254      6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/    
14255       DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/  
14256      1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,    
14257      2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,    
14258      3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,    
14259      4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,    
14260      5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,    
14261      6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,    
14262      1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,    
14263      2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,    
14264      3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,    
14265      4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,    
14266      5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,    
14267      6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/    
14268 C...Expansion coefficients for bottom sea quark distribution.   

14269       DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/  
14270      1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,    
14271      2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,    
14272      3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,    
14273      4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,    
14274      5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,    
14275      6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,    
14276      1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,    
14277      2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,    
14278      3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,    
14279      4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,    
14280      5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,    
14281      6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/    
14282       DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/  
14283      1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,    
14284      2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,    
14285      3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,    
14286      4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,    
14287      5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,    
14288      6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,    
14289      1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,    
14290      2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,    
14291      3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,    
14292      4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,    
14293      5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,    
14294      6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/    
14295 C...Expansion coefficients for top sea quark distribution.  

14296       DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/  
14297      1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,    
14298      2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,    
14299      3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,    
14300      4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,    
14301      5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,    
14302      6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,    
14303      1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,    
14304      2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,    
14305      3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,    
14306      4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,    
14307      5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,    
14308      6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/    
14309       DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/  
14310      1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,    
14311      2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,    
14312      3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,    
14313      4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,    
14314      5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,    
14315      6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,    
14316      1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,    
14317      2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,    
14318      3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,    
14319      4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,    
14320      5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,    
14321      6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/    
14322     
14323 C...The following data lines are coefficients needed in the 

14324 C...Duke, Owens proton structure function parametrizations, see below.  

14325 C...Expansion coefficients for (up+down) valence quark distribution.    

14326       DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/    
14327      1 4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14328      2 4.000E-03, 7.240E-01,-4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14329      3-7.000E-03,-6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/    
14330       DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/    
14331      1 3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14332      2 1.400E-02, 7.530E-01,-6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14333      3 0.000E+00,-7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/    
14334 C...Expansion coefficients for down valence quark distribution. 

14335       DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/    
14336      1 7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14337      2-2.370E-01, 6.270E-01,-4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00,    
14338      3 2.600E-02,-1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/    
14339       DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/    
14340      1 7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14341      2-2.320E-01, 6.270E-01,-4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00,    
14342      3 2.300E-02,-1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/    
14343 C...Expansion coefficients for (up+down+strange) sea quark distribution.    

14344       DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/    
14345      1 1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14346      2-1.132E+00,-3.720E-01, 1.590E+00, 6.310E+00,-1.050E+01, 1.470E+01,    
14347      3 2.930E-01,-2.900E-02,-1.530E-01,-2.730E-01,-3.170E+00, 9.800E+00/    
14348       DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/    
14349      1 1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14350      2-1.920E+00,-2.730E-01, 5.300E-01, 1.570E+01,-1.010E+02, 2.230E+02,    
14351      3 5.820E-01,-1.640E-01,-7.630E-01,-2.830E+00, 4.470E+01,-1.170E+02/    
14352 C...Expansion coefficients for charm sea quark distribution.    

14353       DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/    
14354      1 0.000E+00,-3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14355      2 1.350E-01,-2.220E-01, 3.260E+00,-3.030E+00, 1.740E+01,-1.790E+01,    
14356      3-7.500E-02,-5.800E-02,-9.090E-01, 1.500E+00,-1.130E+01, 1.560E+01/    
14357        DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/   
14358      1 0.000E+00,-1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00,    
14359      2 6.700E-02,-2.330E-01, 3.660E+00,-4.740E-01, 9.500E+00,-1.660E+01,    
14360      3-3.100E-02,-2.300E-02,-4.530E-01, 3.580E-01,-5.430E+00, 1.550E+01/    
14361 C...Expansion coefficients for gluon distribution.  

14362       DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/    
14363      1 1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,    
14364      2-1.710E+00,-9.490E-01, 1.440E+00,-7.190E+00,-1.650E+01, 1.530E+01,    
14365      3 6.380E-01, 3.250E-01,-1.050E+00, 2.550E-01, 1.090E+01,-1.010E+01/    
14366       DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/    
14367      1 8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,    
14368      2-9.710E-01,-1.160E+00, 1.230E+00,-5.640E+00,-7.540E+00,-5.960E-01,    
14369      3 4.340E-01, 4.760E-01,-2.540E-01,-8.170E-01, 5.500E+00, 1.260E-01/    
14370     
14371 C...The following data lines are coefficients needed in the 

14372 C...Owens pion structure function parametrizations, see below.  

14373 C...Expansion coefficients for up and down valence quark distributions. 

14374       DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/    
14375      1  4.0000E-01,  7.0000E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
14376      2 -6.2120E-02,  6.4780E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
14377      3 -7.1090E-03,  1.3350E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/ 
14378       DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/    
14379      1  4.0000E-01,  6.2800E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
14380      2 -5.9090E-02,  6.4360E-01,  0.0000E+00,  0.0000E+00,  0.0000E+00, 
14381      3 -6.5240E-03,  1.4510E-02,  0.0000E+00,  0.0000E+00,  0.0000E+00/ 
14382 C...Expansion coefficients for gluon distribution.  

14383       DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/    
14384      1  8.8800E-01,  0.0000E+00,  3.1100E+00,  6.0000E+00,  0.0000E+00, 
14385      2 -1.8020E+00, -1.5760E+00, -1.3170E-01,  2.8010E+00, -1.7280E+01, 
14386      3  1.8120E+00,  1.2000E+00,  5.0680E-01, -1.2160E+01,  2.0490E+01/ 
14387       DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/    
14388      1  7.9400E-01,  0.0000E+00,  2.8900E+00,  6.0000E+00,  0.0000E+00, 
14389      2 -9.1440E-01, -1.2370E+00,  5.9660E-01, -3.6710E+00, -8.1910E+00, 
14390      3  5.9660E-01,  6.5820E-01, -2.5500E-01, -2.3040E+00,  7.7580E+00/ 
14391 C...Expansion coefficients for (up+down+strange) quark sea distribution.    

14392       DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/    
14393      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00, 
14394      2 -2.4280E-01, -2.1200E-01,  8.6730E-01,  1.2660E+00,  2.3820E+00, 
14395      3  1.3860E-01,  3.6710E-03,  4.7470E-02, -2.2150E+00,  3.4820E-01/ 
14396       DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/    
14397      1  9.0000E-01,  0.0000E+00,  5.0000E+00,  0.0000E+00,  0.0000E+00, 
14398      2 -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00,  5.6210E-01, 
14399      3 -1.7400E-01, -9.6230E-02,  1.5750E+00,  1.3780E+00, -2.7010E-01/ 
14400 C...Expansion coefficients for charm quark sea distribution.    

14401       DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/    
14402      1  0.0000E+00, -2.2120E-02,  2.8940E+00,  0.0000E+00,  0.0000E+00, 
14403      2  7.9280E-02, -3.7850E-01,  9.4330E+00,  5.2480E+00,  8.3880E+00, 
14404      3 -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/ 
14405       DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/    
14406      1  0.0000E+00, -8.8200E-02,  1.9240E+00,  0.0000E+00,  0.0000E+00, 
14407      2  6.2290E-02, -2.8920E-01,  2.4240E-01, -4.4630E+00, -8.3670E-01, 
14408      3 -4.0990E-02, -1.0820E-01,  2.0360E+00,  5.2090E+00, -4.8400E-02/ 
14409 
14410 C...Euler's beta function, requires ordinary Gamma function 

14411 clin-10/25/02 get rid of argument usage mismatch in PYGAMM():

14412 c      EULBT(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)

14413     
14414 C...Reset structure functions, check x and hadron flavour.  

14415       ALAM=0.   
14416       DO 100 KFL=-6,6   
14417   100 XPQ(KFL)=0.   
14418       IF(X.LT.0..OR.X.GT.1.) THEN   
14419         WRITE(MSTU(11),1000) X  
14420         RETURN  
14421       ENDIF 
14422       KFA=IABS(KF)  
14423       IF(KFA.NE.211.AND.KFA.NE.2212.AND.KFA.NE.2112) THEN   
14424         WRITE(MSTU(11),1100) KF 
14425         RETURN  
14426       ENDIF 
14427     
14428 C...Call user-supplied structure function. Select proton/neutron/pion.  

14429       IF(MSTP(51).EQ.0.OR.MSTP(52).GE.2) THEN   
14430         KFE=KFA 
14431         IF(KFA.EQ.2112) KFE=2212    
14432         CALL PYSTFE(KFE,X,Q2,XPQ)   
14433         GOTO 230    
14434       ENDIF 
14435       IF(KFA.EQ.211) GOTO 200   
14436     
14437       IF(MSTP(51).EQ.1.OR.MSTP(51).EQ.2) THEN   
14438 C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.   

14439 C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1    

14440     
14441 C...Determine set, Lamdba and x and t expansion variables.  

14442         NSET=MSTP(51)   
14443         IF(NSET.EQ.1) ALAM=0.2  
14444         IF(NSET.EQ.2) ALAM=0.29 
14445         TMIN=LOG(5./ALAM**2)    
14446         TMAX=LOG(1E8/ALAM**2)   
14447         IF(MSTP(52).EQ.0) THEN  
14448           T=TMIN    
14449         ELSE    
14450           T=LOG(Q2/ALAM**2) 
14451         ENDIF   
14452         VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))    
14453         NX=1    
14454         IF(X.LE.0.1) NX=2   
14455         IF(NX.EQ.1) VX=(2.*X-1.1)/0.9   
14456         IF(NX.EQ.2) VX=MAX(-1.,(2.*LOG(X)+11.51293)/6.90776)    
14457         CXS=1.  
14458         IF(X.LT.1E-4.AND.ABS(PARP(51)-1.).GT.0.01) CXS= 
14459      &  (1E-4/X)**(PARP(51)-1.) 
14460     
14461 C...Chebyshev polynomials for x and t expansion.    

14462         TX(1)=1.    
14463         TX(2)=VX    
14464         TX(3)=2.*VX**2-1.   
14465         TX(4)=4.*VX**3-3.*VX    
14466         TX(5)=8.*VX**4-8.*VX**2+1.  
14467         TX(6)=16.*VX**5-20.*VX**3+5.*VX 
14468         TT(1)=1.    
14469         TT(2)=VT    
14470         TT(3)=2.*VT**2-1.   
14471         TT(4)=4.*VT**3-3.*VT    
14472         TT(5)=8.*VT**4-8.*VT**2+1.  
14473         TT(6)=16.*VT**5-20.*VT**3+5.*VT 
14474     
14475 C...Calculate structure functions.  

14476         DO 120 KFL=1,6  
14477         XQSUM=0.    
14478         DO 110 IT=1,6   
14479         DO 110 IX=1,6   
14480   110   XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)  
14481   120   XQ(KFL)=XQSUM*(1.-X)**NEHLQ(KFL,NSET)*CXS   
14482     
14483 C...Put into output array.  

14484         XPQ(0)=XQ(4)    
14485         XPQ(1)=XQ(2)+XQ(3)  
14486         XPQ(2)=XQ(1)+XQ(3)  
14487         XPQ(3)=XQ(5)    
14488         XPQ(4)=XQ(6)    
14489         XPQ(-1)=XQ(3)   
14490         XPQ(-2)=XQ(3)   
14491         XPQ(-3)=XQ(5)   
14492         XPQ(-4)=XQ(6)   
14493     
14494 C...Special expansion for bottom (thresh effects).   

14495         IF(MSTP(54).GE.5) THEN  
14496           IF(NSET.EQ.1) TMIN=8.1905 
14497           IF(NSET.EQ.2) TMIN=7.4474 
14498           IF(T.LE.TMIN) GOTO 140    
14499           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))  
14500           TT(1)=1.  
14501           TT(2)=VT  
14502           TT(3)=2.*VT**2-1. 
14503           TT(4)=4.*VT**3-3.*VT  
14504           TT(5)=8.*VT**4-8.*VT**2+1.    
14505           TT(6)=16.*VT**5-20.*VT**3+5.*VT   
14506           XQSUM=0.  
14507           DO 130 IT=1,6 
14508           DO 130 IX=1,6 
14509   130     XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)  
14510           XPQ(5)=XQSUM*(1.-X)**NEHLQ(7,NSET)    
14511           XPQ(-5)=XPQ(5)    
14512   140     CONTINUE  
14513         ENDIF   
14514     
14515 C...Special expansion for top (thresh effects).  

14516         IF(MSTP(54).GE.6) THEN  
14517           IF(NSET.EQ.1) TMIN=11.5528    
14518           IF(NSET.EQ.2) TMIN=10.8097    
14519           TMIN=TMIN+2.*LOG(PMAS(6,1)/30.)   
14520           TMAX=TMAX+2.*LOG(PMAS(6,1)/30.)   
14521           IF(T.LE.TMIN) GOTO 160    
14522           VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))  
14523           TT(1)=1.  
14524           TT(2)=VT  
14525           TT(3)=2.*VT**2-1. 
14526           TT(4)=4.*VT**3-3.*VT  
14527           TT(5)=8.*VT**4-8.*VT**2+1.    
14528           TT(6)=16.*VT**5-20.*VT**3+5.*VT   
14529           XQSUM=0.  
14530           DO 150 IT=1,6 
14531           DO 150 IX=1,6 
14532   150     XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)  
14533           XPQ(6)=XQSUM*(1.-X)**NEHLQ(8,NSET)    
14534           XPQ(-6)=XPQ(6)    
14535   160     CONTINUE  
14536         ENDIF   
14537     
14538       ELSEIF(MSTP(51).EQ.3.OR.MSTP(51).EQ.4) THEN   
14539 C...Proton structure functions from Duke, Owens.    

14540 C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.  

14541     
14542 C...Determine set, Lambda and s expansion parameter.    

14543         NSET=MSTP(51)-2 
14544         IF(NSET.EQ.1) ALAM=0.2  
14545         IF(NSET.EQ.2) ALAM=0.4  
14546         IF(MSTP(52).LE.0) THEN  
14547           SD=0. 
14548         ELSE    
14549           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))   
14550         ENDIF   
14551     
14552 C...Calculate structure functions.  

14553         DO 180 KFL=1,5  
14554         DO 170 IS=1,6   
14555   170   TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+    
14556      &  CDO(3,IS,KFL,NSET)*SD**2    
14557         IF(KFL.LE.2) THEN   
14558 
14559 clin-10/25/02 evaluate EULBT(TS(1),TS(2)+1.):

14560 c          XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT(TS(1),    

14561 c     &    TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))  

14562            eulbt1=PYGAMM(TS(1))*PYGAMM(TS(2)+1.)/PYGAMM(TS(1)+TS(2)+1.)
14563            XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT1
14564      &          *(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))  
14565         ELSE    
14566            XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2+  
14567      &    TS(6)*X**3)   
14568         ENDIF   
14569 
14570 
14571   180   CONTINUE    
14572     
14573 C...Put into output arrays. 

14574         XPQ(0)=XQ(5)    
14575         XPQ(1)=XQ(2)+XQ(3)/6.   
14576         XPQ(2)=3.*XQ(1)-XQ(2)+XQ(3)/6.  
14577         XPQ(3)=XQ(3)/6. 
14578         XPQ(4)=XQ(4)    
14579         XPQ(-1)=XQ(3)/6.    
14580         XPQ(-2)=XQ(3)/6.    
14581         XPQ(-3)=XQ(3)/6.    
14582         XPQ(-4)=XQ(4)   
14583     
14584 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 

14585 C...These are accessed via PYSTFE since the files needed may not always 

14586 C...available.  

14587       ELSEIF(MSTP(51).GE.11.AND.MSTP(51).LE.13) THEN    
14588         CALL PYSTFE(2212,X,Q2,XPQ)  
14589     
14590 C...Unknown proton parametrization. 

14591       ELSE  
14592         WRITE(MSTU(11),1200) MSTP(51)   
14593       ENDIF 
14594       GOTO 230  
14595     
14596   200 IF((MSTP(51).GE.1.AND.MSTP(51).LE.4).OR.  
14597      &(MSTP(51).GE.11.AND.MSTP(51).LE.13)) THEN 
14598 C...Pion structure functions from Owens.    

14599 C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2. 

14600     
14601 C...Determine set, Lambda and s expansion variable. 

14602         NSET=1  
14603         IF(MSTP(51).EQ.2.OR.MSTP(51).EQ.4.OR.MSTP(51).EQ.13) NSET=2 
14604         IF(NSET.EQ.1) ALAM=0.2  
14605         IF(NSET.EQ.2) ALAM=0.4  
14606         IF(MSTP(52).LE.0) THEN  
14607           SD=0. 
14608         ELSE    
14609           SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))   
14610         ENDIF   
14611     
14612 C...Calculate structure functions.  

14613         DO 220 KFL=1,4  
14614         DO 210 IS=1,5   
14615   210   TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+    
14616      &  COW(3,IS,KFL,NSET)*SD**2    
14617         IF(KFL.EQ.1) THEN   
14618 
14619 clin-10/25/02 get rid of argument usage mismatch in PYGAMM():

14620 c          XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT(TS(1),TS(2)+1.) 

14621            eulbt2=PYGAMM(TS(1))*PYGAMM(TS(2)+1.)/PYGAMM(TS(1)+TS(2)+1.)
14622            XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT2
14623         ELSE    
14624           XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2)  
14625         ENDIF   
14626   220   CONTINUE    
14627     
14628 C...Put into output arrays. 

14629         XPQ(0)=XQ(2)    
14630         XPQ(1)=XQ(3)/6. 
14631         XPQ(2)=XQ(1)+XQ(3)/6.   
14632         XPQ(3)=XQ(3)/6. 
14633         XPQ(4)=XQ(4)    
14634         XPQ(-1)=XQ(1)+XQ(3)/6.  
14635         XPQ(-2)=XQ(3)/6.    
14636         XPQ(-3)=XQ(3)/6.    
14637         XPQ(-4)=XQ(4)   
14638     
14639 C...Unknown pion parametrization.   

14640       ELSE  
14641         WRITE(MSTU(11),1200) MSTP(51)   
14642       ENDIF 
14643     
14644 C...Isospin conjugation for neutron, charge conjugation for antipart.   

14645   230 IF(KFA.EQ.2112) THEN  
14646         XPS=XPQ(1)  
14647         XPQ(1)=XPQ(2)   
14648         XPQ(2)=XPS  
14649         XPS=XPQ(-1) 
14650         XPQ(-1)=XPQ(-2) 
14651         XPQ(-2)=XPS 
14652       ENDIF 
14653       IF(KF.LT.0) THEN  
14654         DO 240 KFL=1,4  
14655         XPS=XPQ(KFL)    
14656         XPQ(KFL)=XPQ(-KFL)  
14657   240   XPQ(-KFL)=XPS   
14658       ENDIF 
14659     
14660 C...Check positivity and reset above maximum allowed flavour.   

14661       DO 250 KFL=-6,6   
14662       XPQ(KFL)=MAX(0.,XPQ(KFL)) 
14663   250 IF(IABS(KFL).GT.MSTP(54)) XPQ(KFL)=0. 
14664 
14665 C...consider nuclear effect on the structure function

14666               IF((JBT.NE.1.AND.JBT.NE.2).OR.IHPR2(6).EQ.0
14667      &                  .OR.IHNT2(16).EQ.1) GO TO 400
14668               ATNM=IHNT2(2*JBT-1)
14669               IF(ATNM.LE.1.0) GO TO 400
14670               IF(JBT.EQ.1) THEN
14671                BBR2=(YP(1,IHNT2(11))**2+YP(2,IHNT2(11))**2)/1.44/
14672      1              ATNM**0.66666
14673               ELSEIF(JBT.EQ.2) THEN
14674                BBR2=(YT(1,IHNT2(12))**2+YT(2,IHNT2(12))**2)/1.44/
14675      1              ATNM**0.66666
14676               ENDIF
14677               BBR2=MIN(1.0,BBR2)
14678         ABX=(ATNM**0.33333333-1.0)
14679               APX=HIPR1(6)*4.0/3.0*ABX*SQRT(1.0-BBR2)
14680               AAX=1.192*ALOG(ATNM)**0.1666666
14681               RRX=AAX*(X**3-1.2*X**2+0.21*X)+1.0
14682      &           -(APX-1.079*ABX*SQRT(X)/ALOG(ATNM+1.0))
14683      1           *EXP(-X**2.0/0.01)
14684               DO 300 KFL=-6,6
14685                 XPQ(KFL)=XPQ(KFL)*RRX
14686 300           CONTINUE
14687 C                        ********consider the nuclear effect on the structure

14688 C                                function which also depends on the impact

14689 C                                parameter of the nuclear reaction

14690 
14691  400          CONTINUE    
14692 C...Formats for error printouts.    

14693  1000 FORMAT(' Error: x value outside physical range, x =',1P,E12.3)    
14694  1100 FORMAT(' Error: illegal particle code for structure function,',   
14695      &' KF =',I5)   
14696  1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',  
14697      &' MSTP(51) =',I5) 
14698     
14699       RETURN    
14700       END   
14701     
14702 C*********************************************************************  

14703     
14704       SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)   
14705     
14706 C...In case of a hadron remnant which is more complicated than just a   

14707 C...quark or a diquark, split it into two (partons or hadron + parton). 

14708       DIMENSION KFL(3)  
14709     
14710 C...Preliminaries. Parton composition.  

14711       KFA=IABS(KF)  
14712       KFS=ISIGN(1,KF)   
14713       KFL(1)=MOD(KFA/1000,10)   
14714       KFL(2)=MOD(KFA/100,10)    
14715       KFL(3)=MOD(KFA/10,10) 
14716       KFLR=KFLIN*KFS    
14717       KFLCH=0   
14718     
14719 C...Subdivide meson.    

14720       IF(KFL(1).EQ.0) THEN  
14721         KFL(2)=KFL(2)*(-1)**KFL(2)  
14722         KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))   
14723         IF(KFLR.EQ.KFL(2)) THEN 
14724           KFLSP=KFL(3)  
14725         ELSEIF(KFLR.EQ.KFL(3)) THEN 
14726           KFLSP=KFL(2)  
14727         ELSEIF(IABS(KFLR).EQ.21.AND.RLU(0).GT.0.5) THEN 
14728           KFLSP=KFL(2)  
14729           KFLCH=KFL(3)  
14730         ELSEIF(IABS(KFLR).EQ.21) THEN   
14731           KFLSP=KFL(3)  
14732           KFLCH=KFL(2)  
14733         ELSEIF(KFLR*KFL(2).GT.0) THEN   
14734           CALL LUKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)    
14735           KFLSP=KFL(3)  
14736         ELSE    
14737           CALL LUKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)    
14738           KFLSP=KFL(2)  
14739         ENDIF   
14740     
14741 C...Subdivide baryon.   

14742       ELSE  
14743         NAGR=0  
14744         DO 100 J=1,3    
14745   100   IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1  
14746         IF(NAGR.GE.1) THEN  
14747           RAGR=0.00001+(NAGR-0.00002)*RLU(0)    
14748           IAGR=0    
14749           DO 110 J=1,3  
14750           IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1.   
14751   110     IF(IAGR.EQ.0.AND.RAGR.LE.0.) IAGR=J   
14752         ELSE    
14753           IAGR=int(1.00001+2.99998*RLU(0))
14754         ENDIF   
14755         ID1=1   
14756         IF(IAGR.EQ.1) ID1=2 
14757         IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3    
14758         ID2=6-IAGR-ID1  
14759         KSP=3   
14760         IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN  
14761           IF(IAGR.NE.3.AND.RLU(0).GT.0.25) KSP=1    
14762         ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN  
14763           IF(IAGR.NE.1.AND.RLU(0).GT.0.25) KSP=1    
14764         ELSEIF(MOD(KFA,10).EQ.2) THEN   
14765           IF(IAGR.EQ.1) KSP=1   
14766           IF(IAGR.NE.1.AND.RLU(0).GT.0.75) KSP=1    
14767         ENDIF   
14768         KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP    
14769         IF(KFLIN.EQ.21) THEN    
14770           KFLCH=KFL(IAGR)   
14771         ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN    
14772           CALL LUKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH) 
14773         ELSEIF(NAGR.EQ.0) THEN  
14774           CALL LUKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)   
14775           KFLSP=KFL(IAGR)   
14776         ENDIF   
14777       ENDIF 
14778     
14779 C...Add on correct sign for result. 

14780       KFLCH=KFLCH*KFS   
14781       KFLSP=KFLSP*KFS   
14782     
14783       RETURN    
14784       END   
14785     
14786 C*********************************************************************  

14787     
14788       FUNCTION PYGAMM(X)    
14789     
14790 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;    

14791 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions 

14792 C...(Dover, 1965) 6.1.36.   

14793       DIMENSION B(8)    
14794 clin      DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857, 

14795 clin     &-0.756704078,0.482199394,-0.193527818,0.035868343/    

14796       DATA B/-0.57719165,0.98820589,-0.89705694,0.91820686, 
14797      &-0.75670408,0.48219939,-0.19352782,0.03586834/    
14798     
14799       NX=INT(X) 
14800       DX=X-NX   
14801     
14802       PYGAMM=1. 
14803       DO 100 I=1,8  
14804   100 PYGAMM=PYGAMM+B(I)*DX**I  
14805       IF(X.LT.1.) THEN  
14806         PYGAMM=PYGAMM/X 
14807       ELSE  
14808         DO 110 IX=1,NX-1    
14809   110   PYGAMM=(X-IX)*PYGAMM    
14810       ENDIF 
14811     
14812       RETURN    
14813       END   
14814     
14815 C***********************************************************************    

14816     
14817       FUNCTION PYW1AU(EPS,IREIM)    
14818     
14819 C...Calculates real and imaginary parts of the auxiliary function W1;   

14820 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   

14821 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    

14822       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14823       SAVE /LUDAT1/ 
14824     
14825 clin-8/2014:

14826 c      ASINH(X)=LOG(X+SQRT(X**2+1.)) 

14827       ACOSH(X)=LOG(X+SQRT(X**2-1.)) 
14828     
14829       IF(EPS.LT.0.) THEN    
14830         W1RE=2.*SQRT(1.-EPS)*ASINH(SQRT(-1./EPS))   
14831         W1IM=0. 
14832       ELSEIF(EPS.LT.1.) THEN    
14833         W1RE=2.*SQRT(1.-EPS)*ACOSH(SQRT(1./EPS))    
14834         W1IM=-PARU(1)*SQRT(1.-EPS)  
14835       ELSE  
14836         W1RE=2.*SQRT(EPS-1.)*ASIN(SQRT(1./EPS)) 
14837         W1IM=0. 
14838       ENDIF 
14839     
14840       PYW1AU = 0.
14841       IF(IREIM.EQ.1) PYW1AU=W1RE    
14842       IF(IREIM.EQ.2) PYW1AU=W1IM    
14843     
14844       RETURN    
14845       END   
14846     
14847 C***********************************************************************    

14848     
14849       FUNCTION PYW2AU(EPS,IREIM)    
14850     
14851 C...Calculates real and imaginary parts of the auxiliary function W2;   

14852 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   

14853 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    

14854       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14855       SAVE /LUDAT1/ 
14856     
14857 clin-8/2014:

14858 c      ASINH(X)=LOG(X+SQRT(X**2+1.)) 

14859       ACOSH(X)=LOG(X+SQRT(X**2-1.)) 
14860     
14861       IF(EPS.LT.0.) THEN    
14862         W2RE=4.*(ASINH(SQRT(-1./EPS)))**2   
14863         W2IM=0. 
14864       ELSEIF(EPS.LT.1.) THEN    
14865         W2RE=4.*(ACOSH(SQRT(1./EPS)))**2-PARU(1)**2 
14866         W2IM=-4.*PARU(1)*ACOSH(SQRT(1./EPS))    
14867       ELSE  
14868         W2RE=-4.*(ASIN(SQRT(1./EPS)))**2    
14869         W2IM=0. 
14870       ENDIF 
14871     
14872 cms ... else needed to avoid compiler warning

14873       PYW2AU = 0.
14874       IF(IREIM.EQ.1) THEN
14875         PYW2AU=W2RE    
14876       ELSEIF(IREIM.EQ.2) THEN
14877         PYW2AU=W2IM    
14878       ENDIF
14879 
14880       RETURN    
14881       END   
14882     
14883 C***********************************************************************    

14884     
14885       FUNCTION PYI3AU(BE,EPS,IREIM) 
14886     
14887 C...Calculates real and imaginary parts of the auxiliary function I3;   

14888 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   

14889 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    

14890       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14891       SAVE /LUDAT1/ 
14892 
14893 cms ... needed to avoid compiler warning

14894       GA=0.5
14895       IF(EPS.LT.1.) GA=0.5*(1.+SQRT(1.-EPS))    
14896 
14897       IF(EPS.LT.0.) THEN    
14898         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+    
14899      &  PYSPEN((BE-GA)/BE,0.,1)-PYSPEN((BE-GA)/(BE-1.),0.,1)+   
14900      &  (LOG(BE)**2-LOG(BE-1.)**2)/2.+LOG(GA)*LOG((GA+BE-1.)/BE)+   
14901      &  LOG(GA-1.)*LOG((BE-1.)/(GA+BE-1.))  
14902         F3IM=0. 
14903       ELSEIF(EPS.LT.1.) THEN    
14904         F3RE=PYSPEN((GA-1.)/(GA+BE-1.),0.,1)-PYSPEN(GA/(GA+BE-1.),0.,1)+    
14905      &  PYSPEN(GA/(GA-BE),0.,1)-PYSPEN((GA-1.)/(GA-BE),0.,1)+   
14906      &  LOG(GA/(1.-GA))*LOG((GA+BE-1.)/(BE-GA)) 
14907         F3IM=-PARU(1)*LOG((GA+BE-1.)/(BE-GA))   
14908       ELSE  
14909         RSQ=EPS/(EPS-1.+(2.*BE-1.)**2)  
14910         RCTHE=RSQ*(1.-2.*BE/EPS)    
14911         RSTHE=SQRT(RSQ-RCTHE**2)    
14912         RCPHI=RSQ*(1.+2.*(BE-1.)/EPS)   
14913         RSPHI=SQRT(RSQ-RCPHI**2)    
14914         R=SQRT(RSQ) 
14915         THE=ACOS(RCTHE/R)   
14916         PHI=ACOS(RCPHI/R)   
14917         F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-  
14918      &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+   
14919      &  (PHI-THE)*(PHI+THE-PARU(1)) 
14920         F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-  
14921      &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)    
14922       ENDIF 
14923 
14924 cms ... needed to avoid compiler warning

14925       PYI3AU = 0.
14926       IF(IREIM.EQ.1) THEN
14927         PYI3AU=2./(2.*BE-1.)*F3RE  
14928       ELSEIF(IREIM.EQ.2) THEN
14929         PYI3AU=2./(2.*BE-1.)*F3IM  
14930       ENDIF
14931 
14932       RETURN    
14933       END   
14934     
14935 C***********************************************************************    

14936     
14937       FUNCTION PYSPEN(XREIN,XIMIN,IREIM)    
14938     
14939 C...Calculates real and imaginary part of Spence function; see  

14940 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.    

14941       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
14942       SAVE /LUDAT1/ 
14943       DIMENSION B(0:14) 
14944     
14945       DATA B/   
14946      & 1.000000E+00,        -5.000000E-01,         1.666667E-01,    
14947      & 0.000000E+00,        -3.333333E-02,         0.000000E+00,    
14948      & 2.380952E-02,         0.000000E+00,        -3.333333E-02,    
14949      & 0.000000E+00,         7.575757E-02,         0.000000E+00,    
14950      &-2.531135E-01,         0.000000E+00,         1.166667E+00/    
14951     
14952       XRE=XREIN 
14953       XIM=XIMIN
14954       PYSPEN=0.
14955       IF(ABS(1.-XRE).LT.1.E-6.AND.ABS(XIM).LT.1.E-6) THEN   
14956         IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6. 
14957         IF(IREIM.EQ.2) PYSPEN=0.    
14958         RETURN  
14959       ENDIF 
14960     
14961       XMOD=SQRT(XRE**2+XIM**2)  
14962       IF(XMOD.LT.1.E-6) THEN    
14963         IF(IREIM.EQ.1) PYSPEN=0.    
14964         IF(IREIM.EQ.2) PYSPEN=0.    
14965         RETURN  
14966       ENDIF 
14967     
14968       XARG=SIGN(ACOS(XRE/XMOD),XIM) 
14969       SP0RE=0.  
14970       SP0IM=0.  
14971       SGN=1.    
14972       IF(XMOD.GT.1.) THEN   
14973         ALGXRE=LOG(XMOD)    
14974         ALGXIM=XARG-SIGN(PARU(1),XARG)  
14975         SP0RE=-PARU(1)**2/6.-(ALGXRE**2-ALGXIM**2)/2.   
14976         SP0IM=-ALGXRE*ALGXIM    
14977         SGN=-1. 
14978         XMOD=1./XMOD    
14979         XARG=-XARG  
14980         XRE=XMOD*COS(XARG)  
14981         XIM=XMOD*SIN(XARG)  
14982       ENDIF 
14983       IF(XRE.GT.0.5) THEN   
14984         ALGXRE=LOG(XMOD)    
14985         ALGXIM=XARG 
14986         XRE=1.-XRE  
14987         XIM=-XIM    
14988         XMOD=SQRT(XRE**2+XIM**2)    
14989         XARG=SIGN(ACOS(XRE/XMOD),XIM)   
14990         ALGYRE=LOG(XMOD)    
14991         ALGYIM=XARG 
14992         SP0RE=SP0RE+SGN*(PARU(1)**2/6.-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))   
14993         SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)   
14994         SGN=-SGN    
14995       ENDIF 
14996     
14997       XRE=1.-XRE    
14998       XIM=-XIM  
14999       XMOD=SQRT(XRE**2+XIM**2)  
15000       XARG=SIGN(ACOS(XRE/XMOD),XIM) 
15001       ZRE=-LOG(XMOD)    
15002       ZIM=-XARG 
15003     
15004       SPRE=0.   
15005       SPIM=0.   
15006       SAVERE=1. 
15007       SAVEIM=0. 
15008       DO 100 I=0,14 
15009       TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/FLOAT(I+1) 
15010       TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/FLOAT(I+1) 
15011       SAVERE=TERMRE 
15012       SAVEIM=TERMIM 
15013       SPRE=SPRE+B(I)*TERMRE 
15014   100 SPIM=SPIM+B(I)*TERMIM 
15015     
15016 cms ... needed to avoid compiler warning

15017       IF(IREIM.EQ.1) THEN
15018         PYSPEN=SP0RE+SGN*SPRE  
15019       ELSEIF(IREIM.EQ.2) THEN
15020         PYSPEN=SP0IM+SGN*SPIM  
15021       ENDIF
15022 
15023       RETURN    
15024       END   
15025     
15026 C*********************************************************************  

15027     
15028       BLOCK DATA PYDATA 
15029     
15030 C...Give sensible default values to all status codes and parameters.    

15031       COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200) 
15032       SAVE /PYSUBS/ 
15033       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
15034       SAVE /PYPARS/ 
15035       COMMON/PYINT1/MINT(400),VINT(400) 
15036       SAVE /PYINT1/ 
15037       COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) 
15038       SAVE /PYINT2/ 
15039       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)  
15040       SAVE /PYINT3/ 
15041       COMMON/AMPTPYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) 
15042       SAVE /AMPTPYINT4/ 
15043       COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3) 
15044       SAVE /PYINT5/ 
15045       COMMON/PYINT6/PROC(0:200) 
15046       CHARACTER PROC*28 
15047       SAVE /PYINT6/ 
15048     
15049 C...Default values for allowed processes and kinematics constraints.    

15050       DATA MSEL/1/  
15051       DATA MSUB/200*0/  
15052       DATA ((KFIN(I,J),J=-40,40),I=1,2)/40*1,0,80*1,0,40*1/ 
15053       DATA CKIN/    
15054      &   2.0, -1.0,  0.0, -1.0,  1.0,  1.0, -10.,  10., -10.,  10., 
15055      1  -10.,  10., -10.,  10., -10.,  10., -1.0,  1.0, -1.0,  1.0, 
15056      2   0.0,  1.0,  0.0,  1.0, -1.0,  1.0, -1.0,  1.0,   0.,   0., 
15057      3   2.0, -1.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15058      4   160*0./    
15059     
15060 C...Default values for main switches and parameters. Reset information. 

15061       DATA (MSTP(I),I=1,100)/   
15062      &     3,    1,    2,    0,    0,    0,    0,    0,    0,    0, 
15063      1     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15064      2     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15065      3     1,    2,    0,    0,    0,    2,    0,    0,    0,    0, 
15066      4     1,    0,    3,    7,    1,    0,    0,    0,    0,    0, 
15067      5     1,    1,   20,    6,    0,    0,    0,    0,    0,    0, 
15068      6     1,    2,    2,    2,    1,    0,    0,    0,    0,    0, 
15069      7     1,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15070      8     1,    1,  100,    0,    0,    0,    0,    0,    0,    0, 
15071      9     1,    4,    0,    0,    0,    0,    0,    0,    0,    0/ 
15072       DATA (MSTP(I),I=101,200)/ 
15073      &     1,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15074      1     1,    1,    1,    0,    0,    0,    0,    0,    0,    0, 
15075      2     0,    1,    2,    1,    1,   20,    0,    0,    0,    0, 
15076      3     0,    4,    0,    1,    0,    0,    0,    0,    0,    0, 
15077      4     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15078      5     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15079      6     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15080      7     0,    0,    0,    0,    0,    0,    0,    0,    0,    0, 
15081      8     5,    3, 1989,   11,   24,    0,    0,    0,    0,    0, 
15082      9     0,    0,    0,    0,    0,    0,    0,    0,    0,    0/ 
15083       DATA (PARP(I),I=1,100)/   
15084      &  0.25,  10.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15085      1    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15086      2    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15087      3   1.5,  2.0, 0.075,  0.,  0.2,   0.,   0.,   0.,   0.,   0., 
15088      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15089      5   1.0, 2.26, 1.E4, 1.E-4,  0.,   0.,   0.,   0.,   0.,   0., 
15090      6  0.25,  1.0, 0.25,  1.0,  2.0, 1.E-3, 4.0,   0.,   0.,   0., 
15091      7   4.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15092      8   1.6, 1.85,  0.5,  0.2, 0.33, 0.66,  0.7,  0.5,   0.,   0., 
15093      9  0.44, 0.44,  2.0,  1.0,   0.,  3.0,  1.0, 0.75,   0.,   0./ 
15094       DATA (PARP(I),I=101,200)/ 
15095      & -0.02,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15096      1   2.0,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15097      2   0.4,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15098      3  0.01,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15099      4    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15100      5    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15101      6    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15102      7    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15103      8    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0., 
15104      9    0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0.,   0./ 
15105       DATA MSTI/200*0/  
15106       DATA PARI/200*0./ 
15107       DATA MINT/400*0/  
15108       DATA VINT/400*0./ 
15109     
15110 C...Constants for the generation of the various processes.  

15111       DATA (ISET(I),I=1,100)/   
15112      &    1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,   -2,  
15113      1    2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,  
15114      2   -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,  
15115      3    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
15116      4   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
15117      5   -1,   -1,    2,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  
15118      6   -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,   -1,   -1,  
15119      7    4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,   -2,  
15120      8    2,    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15121      9    0,    0,    0,   -1,    0,    5,   -2,   -2,   -2,   -2/  
15122       DATA (ISET(I),I=101,200)/ 
15123      &   -1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15124      1    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,   -2,  
15125      2   -1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15126      3   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15127      4    1,    1,    1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15128      5   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15129      6    2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15130      7   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15131      8   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,  
15132      9   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2/  
15133       DATA ((KFPR(I,J),J=1,2),I=1,50)/  
15134      &   23,    0,   24,    0,   25,    0,   24,    0,   25,    0,  
15135      &   24,    0,   23,    0,   25,    0,    0,    0,    0,    0,  
15136      1    0,    0,    0,    0,   21,   21,   21,   22,   21,   23,  
15137      1   21,   24,   21,   25,   22,   22,   22,   23,   22,   24,  
15138      2   22,   25,   23,   23,   23,   24,   23,   25,   24,   24,  
15139      2   24,   25,   25,   25,    0,   21,    0,   22,    0,   23,  
15140      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
15141      3    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
15142      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23,  
15143      4    0,   24,    0,   25,    0,   21,    0,   22,    0,   23/  
15144       DATA ((KFPR(I,J),J=1,2),I=51,100)/    
15145      5    0,   24,    0,   25,    0,    0,    0,    0,    0,    0,  
15146      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15147      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15148      6    0,    0,    0,    0,   21,   21,   24,   24,   22,   24,  
15149      7   23,   23,   24,   24,   23,   24,   23,   25,   22,   22,  
15150      7   23,   23,   24,   24,   24,   25,   25,   25,    0,    0,  
15151      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15152      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15153      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15154      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
15155       DATA ((KFPR(I,J),J=1,2),I=101,150)/   
15156      &   23,    0,   25,    0,    0,    0,    0,    0,    0,    0,  
15157      &    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15158      1   21,   25,    0,   25,   21,   25,   22,   22,   22,   23,  
15159      1   23,   23,   24,   24,    0,    0,    0,    0,    0,    0,  
15160      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15161      2    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15162      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15163      3    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15164      4   32,    0,   37,    0,   40,    0,    0,    0,    0,    0,  
15165      4    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
15166       DATA ((KFPR(I,J),J=1,2),I=151,200)/   
15167      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15168      5    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15169      6    0,   37,    0,    0,    0,    0,    0,    0,    0,    0,  
15170      6    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15171      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15172      7    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15173      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15174      8    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15175      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0,  
15176      9    0,    0,    0,    0,    0,    0,    0,    0,    0,    0/  
15177       DATA COEF/4000*0./    
15178       DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/    
15179      1 4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2, 
15180      2 3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2, 
15181      3 3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1, 
15182      4 3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0, 
15183      5 4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3, 
15184      6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2, 
15185      7 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
15186      8 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
15187      9 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 
15188      & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ 
15189     
15190 C...Character constants: name of processes. 

15191       DATA PROC(0)/                    'All included subprocesses   '/  
15192       DATA (PROC(I),I=1,20)/    
15193      1'f + fb -> gamma*/Z0         ',  'f + fb'' -> W+/-             ', 
15194      2'f + fb -> H0                ',  'gamma + W+/- -> W+/-        ',  
15195      3'Z0 + Z0 -> H0               ',  'Z0 + W+/- -> W+/-           ',  
15196      4'                            ',  'W+ + W- -> H0               ',  
15197      5'                            ',  '                            ',  
15198      6'f + f'' -> f + f''            ','f + fb -> f'' + fb''          ',    
15199      7'f + fb -> g + g             ',  'f + fb -> g + gamma         ',  
15200      8'f + fb -> g + Z0            ',  'f + fb'' -> g + W+/-         ', 
15201      9'f + fb -> g + H0            ',  'f + fb -> gamma + gamma     ',  
15202      &'f + fb -> gamma + Z0        ',  'f + fb'' -> gamma + W+/-     '/ 
15203       DATA (PROC(I),I=21,40)/   
15204      1'f + fb -> gamma + H0        ',  'f + fb -> Z0 + Z0           ',  
15205      2'f + fb'' -> Z0 + W+/-        ', 'f + fb -> Z0 + H0           ',  
15206      3'f + fb -> W+ + W-           ',  'f + fb'' -> W+/- + H0        ', 
15207      4'f + fb -> H0 + H0           ',  'f + g -> f + g              ',  
15208      5'f + g -> f + gamma          ',  'f + g -> f + Z0             ',  
15209      6'f + g -> f'' + W+/-          ', 'f + g -> f + H0             ',  
15210      7'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',  
15211      8'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ', 
15212      9'f + gamma -> f + H0         ',  'f + Z0 -> f + g             ',  
15213      &'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/  
15214       DATA (PROC(I),I=41,60)/   
15215      1'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + H0            ',  
15216      2'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ', 
15217      3'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ', 
15218      4'f + W+/- -> f'' + H0         ', 'f + H0 -> f + g             ',  
15219      5'f + H0 -> f + gamma         ',  'f + H0 -> f + Z0            ',  
15220      6'f + H0 -> f'' + W+/-         ', 'f + H0 -> f + H0            ',  
15221      7'g + g -> f + fb             ',  'g + gamma -> f + fb         ',  
15222      8'g + Z0 -> f + fb            ',  'g + W+/- -> f + fb''         ', 
15223      9'g + H0 -> f + fb            ',  'gamma + gamma -> f + fb     ',  
15224      &'gamma + Z0 -> f + fb        ',  'gamma + W+/- -> f + fb''     '/ 
15225       DATA (PROC(I),I=61,80)/   
15226      1'gamma + H0 -> f + fb        ',  'Z0 + Z0 -> f + fb           ',  
15227      2'Z0 + W+/- -> f + fb''        ', 'Z0 + H0 -> f + fb           ',  
15228      3'W+ + W- -> f + fb           ',  'W+/- + H0 -> f + fb''        ', 
15229      4'H0 + H0 -> f + fb           ',  'g + g -> g + g              ',  
15230      5'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> gamma + W+/-',  
15231      6'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',  
15232      7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + H0          ',  
15233      8'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',  
15234      9'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + H0 -> W+/- + H0      ',  
15235      &'H0 + H0 -> H0 + H0          ',  '                            '/  
15236       DATA (PROC(I),I=81,100)/  
15237      1'q + qb -> Q + QB, massive   ',  'g + g -> Q + QB, massive    ',  
15238      2'                            ',  '                            ',  
15239      3'                            ',  '                            ',  
15240      4'                            ',  '                            ',  
15241      5'                            ',  '                            ',  
15242      6'Elastic scattering          ',  'Single diffractive          ',  
15243      7'Double diffractive          ',  'Central diffractive         ',  
15244      8'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',  
15245      9'                            ',  '                            ',  
15246      &'                            ',  '                            '/  
15247       DATA (PROC(I),I=101,120)/ 
15248      1'g + g -> gamma*/Z0          ',  'g + g -> H0                 ',  
15249      2'                            ',  '                            ',  
15250      3'                            ',  '                            ',  
15251      4'                            ',  '                            ',  
15252      5'                            ',  '                            ',  
15253      6'f + fb -> g + H0            ',  'q + g -> q + H0             ',  
15254      7'g + g -> g + H0             ',  'g + g -> gamma + gamma      ',  
15255      8'g + g -> gamma + Z0         ',  'g + g -> Z0 + Z0            ',  
15256      9'g + g -> W+ + W-            ',  '                            ',  
15257      &'                            ',  '                            '/  
15258       DATA (PROC(I),I=121,140)/ 
15259      1'g + g -> f + fb + H0        ',  '                            ',  
15260      2'                            ',  '                            ',  
15261      3'                            ',  '                            ',  
15262      4'                            ',  '                            ',  
15263      5'                            ',  '                            ',  
15264      6'                            ',  '                            ',  
15265      7'                            ',  '                            ',  
15266      8'                            ',  '                            ',  
15267      9'                            ',  '                            ',  
15268      &'                            ',  '                            '/  
15269       DATA (PROC(I),I=141,160)/ 
15270      1'f + fb -> gamma*/Z0/Z''0     ', 'f + fb'' -> H+/-             ', 
15271      2'f + fb -> R                 ',  '                            ',  
15272      3'                            ',  '                            ',  
15273      4'                            ',  '                            ',  
15274      5'                            ',  '                            ',  
15275      6'                            ',  '                            ',  
15276      7'                            ',  '                            ',  
15277      8'                            ',  '                            ',  
15278      9'                            ',  '                            ',  
15279      &'                            ',  '                            '/  
15280       DATA (PROC(I),I=161,180)/ 
15281      1'f + g -> f'' + H+/-          ', '                            ',  
15282      2'                            ',  '                            ',  
15283      3'                            ',  '                            ',  
15284      4'                            ',  '                            ',  
15285      5'                            ',  '                            ',  
15286      6'                            ',  '                            ',  
15287      7'                            ',  '                            ',  
15288      8'                            ',  '                            ',  
15289      9'                            ',  '                            ',  
15290      &'                            ',  '                            '/  
15291       DATA (PROC(I),I=181,200)/     20*'                            '/  
15292     
15293       END   
15294     
15295 C*********************************************************************  

15296     
15297       SUBROUTINE PYKCUT(MCUT)   
15298     
15299 C...Dummy routine, which the user can replace in order to make cuts on  

15300 C...the kinematics on the parton level before the matrix elements are   

15301 C...evaluated and the event is generated. The cross-section estimates   

15302 C...will automatically take these cuts into account, so the given   

15303 C...values are for the allowed phase space region only. MCUT=0 means    

15304 C...that the event has passed the cuts, MCUT=1 that it has failed.  

15305       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
15306       SAVE /PYPARS/ 
15307     
15308       MCUT=0    
15309     
15310       RETURN    
15311       END   
15312     
15313 C*********************************************************************  

15314     
15315       SUBROUTINE PYSTFE(KF,X,Q2,XPQ)    
15316     
15317 C...This is a dummy routine, where the user can introduce an interface  

15318 C...to his own external structure function parametrization. 

15319 C...Arguments in:   

15320 C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge  

15321 C...    conjugation for pbar, nbar or pi- is performed by PYSTFU.   

15322 C...X : x value.    

15323 C...Q2 : Q^2 value. 

15324 C...Arguments out:  

15325 C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,   

15326 C...    except that gluon is placed in 0. Thus XPQ(0) = xg, 

15327 C...    XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar, 

15328 C...    XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar, 

15329 C...    XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar. 

15330 C...    

15331 C...One such interface, to the Diemos, Ferroni, Longo, Martinelli   

15332 C...proton structure functions, already comes with the package. What    

15333 C...the user needs here is external files with the three routines   

15334 C...FXG160, FXG260 and FXG360 of the authors above, plus the    

15335 C...interpolation routine FINT, which is part of the CERN library   

15336 C...KERNLIB package. To avoid problems with unresolved external 

15337 C...references, the external calls are commented in the current 

15338 C...version. To enable this option, remove the C* at the beginning  

15339 C...of the relevant lines.  

15340 C...    

15341 C...Alternatively, the routine can be used as an interface to the   

15342 C...structure function evolution program of Tung. This can be achieved  

15343 C...by removing C* at the beginning of some of the lines below. 

15344       COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) 
15345       SAVE /LUDAT1/ 
15346       COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)    
15347       SAVE /LUDAT2/ 
15348       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) 
15349       SAVE /PYPARS/ 
15350       DIMENSION XPQ(-6:6),XFDFLM(9) 
15351       CHARACTER CHDFLM(9)*5,HEADER*40   
15352       DATA CHDFLM/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',  
15353      &'CBAR ','BBAR ','TBAR '/  
15354       DATA HEADER/'Tung evolution package has been invoked'/    
15355       DATA INIT/0/  
15356     
15357 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 

15358 C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95. 

15359       IF(MSTP(51).GE.11.AND.MSTP(51).LE.13.AND.MSTP(52).LE.1) THEN  
15360         XDFLM=MAX(0.51E-4,X)    
15361         Q2DFLM=MAX(10.,MIN(1E8,Q2)) 
15362         IF(MSTP(52).EQ.0) Q2DFLM=10.    
15363         DO 100 J=1,9    
15364         IF(MSTP(52).EQ.1.AND.J.EQ.9) THEN   
15365           Q2DFLM=Q2DFLM*(40./PMAS(6,1))**2  
15366           Q2DFLM=MAX(10.,MIN(1E8,Q2))   
15367         ENDIF   
15368         XFDFLM(J)=0.    
15369 C...Remove C* on following three lines to enable the DFLM options.  

15370 C*      IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    

15371 C*      IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    

15372 C*      IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    

15373   100   CONTINUE    
15374         IF(X.LT.0.51E-4.AND.ABS(PARP(51)-1.).GT.0.01) THEN  
15375           CXS=(0.51E-4/X)**(PARP(51)-1.)    
15376           DO 110 J=1,7  
15377   110     XFDFLM(J)=XFDFLM(J)*CXS   
15378         ENDIF   
15379         XPQ(0)=XFDFLM(3)    
15380         XPQ(1)=XFDFLM(2)+XFDFLM(5)  
15381         XPQ(2)=XFDFLM(1)+XFDFLM(5)  
15382         XPQ(3)=XFDFLM(6)    
15383         XPQ(4)=XFDFLM(7)    
15384         XPQ(5)=XFDFLM(8)    
15385         XPQ(6)=XFDFLM(9)    
15386         XPQ(-1)=XFDFLM(5)   
15387         XPQ(-2)=XFDFLM(5)   
15388         XPQ(-3)=XFDFLM(6)   
15389         XPQ(-4)=XFDFLM(7)   
15390         XPQ(-5)=XFDFLM(8)   
15391         XPQ(-6)=XFDFLM(9)   
15392     
15393 C...Proton structure function evolution from Wu-Ki Tung: parton 

15394 C...distribution functions incorporating heavy quark mass effects.  

15395 C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.  

15396       ELSE  
15397         IF(INIT.EQ.0) THEN  
15398           I1=0  
15399           IF(MSTP(52).EQ.4) I1=1    
15400           IHDRN=1   
15401           NU=MSTP(53)   
15402           I2=MSTP(51)   
15403           IF(MSTP(51).GE.11) I2=MSTP(51)-3  
15404           I3=0  
15405           IF(MSTP(52).EQ.3) I3=1    
15406     
15407 C...Convert to Lambda in CWZ scheme (approximately linear relation).    

15408           ALAM=0.75*PARP(1) 
15409           TPMS=PMAS(6,1)    
15410           QINI=PARP(52) 
15411           QMAX=PARP(53) 
15412           XMIN=PARP(54) 
15413     
15414 C...Initialize evolution (perform calculation or read results from  

15415 C...file).  

15416 C...Remove C* on following two lines to enable Tung initialization. 

15417 C*        CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,  

15418 C*   &    I2,I3,IRET,IRR)   

15419           INIT=1    
15420         ENDIF   
15421     
15422 C...Put into output array.  

15423         Q=SQRT(Q2)  
15424         DO 200 I=-6,6   
15425         FIXQ=0. 
15426 C...Remove C* on following line to enable structure function call.  

15427 C*      FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR)) 

15428   200   XPQ(I)=X*FIXQ   
15429     
15430 C...Change order of u and d quarks from Tung to PYTHIA convention.  

15431         XPS=XPQ(1)  
15432         XPQ(1)=XPQ(2)   
15433         XPQ(2)=XPS  
15434         XPS=XPQ(-1) 
15435         XPQ(-1)=XPQ(-2) 
15436         XPQ(-2)=XPS 
15437       ENDIF 
15438     
15439       RETURN    
15440       END   
15441
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated by the 2.2.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!