Functions/Subroutines
subroutine	lu1ent (IP, KF, PE, THE, PHI)

subroutine	lu2ent (IP, KF1, KF2, PECM)

subroutine	lu3ent (IP, KF1, KF2, KF3, PECM, X1, X3)

subroutine	lu4ent (IP, KF1, KF2, KF3, KF4, PECM, X1, X2, X4, X12, X14)

subroutine	lujoin (NJOIN, IJOIN)

subroutine	lugive (CHIN)

subroutine	luexec

subroutine	luprep (IP)

subroutine	lustrf (IP)

subroutine	luindf (IP)

subroutine	ludecy (IP)

subroutine	lukfdi (KFL1, KFL2, KFL3, KF)

subroutine	luptdi (KFL, PX, PY)

subroutine	luzdis (KFL1, KFL2, PR, Z)

subroutine	lushow (IP1, IP2, QMAX)

subroutine	luboei (NSAV)

function	ulmass (KF)

subroutine	luname (KF, CHAU)

function	luchge (KF)

function	lucomp (KF)

subroutine	luerrm (MERR, CHMESS)

function	ulalps (Q2)

function	ulangl (X, Y)

function	rlu (IDUM)

subroutine	rluget (LFN, MOVE)

subroutine	rluset (LFN, MOVE)

subroutine	lurobo (THE, PHI, BEX, BEY, BEZ)

subroutine	hirobo (THE, PHI, BEX, BEY, BEZ)

subroutine	luedit (MEDIT)

subroutine	lulist (MLIST)

subroutine	luupda (MUPDA, LFN)

function	klu (I, J)

function	plu (I, J)

subroutine	lusphe (SPH, APL)

subroutine	luthru (THR, OBL)

subroutine	luclus (NJET)

subroutine	lucell (NJET)

subroutine	lujmas (PMH, PML)

subroutine	lufowo (H10, H20, H30, H40)

subroutine	lutabu (MTABU)

subroutine	lueevt (KFL, ECM)

subroutine	luxtot (KFL, ECM, XTOT)

subroutine	luradk (ECM, MK, PAK, THEK, PHIK, ALPK)

subroutine	luxkfl (KFL, ECM, ECMC, KFLC)

subroutine	luxjet (ECM, NJET, CUT)

subroutine	lux3jt (NJET, CUT, KFL, ECM, X1, X2)

subroutine	lux4jt (NJET, CUT, KFL, ECM, KFLN, X1, X2, X4, X12, X14)

subroutine	luxdif (NC, NJET, KFL, ECM, CHI, THE, PHI)

subroutine	luonia (KFL, ECM)

subroutine	luhepc (MCONV)

subroutine	lutest (MTEST)

subroutine	pyinit (FRAME, BEAM, TARGET, WIN)

subroutine	pythia

subroutine	pystat (MSTAT)

subroutine	pyinki (CHFRAM, CHBEAM, CHTARG, WIN)

subroutine	pyinre

subroutine	pyxtot

subroutine	pymaxi

subroutine	pyovly (MOVLY)

subroutine	pyrand

subroutine	pyscat

subroutine	pysspa (IPU1, IPU2)

subroutine	pymult (MMUL)

subroutine	pyremn (IPU1, IPU2)

subroutine	pyresd

subroutine	pydiff

subroutine	pyfram (IFRAME)

subroutine	pywidt (KFLR, RMAS, WDTP, WDTE)

subroutine	pyklim (ILIM)

subroutine	pykmap (IVAR, MVAR, VVAR)

subroutine	pysigh (NCHN, SIGS)

subroutine	pystfu (KF, X, Q2, XPQ, JBT)

subroutine	pyspli (KF, KFLIN, KFLCH, KFLSP)

function	pygamm (X)

function	pyw1au (EPS, IREIM)

function	pyw2au (EPS, IREIM)

function	pyi3au (BE, EPS, IREIM)

function	pyspen (XREIN, XIMIN, IREIM)

subroutine	pytest (MTEST)

subroutine	pykcut (MCUT)

subroutine	pystfe (KF, X, Q2, XPQ)

Function/Subroutine Documentation

◆ hirobo()

subroutine hirobo	(	THE,
		PHI,
		BEX,
		BEY,
		BEZ
	)

Definition at line 5415 of file hipyset1.35.f.

     
 C...Purpose: to perform rotations and boosts.   
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)    
     
 C...Find range of rotation/boost. Convert boost to double precision.    
       imin=1    
       IF(mstu(1).GT.0) imin=mstu(1) 
       imax=n    
       IF(mstu(2).GT.0) imax=mstu(2) 
       dbx=bex   
       dby=bey   
       dbz=bez   
     
 C...Check range of rotation/boost.  
       IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN   
         CALL luerrm(11,'(LUROBO:) range outside LUJETS memory') 
         RETURN  
       ENDIF 
     
 C...Rotate, typically from z axis to direction (theta,phi). 
       IF(the**2+phi**2.GT.1e-20) THEN   
         rot(1,1)=cos(the)*cos(phi)  
         rot(1,2)=-sin(phi)  
         rot(1,3)=sin(the)*cos(phi)  
         rot(2,1)=cos(the)*sin(phi)  
         rot(2,2)=cos(phi)   
         rot(2,3)=sin(the)*sin(phi)  
         rot(3,1)=-sin(the)  
         rot(3,2)=0. 
         rot(3,3)=cos(the)   
         DO 130 i=imin,imax  
         IF(k(i,1).LE.0) GOTO 130    
         DO 110 j=1,3    
   110   pr(j)=p(i,j)   
         DO 120 j=1,3    
   120   p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3) 
   130   CONTINUE    
       ENDIF 
     
 C...Boost, typically from rest to momentum/energy=beta. 
       IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN    
         db=sqrt(dbx**2+dby**2+dbz**2)   
         IF(db.GT.0.99999999d0) THEN 
 C...Rescale boost vector if too close to unity. 
           CALL luerrm(3,'(LUROBO:) boost vector too large') 
           dbx=dbx*(0.99999999d0/db) 
           dby=dby*(0.99999999d0/db) 
           dbz=dbz*(0.99999999d0/db) 
           db=0.99999999d0   
         ENDIF   
         dga=1d0/sqrt(1d0-db**2) 
         DO 150 i=imin,imax  
         IF(k(i,1).LE.0) GOTO 150    
         DO 140 j=1,4    
   140   dp(j)=p(i,j)    
         dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)   
         dgabp=dga*(dga*dbp/(1d0+dga)+dp(4)) 
         p(i,1)=dp(1)+dgabp*dbx  
         p(i,2)=dp(2)+dgabp*dby  
         p(i,3)=dp(3)+dgabp*dbz  
         p(i,4)=dga*(dp(4)+dbp)  
   150   CONTINUE    
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ klu()

function klu	(	I,
		J
	)

Definition at line 6196 of file hipyset1.35.f.

     
 C...Purpose: to provide various integer-valued event related data.  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Default value. For I=0 number of entries, number of stable entries  
 C...or 3 times total charge.    
       klu=0 
       IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN 
       ELSEIF(i.EQ.0.AND.j.EQ.1) THEN    
         klu=n   
       ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN    
         DO 100 i1=1,n   
         IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+1 
         IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+  
      &  luchge(k(i1,2)) 
   100   CONTINUE    
       ELSEIF(i.EQ.0) THEN   
     
 C...For I > 0 direct readout of K matrix or charge. 
       ELSEIF(j.LE.5) THEN   
         klu=k(i,j)  
       ELSEIF(j.EQ.6) THEN   
         klu=luchge(k(i,2))  
     
 C...Status (existing/fragmented/decayed), parton/hadron separation. 
       ELSEIF(j.LE.8) THEN   
         IF(k(i,1).GE.1.AND.k(i,1).LE.10) klu=1  
         IF(j.EQ.8) klu=klu*k(i,2)   
       ELSEIF(j.LE.12) THEN  
         kfa=iabs(k(i,2))    
         kc=lucomp(kfa)  
         kq=0    
         IF(kc.NE.0) kq=kchg(kc,2)   
         IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) klu=k(i,2)   
         IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) klu=k(i,2)  
         IF(j.EQ.11) klu=kc  
         IF(j.EQ.12) klu=kq*isign(1,k(i,2))  
     
 C...Heaviest flavour in hadron/diquark. 
       ELSEIF(j.EQ.13) THEN  
         kfa=iabs(k(i,2))    
         klu=mod(kfa/100,10)*(-1)**mod(kfa/100,10)   
         IF(kfa.LT.10) klu=kfa   
         IF(mod(kfa/1000,10).NE.0) klu=mod(kfa/1000,10)  
         klu=klu*isign(1,k(i,2)) 
     
 C...Particle history: generation, ancestor, rank.   
       ELSEIF(j.LE.16) THEN  
         i2=i    
         i1=i    
   110   klu=klu+1   
         i3=i2   
         i2=i1   
         i1=k(i1,3)  
         IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) GOTO 110 
         IF(j.EQ.15) klu=i2  
         IF(j.EQ.16) THEN    
           klu=0 
           DO 120 i1=i2+1,i3 
   120     IF(k(i1,3).EQ.i2.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) klu=klu+1    
         ENDIF   
     
 C...Particle coming from collapsing jet system or not.  
       ELSEIF(j.EQ.17) THEN  
         i1=i    
   130   klu=klu+1   
         i3=i1   
         i1=k(i1,3)  
         i0=max(1,i1)    
         kc=lucomp(k(i0,2))  
         IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN    
           IF(klu.EQ.1) klu=-1   
           IF(klu.GT.1) klu=0    
           RETURN    
         ENDIF   
         IF(kchg(kc,2).EQ.0) GOTO 130    
         IF(k(i1,1).NE.12) klu=0 
         IF(k(i1,1).NE.12) RETURN    
         i2=i1   
   140   i2=i2+1 
         IF(i2.LT.n.AND.k(i2,1).NE.11) GOTO 140  
         k3m=k(i3-1,3)   
         IF(k3m.GE.i1.AND.k3m.LE.i2) klu=0   
         k3p=k(i3+1,3)   
         IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) klu=0   
     
 C...Number of decay products. Colour flow.  
       ELSEIF(j.EQ.18) THEN  
         IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) klu=max(0,k(i,5)-k(i,4)+1) 
         IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) klu=0    
       ELSEIF(j.LE.22) THEN  
         IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN    
         IF(j.EQ.19) klu=mod(k(i,4)/mstu(5),mstu(5)) 
         IF(j.EQ.20) klu=mod(k(i,5)/mstu(5),mstu(5)) 
         IF(j.EQ.21) klu=mod(k(i,4),mstu(5)) 
         IF(j.EQ.22) klu=mod(k(i,5),mstu(5)) 
       ELSE  
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

◆ lu1ent()

subroutine lu1ent	(	IP,
		KF,
		PE,
		THE,
		PHI
	)

Definition at line 17 of file hipyset1.35.f.

     
 C...Purpose: to store one parton/particle in commonblock LUJETS.    
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5) 
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Standard checks.    
       mstu(28)=0    
       IF(mstu(12).GE.1) CALL lulist(0)  
       ipa=max(1,iabs(ip))   
       IF(ipa.GT.mstu(4)) CALL luerrm(21,    
      &'(LU1ENT:) writing outside LUJETS memory')    
       kc=lucomp(kf) 
       IF(kc.EQ.0) CALL luerrm(12,'(LU1ENT:) unknown flavour code')  
     
 C...Find mass. Reset K, P and V vectors.    
       pm=0. 
       IF(mstu(10).EQ.1) pm=p(ipa,5) 
       IF(mstu(10).GE.2) pm=ulmass(kf)   
       DO 100 j=1,5  
       k(ipa,j)=0    
       p(ipa,j)=0.   
   100 v(ipa,j)=0.   
     
 C...Store parton/particle in K and P vectors.   
       k(ipa,1)=1    
       IF(ip.LT.0) k(ipa,1)=2    
       k(ipa,2)=kf   
       p(ipa,5)=pm   
       p(ipa,4)=max(pe,pm)   
       pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)  
       p(ipa,1)=pa*sin(the)*cos(phi) 
       p(ipa,2)=pa*sin(the)*sin(phi) 
       p(ipa,3)=pa*cos(the)  
     
 C...Set N. Optionally fragment/decay.   
       n=ipa 
       IF(ip.EQ.0) CALL luexec   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lu2ent()

subroutine lu2ent	(	IP,
		KF1,
		KF2,
		PECM
	)

Definition at line 65 of file hipyset1.35.f.

     
 C...Purpose: to store two partons/particles in their CM frame,  
 C...with the first along the +z axis.   
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Standard checks.    
       mstu(28)=0    
       IF(mstu(12).GE.1) CALL lulist(0)  
       ipa=max(1,iabs(ip))   
       IF(ipa.GT.mstu(4)-1) CALL luerrm(21,  
      &'(LU2ENT:) writing outside LUJETS memory')    
       kc1=lucomp(kf1)   
       kc2=lucomp(kf2)   
       IF(kc1.EQ.0.OR.kc2.EQ.0) CALL luerrm(12,  
      &'(LU2ENT:) unknown flavour code') 
     
 C...Find masses. Reset K, P and V vectors.  
       pm1=0.    
       IF(mstu(10).EQ.1) pm1=p(ipa,5)    
       IF(mstu(10).GE.2) pm1=ulmass(kf1) 
       pm2=0.    
       IF(mstu(10).EQ.1) pm2=p(ipa+1,5)  
       IF(mstu(10).GE.2) pm2=ulmass(kf2) 
       DO 100 i=ipa,ipa+1    
       DO 100 j=1,5  
       k(i,j)=0  
       p(i,j)=0. 
   100 v(i,j)=0. 
     
 C...Check flavours. 
       kq1=kchg(kc1,2)*isign(1,kf1)  
       kq2=kchg(kc2,2)*isign(1,kf2)  
       IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL luerrm(2,  
      &'(LU2ENT:) unphysical flavour combination')   
       k(ipa,2)=kf1  
       k(ipa+1,2)=kf2    
     
 C...Store partons/particles in K vectors for normal case.   
       IF(ip.GE.0) THEN  
         k(ipa,1)=1  
         IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2    
         k(ipa+1,1)=1    
     
 C...Store partons in K vectors for parton shower evolution. 
       ELSE  
         IF(kq1.EQ.0.OR.kq2.EQ.0) CALL luerrm(2, 
      &  '(LU2ENT:) requested flavours can not develop parton shower')   
         k(ipa,1)=3  
         k(ipa+1,1)=3    
         k(ipa,4)=mstu(5)*(ipa+1)    
         k(ipa,5)=k(ipa,4)   
         k(ipa+1,4)=mstu(5)*ipa  
         k(ipa+1,5)=k(ipa+1,4)   
       ENDIF 
     
 C...Check kinematics and store partons/particles in P vectors.  
       IF(pecm.LE.pm1+pm2) CALL luerrm(13,   
      &'(LU2ENT:) energy smaller than sum of masses')    
       pa=sqrt(max(0.,(pecm**2-pm1**2-pm2**2)**2-(2.*pm1*pm2)**2))/  
      &(2.*pecm) 
       p(ipa,3)=pa   
       p(ipa,4)=sqrt(pm1**2+pa**2)   
       p(ipa,5)=pm1  
       p(ipa+1,3)=-pa    
       p(ipa+1,4)=sqrt(pm2**2+pa**2) 
       p(ipa+1,5)=pm2    
     
 C...Set N. Optionally fragment/decay.   
       n=ipa+1   
       IF(ip.EQ.0) CALL luexec   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lu3ent()

subroutine lu3ent	(	IP,
		KF1,
		KF2,
		KF3,
		PECM,
		X1,
		X3
	)

Definition at line 147 of file hipyset1.35.f.

     
 C...Purpose: to store three partons or particles in their CM frame, 
 C...with the first along the +z axis and the third in the (x,z) 
 C...plane with x > 0.   
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Standard checks.    
       mstu(28)=0    
       IF(mstu(12).GE.1) CALL lulist(0)  
       ipa=max(1,iabs(ip))   
       IF(ipa.GT.mstu(4)-2) CALL luerrm(21,  
      &'(LU3ENT:) writing outside LUJETS memory')    
       kc1=lucomp(kf1)   
       kc2=lucomp(kf2)   
       kc3=lucomp(kf3)   
       IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL luerrm(12,  
      &'(LU3ENT:) unknown flavour code') 
     
 C...Find masses. Reset K, P and V vectors.  
       pm1=0.    
       IF(mstu(10).EQ.1) pm1=p(ipa,5)    
       IF(mstu(10).GE.2) pm1=ulmass(kf1) 
       pm2=0.    
       IF(mstu(10).EQ.1) pm2=p(ipa+1,5)  
       IF(mstu(10).GE.2) pm2=ulmass(kf2) 
       pm3=0.    
       IF(mstu(10).EQ.1) pm3=p(ipa+2,5)  
       IF(mstu(10).GE.2) pm3=ulmass(kf3) 
       DO 100 i=ipa,ipa+2    
       DO 100 j=1,5  
       k(i,j)=0  
       p(i,j)=0. 
   100 v(i,j)=0. 
     
 C...Check flavours. 
       kq1=kchg(kc1,2)*isign(1,kf1)  
       kq2=kchg(kc2,2)*isign(1,kf2)  
       kq3=kchg(kc3,2)*isign(1,kf3)  
       IF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN   
       ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.kq1+kq3.EQ.4))  
      &THEN  
       ELSE  
         CALL luerrm(2,'(LU3ENT:) unphysical flavour combination')   
       ENDIF 
       k(ipa,2)=kf1  
       k(ipa+1,2)=kf2    
       k(ipa+2,2)=kf3    
     
 C...Store partons/particles in K vectors for normal case.   
       IF(ip.GE.0) THEN  
         k(ipa,1)=1  
         IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2  
         k(ipa+1,1)=1    
         IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2  
         k(ipa+2,1)=1    
     
 C...Store partons in K vectors for parton shower evolution. 
       ELSE  
         IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0) CALL luerrm(2, 
      &  '(LU3ENT:) requested flavours can not develop parton shower')   
         k(ipa,1)=3  
         k(ipa+1,1)=3    
         k(ipa+2,1)=3    
         kcs=4   
         IF(kq1.EQ.-1) kcs=5 
         k(ipa,kcs)=mstu(5)*(ipa+1)  
         k(ipa,9-kcs)=mstu(5)*(ipa+2)    
         k(ipa+1,kcs)=mstu(5)*(ipa+2)    
         k(ipa+1,9-kcs)=mstu(5)*ipa  
         k(ipa+2,kcs)=mstu(5)*ipa    
         k(ipa+2,9-kcs)=mstu(5)*(ipa+1)  
       ENDIF 
     
 C...Check kinematics.   
       mkerr=0   
       IF(0.5*x1*pecm.LE.pm1.OR.0.5*(2.-x1-x3)*pecm.LE.pm2.OR.   
      &0.5*x3*pecm.LE.pm3) mkerr=1   
       pa1=sqrt(max(0.,(0.5*x1*pecm)**2-pm1**2)) 
       pa2=sqrt(max(0.,(0.5*(2.-x1-x3)*pecm)**2-pm2**2)) 
       pa3=sqrt(max(0.,(0.5*x3*pecm)**2-pm3**2)) 
       cthe2=(pa3**2-pa1**2-pa2**2)/(2.*pa1*pa2) 
       cthe3=(pa2**2-pa1**2-pa3**2)/(2.*pa1*pa3) 
       IF(abs(cthe2).GE.1.001.OR.abs(cthe3).GE.1.001) mkerr=1    
       cthe3=max(-1.,min(1.,cthe3))  
       IF(mkerr.NE.0) CALL luerrm(13,    
      &'(LU3ENT:) unphysical kinematical variable setup')    
     
 C...Store partons/particles in P vectors.   
       p(ipa,3)=pa1  
       p(ipa,4)=sqrt(pa1**2+pm1**2)  
       p(ipa,5)=pm1  
       p(ipa+2,1)=pa3*sqrt(1.-cthe3**2)  
       p(ipa+2,3)=pa3*cthe3  
       p(ipa+2,4)=sqrt(pa3**2+pm3**2)    
       p(ipa+2,5)=pm3    
       p(ipa+1,1)=-p(ipa+2,1)    
       p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)   
       p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)   
       p(ipa+1,5)=pm2    
     
 C...Set N. Optionally fragment/decay.   
       n=ipa+2   
       IF(ip.EQ.0) CALL luexec   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lu4ent()

subroutine lu4ent	(	IP,
		KF1,
		KF2,
		KF3,
		KF4,
		PECM,
		X1,
		X2,
		X4,
		X12,
		X14
	)

Definition at line 262 of file hipyset1.35.f.

     
 C...Purpose: to store four partons or particles in their CM frame, with 
 C...the first along the +z axis, the last in the xz plane with x > 0    
 C...and the second having y < 0 and y > 0 with equal probability.   
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Standard checks.    
       mstu(28)=0    
       IF(mstu(12).GE.1) CALL lulist(0)  
       ipa=max(1,iabs(ip))   
       IF(ipa.GT.mstu(4)-3) CALL luerrm(21,  
      &'(LU4ENT:) writing outside LUJETS momory')    
       kc1=lucomp(kf1)   
       kc2=lucomp(kf2)   
       kc3=lucomp(kf3)   
       kc4=lucomp(kf4)   
       IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL luerrm(12,  
      &'(LU4ENT:) unknown flavour code') 
     
 C...Find masses. Reset K, P and V vectors.  
       pm1=0.    
       IF(mstu(10).EQ.1) pm1=p(ipa,5)    
       IF(mstu(10).GE.2) pm1=ulmass(kf1) 
       pm2=0.    
       IF(mstu(10).EQ.1) pm2=p(ipa+1,5)  
       IF(mstu(10).GE.2) pm2=ulmass(kf2) 
       pm3=0.    
       IF(mstu(10).EQ.1) pm3=p(ipa+2,5)  
       IF(mstu(10).GE.2) pm3=ulmass(kf3) 
       pm4=0.    
       IF(mstu(10).EQ.1) pm4=p(ipa+3,5)  
       IF(mstu(10).GE.2) pm4=ulmass(kf4) 
       DO 100 i=ipa,ipa+3    
       DO 100 j=1,5  
       k(i,j)=0  
       p(i,j)=0. 
   100 v(i,j)=0. 
     
 C...Check flavours. 
       kq1=kchg(kc1,2)*isign(1,kf1)  
       kq2=kchg(kc2,2)*isign(1,kf2)  
       kq3=kchg(kc3,2)*isign(1,kf3)  
       kq4=kchg(kc4,2)*isign(1,kf4)  
       IF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN  
       ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.   
      &kq1+kq4.EQ.4)) THEN   
       ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0.)  
      &THEN  
       ELSE  
         CALL luerrm(2,'(LU4ENT:) unphysical flavour combination')   
       ENDIF 
       k(ipa,2)=kf1  
       k(ipa+1,2)=kf2    
       k(ipa+2,2)=kf3    
       k(ipa+3,2)=kf4    
     
 C...Store partons/particles in K vectors for normal case.   
       IF(ip.GE.0) THEN  
         k(ipa,1)=1  
         IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2  
         k(ipa+1,1)=1    
         IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))    
      &  k(ipa+1,1)=2    
         k(ipa+2,1)=1    
         IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2  
         k(ipa+3,1)=1    
     
 C...Store partons for parton shower evolution from q-g-g-qbar or    
 C...g-g-g-g event.  
       ELSEIF(kq1+kq2.NE.0) THEN 
         IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0.OR.kq4.EQ.0) CALL luerrm(2, 
      &  '(LU4ENT:) requested flavours can not develop parton shower')   
         k(ipa,1)=3  
         k(ipa+1,1)=3    
         k(ipa+2,1)=3    
         k(ipa+3,1)=3    
         kcs=4   
         IF(kq1.EQ.-1) kcs=5 
         k(ipa,kcs)=mstu(5)*(ipa+1)  
         k(ipa,9-kcs)=mstu(5)*(ipa+3)    
         k(ipa+1,kcs)=mstu(5)*(ipa+2)    
         k(ipa+1,9-kcs)=mstu(5)*ipa  
         k(ipa+2,kcs)=mstu(5)*(ipa+3)    
         k(ipa+2,9-kcs)=mstu(5)*(ipa+1)  
         k(ipa+3,kcs)=mstu(5)*ipa    
         k(ipa+3,9-kcs)=mstu(5)*(ipa+2)  
     
 C...Store partons for parton shower evolution from q-qbar-q-qbar event. 
       ELSE  
         IF(kq1.EQ.0.OR.kq2.EQ.0.OR.kq3.EQ.0.OR.kq4.EQ.0) CALL luerrm(2, 
      &  '(LU4ENT:) requested flavours can not develop parton shower')   
         k(ipa,1)=3  
         k(ipa+1,1)=3    
         k(ipa+2,1)=3    
         k(ipa+3,1)=3    
         k(ipa,4)=mstu(5)*(ipa+1)    
         k(ipa,5)=k(ipa,4)   
         k(ipa+1,4)=mstu(5)*ipa  
         k(ipa+1,5)=k(ipa+1,4)   
         k(ipa+2,4)=mstu(5)*(ipa+3)  
         k(ipa+2,5)=k(ipa+2,4)   
         k(ipa+3,4)=mstu(5)*(ipa+2)  
         k(ipa+3,5)=k(ipa+3,4)   
       ENDIF 
     
 C...Check kinematics.   
       mkerr=0   
       IF(0.5*x1*pecm.LE.pm1.OR.0.5*x2*pecm.LE.pm2.OR.0.5*(2.-x1-x2-x4)* 
      &pecm.LE.pm3.OR.0.5*x4*pecm.LE.pm4) mkerr=1    
       pa1=sqrt(max(0.,(0.5*x1*pecm)**2-pm1**2)) 
       pa2=sqrt(max(0.,(0.5*x2*pecm)**2-pm2**2)) 
       pa3=sqrt(max(0.,(0.5*(2.-x1-x2-x4)*pecm)**2-pm3**2))  
       pa4=sqrt(max(0.,(0.5*x4*pecm)**2-pm4**2)) 
       x24=x1+x2+x4-1.-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2 
       cthe4=(x1*x4-2.*x14)*pecm**2/(4.*pa1*pa4) 
       IF(abs(cthe4).GE.1.002) mkerr=1   
       cthe4=max(-1.,min(1.,cthe4))  
       sthe4=sqrt(1.-cthe4**2)   
       cthe2=(x1*x2-2.*x12)*pecm**2/(4.*pa1*pa2) 
       IF(abs(cthe2).GE.1.002) mkerr=1   
       cthe2=max(-1.,min(1.,cthe2))  
       sthe2=sqrt(1.-cthe2**2)   
       cphi2=((x2*x4-2.*x24)*pecm**2-4.*pa2*cthe2*pa4*cthe4)/    
      &(4.*pa2*sthe2*pa4*sthe4)  
       IF(abs(cphi2).GE.1.05) mkerr=1    
       cphi2=max(-1.,min(1.,cphi2))  
       IF(mkerr.EQ.1) CALL luerrm(13,    
      &'(LU4ENT:) unphysical kinematical variable setup')    
     
 C...Store partons/particles in P vectors.   
       p(ipa,3)=pa1  
       p(ipa,4)=sqrt(pa1**2+pm1**2)  
       p(ipa,5)=pm1  
       p(ipa+3,1)=pa4*sthe4  
       p(ipa+3,3)=pa4*cthe4  
       p(ipa+3,4)=sqrt(pa4**2+pm4**2)    
       p(ipa+3,5)=pm4    
       p(ipa+1,1)=pa2*sthe2*cphi2    
       p(ipa+1,2)=pa2*sthe2*sqrt(1.-cphi2**2)*(-1.)**int(rlu(0)+0.5) 
       p(ipa+1,3)=pa2*cthe2  
       p(ipa+1,4)=sqrt(pa2**2+pm2**2)    
       p(ipa+1,5)=pm2    
       p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1) 
       p(ipa+2,2)=-p(ipa+1,2)    
       p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)    
       p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2) 
       p(ipa+2,5)=pm3    
     
 C...Set N. Optionally fragment/decay.   
       n=ipa+3   
       IF(ip.EQ.0) CALL luexec   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luboei()

subroutine luboei ( NSAV )

Definition at line 4538 of file hipyset1.35.f.

     
 C...Purpose: to modify event so as to approximately take into account   
 C...Bose-Einstein effects according to a simple phenomenological    
 C...parametrization.    
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension dps(4),kfbe(9),nbe(0:9),bei(100)    
       DATA kfbe/211,-211,111,321,-321,130,310,221,331/  
     
 C...Boost event to overall CM frame. Calculate CM energy.   
       IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN   
       DO 100 j=1,4  
   100 dps(j)=0. 
       DO 120 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120  
       DO 110 j=1,4  
   110 dps(j)=dps(j)+p(i,j)  
   120 CONTINUE  
       CALL ludbrb(0,0,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),  
      &-dps(3)/dps(4))   
       pecm=0.   
       DO 130 i=1,n  
   130 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4) 
     
 C...Reserve copy of particles by species at end of record.  
       nbe(0)=n+mstu(3)  
       DO 160 ibe=1,min(9,mstj(51))  
       nbe(ibe)=nbe(ibe-1)   
       DO 150 i=nsav+1,n 
       IF(k(i,2).NE.kfbe(ibe)) GOTO 150  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150  
       IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN   
         CALL luerrm(11,'(LUBOEI:) no more memory left in LUJETS')   
         RETURN  
       ENDIF 
       nbe(ibe)=nbe(ibe)+1   
       k(nbe(ibe),1)=i   
       DO 140 j=1,3  
   140 p(nbe(ibe),j)=0.  
   150 CONTINUE  
   160 CONTINUE  
     
 C...Tabulate integral for subsequent momentum shift.    
       DO 210 ibe=1,min(9,mstj(51))  
       IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) GOTO 180   
       IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2)).   
      &le.1) GOTO 180    
       IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),    
      &nbe(7)-nbe(6)).LE.1) GOTO 180 
       IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) GOTO 180    
       IF(ibe.EQ.1) pmhq=2.*ulmass(211)  
       IF(ibe.EQ.4) pmhq=2.*ulmass(321)  
       IF(ibe.EQ.8) pmhq=2.*ulmass(221)  
       IF(ibe.EQ.9) pmhq=2.*ulmass(331)  
       qdel=0.1*min(pmhq,parj(93))   
       IF(mstj(51).EQ.1) THEN    
         nbin=min(100,nint(9.*parj(93)/qdel))    
         beex=exp(0.5*qdel/parj(93)) 
         bert=exp(-qdel/parj(93))    
       ELSE  
         nbin=min(100,nint(3.*parj(93)/qdel))    
       ENDIF 
       DO 170 ibin=1,nbin    
       qbin=qdel*(ibin-0.5)  
       bei(ibin)=qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)    
       IF(mstj(51).EQ.1) THEN    
         beex=beex*bert  
         bei(ibin)=bei(ibin)*beex    
       ELSE  
         bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)    
       ENDIF 
   170 IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1) 
     
 C...Loop through particle pairs and find old relative momentum. 
   180 DO 200 i1m=nbe(ibe-1)+1,nbe(ibe)-1    
       i1=k(i1m,1)   
       DO 200 i2m=i1m+1,nbe(ibe) 
       i2=k(i2m,1)   
       q2old=max(0.,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+  
      &p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)    
       qold=sqrt(q2old)  
     
 C...Calculate new relative momentum.    
       IF(qold.LT.0.5*qdel) THEN 
         qmov=qold/3.    
       ELSEIF(qold.LT.(nbin-0.1)*qdel) THEN  
         rbin=qold/qdel  
         ibin=rbin   
         rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)  
         qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*  
      &  sqrt(q2old+pmhq**2)/q2old   
       ELSE  
         qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old    
       ENDIF 
       q2new=q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)   
     
 C...Calculate and save shift to be performed on three-momenta.  
       hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)    
       hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2    
       ha=0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))   
       DO 190 j=1,3  
       pd=ha*(p(i2,j)-p(i1,j))   
       p(i1m,j)=p(i1m,j)+pd  
   190 p(i2m,j)=p(i2m,j)-pd  
   200 CONTINUE  
   210 CONTINUE  
     
 C...Shift momenta and recalculate energies. 
       DO 230 im=nbe(0)+1,nbe(min(9,mstj(51)))   
       i=k(im,1) 
       DO 220 j=1,3  
   220 p(i,j)=p(i,j)+p(im,j) 
   230 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)  
     
 C...Rescale all momenta for energy conservation.    
       pes=0.    
       pqs=0.    
       DO 240 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 240  
       pes=pes+p(i,4)    
       pqs=pqs+p(i,5)**2/p(i,4)  
   240 CONTINUE  
       fac=(pecm-pqs)/(pes-pqs)  
       DO 260 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 260  
       DO 250 j=1,3  
   250 p(i,j)=fac*p(i,j) 
       p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)  
   260 CONTINUE  
     
 C...Boost back to correct reference frame.  
       CALL ludbrb(0,0,0.,0.,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lucell()

subroutine lucell ( NJET )

Definition at line 6982 of file hipyset1.35.f.

     
 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET    
 C...coordinate frame, as used for calorimeters at hadron colliders. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Loop over all particles. Find cell that was hit by given particle.  
       nce2=2*mstu(51)*mstu(52)  
       ptlrat=1./sinh(paru(51))**2   
       np=0  
       nc=n  
       DO 110 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110  
       IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) GOTO 110  
       IF(mstu(41).GE.2) THEN    
         kc=lucomp(k(i,2))   
         IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
      &  kc.EQ.18) GOTO 110  
         IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
      &  GOTO 110    
       ENDIF 
       np=np+1   
       pt=sqrt(p(i,1)**2+p(i,2)**2)  
       eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))  
       ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5*(eta/paru(51)+1.))))   
       phi=ulangl(p(i,1),p(i,2)) 
       iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5*(phi/paru(1)+1.))))    
       ietph=mstu(52)*ieta+iphi  
     
 C...Add to cell already hit, or book new cell.  
       DO 100 ic=n+1,nc  
       IF(ietph.EQ.k(ic,3)) THEN 
         k(ic,4)=k(ic,4)+1   
         p(ic,5)=p(ic,5)+pt  
         GOTO 110    
       ENDIF 
   100 CONTINUE  
       IF(nc.GE.mstu(4)-mstu(32)-5) THEN 
         CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')   
         njet=-2 
         RETURN  
       ENDIF 
       nc=nc+1   
       k(nc,3)=ietph 
       k(nc,4)=1 
       k(nc,5)=2 
       p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))   
       p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))    
       p(nc,5)=pt    
   110 CONTINUE  
     
 C...Smear true bin content by calorimeter resolution.   
       IF(mstu(53).GE.1) THEN    
         DO 130 ic=n+1,nc    
         pei=p(ic,5) 
         IF(mstu(53).EQ.2) pei=p(ic,5)/cosh(p(ic,1)) 
   120   pef=pei+paru(55)*sqrt(-2.*log(max(1e-10,rlu(0)))*pei)*  
      &  cos(paru(2)*rlu(0)) 
         IF(pef.LT.0..OR.pef.GT.paru(56)*pei) GOTO 120   
         p(ic,5)=pef 
   130   IF(mstu(53).EQ.2) p(ic,5)=pef*cosh(p(ic,1)) 
       ENDIF 
     
 C...Find initiator cell: the one with highest pT of not yet used ones.  
       nj=nc 
   140 etmax=0.  
       DO 150 ic=n+1,nc  
       IF(k(ic,5).NE.2) GOTO 150 
       IF(p(ic,5).LE.etmax) GOTO 150 
       icmax=ic  
       eta=p(ic,1)   
       phi=p(ic,2)   
       etmax=p(ic,5) 
   150 CONTINUE  
       IF(etmax.LT.paru(52)) GOTO 210    
       IF(nj.GE.mstu(4)-mstu(32)-5) THEN 
         CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')   
         njet=-2 
         RETURN  
       ENDIF 
       k(icmax,5)=1  
       nj=nj+1   
       k(nj,4)=0 
       k(nj,5)=1 
       p(nj,1)=eta   
       p(nj,2)=phi   
       p(nj,3)=0.    
       p(nj,4)=0.    
       p(nj,5)=0.    
     
 C...Sum up unused cells within required distance of initiator.  
       DO 160 ic=n+1,nc  
       IF(k(ic,5).EQ.0) GOTO 160 
       IF(abs(p(ic,1)-eta).GT.paru(54)) GOTO 160 
       dphia=abs(p(ic,2)-phi)    
       IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) GOTO 160  
       phic=p(ic,2)  
       IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)  
       IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) GOTO 160    
       k(ic,5)=-k(ic,5)  
       k(nj,4)=k(nj,4)+k(ic,4)   
       p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)   
       p(nj,4)=p(nj,4)+p(ic,5)*phic  
       p(nj,5)=p(nj,5)+p(ic,5)   
   160 CONTINUE  
     
 C...Reject cluster below minimum ET, else accept.   
       IF(p(nj,5).LT.paru(53)) THEN  
         nj=nj-1 
         DO 170 ic=n+1,nc    
   170   IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)   
       ELSEIF(mstu(54).LE.2) THEN    
         p(nj,3)=p(nj,3)/p(nj,5) 
         p(nj,4)=p(nj,4)/p(nj,5) 
         IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),   
      &  p(nj,4))    
         DO 180 ic=n+1,nc    
   180   IF(k(ic,1).LT.0) k(ic,1)=0  
       ELSE  
         DO 190 j=1,4    
   190   p(nj,j)=0.  
         DO 200 ic=n+1,nc    
         IF(k(ic,5).GE.0) GOTO 200   
         p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))    
         p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))    
         p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))   
         p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))   
         k(ic,5)=0   
   200   CONTINUE    
       ENDIF 
       GOTO 140  
     
 C...Arrange clusters in falling ET sequence.    
   210 DO 230 i=1,nj-nc  
       etmax=0.  
       DO 220 ij=nc+1,nj 
       IF(k(ij,5).EQ.0) GOTO 220 
       IF(p(ij,5).LT.etmax) GOTO 220 
       ijmax=ij  
       etmax=p(ij,5) 
   220 CONTINUE  
       k(ijmax,5)=0  
       k(n+i,1)=31   
       k(n+i,2)=98   
       k(n+i,3)=i    
       k(n+i,4)=k(ijmax,4)   
       k(n+i,5)=0    
       DO 230 j=1,5  
       p(n+i,j)=p(ijmax,j)   
   230 v(n+i,j)=0.   
       njet=nj-nc    
     
 C...Convert to massless or massive four-vectors.    
       IF(mstu(54).EQ.2) THEN    
         DO 240 i=n+1,n+njet 
         eta=p(i,3)  
         p(i,1)=p(i,5)*cos(p(i,4))   
         p(i,2)=p(i,5)*sin(p(i,4))   
         p(i,3)=p(i,5)*sinh(eta) 
         p(i,4)=p(i,5)*cosh(eta) 
   240   p(i,5)=0.   
       ELSEIF(mstu(54).GE.3) THEN    
         DO 250 i=n+1,n+njet 
   250   p(i,5)=sqrt(max(0.,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))    
       ENDIF 
     
 C...Information about storage.  
       mstu(61)=n+1  
       mstu(62)=np   
       mstu(63)=nc-n 
       IF(mstu(43).LE.1) mstu(3)=njet    
       IF(mstu(43).GE.2) n=n+njet    
     
       RETURN    

Here is the call graph for this function:

◆ luchge()

function luchge ( KF )

Definition at line 4912 of file hipyset1.35.f.

     
 C...Purpose: to give three times the charge for a particle/parton.  
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Initial values. Simple case of direct readout.  
       luchge=0  
       kfa=iabs(kf)  
       kc=lucomp(kfa)    
       IF(kc.EQ.0) THEN  
       ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN  
         luchge=kchg(kc,1)   
     
 C...Construction from quark content for heavy meson, diquark, baryon.   
       ELSEIF(mod(kfa/1000,10).EQ.0) THEN    
         luchge=(kchg(mod(kfa/100,10),1)-kchg(mod(kfa/10,10),1))*    
      &  (-1)**mod(kfa/100,10)   
       ELSEIF(mod(kfa/10,10).EQ.0) THEN  
         luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1) 
       ELSE  
         luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)+    
      &  kchg(mod(kfa/10,10),1)  
       ENDIF 
     
 C...Add on correct sign.    
       luchge=luchge*isign(1,kf) 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luclus()

subroutine luclus ( NJET )

Definition at line 6667 of file hipyset1.35.f.

     
 C...Purpose: to subdivide the particle content of an event into 
 C...jets/clusters.  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension ps(5)   
       SAVE nsav,np,ps,pss,rinit,npre,nrem   
     
 C...Functions: distance measure in pT or (pseudo)mass.  
       r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-  
      &p(i1,3)*p(i2,3))*2.*p(i1,5)*p(i2,5)/(0.0001+p(i1,5)+p(i2,5))**2   
       r2m(i1,i2)=2.*p(i1,4)*p(i2,4)*(1.-(p(i1,1)*p(i2,1)+p(i1,2)*   
      &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))   
     
 C...If first time, reset. If reentering, skip preliminaries.    
       IF(mstu(48).LE.0) THEN    
         np=0    
         DO 100 j=1,5    
   100   ps(j)=0.    
         pss=0.  
       ELSE  
         njet=nsav   
         IF(mstu(43).GE.2) n=n-njet  
         DO 110 i=n+1,n+njet 
   110   p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)  
         IF(mstu(46).LE.3) r2acc=paru(44)**2 
         IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2   
         nloop=0 
         GOTO 290    
       ENDIF 
     
 C...Find which particles are to be considered in cluster search.    
       DO 140 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140  
       IF(mstu(41).GE.2) THEN    
         kc=lucomp(k(i,2))   
         IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
      &  kc.EQ.18) GOTO 140  
         IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
      &  GOTO 140    
       ENDIF 
       IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN 
         CALL luerrm(11,'(LUCLUS:) no more memory left in LUJETS')   
         njet=-1 
         RETURN  
       ENDIF 
     
 C...Take copy of these particles, with space left for jets later on.    
       np=np+1   
       k(n+np,3)=i   
       DO 120 j=1,5  
   120 p(n+np,j)=p(i,j)  
       IF(mstu(42).EQ.0) p(n+np,5)=0.    
       IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)  
       p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)    
       p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2) 
       DO 130 j=1,4  
   130 ps(j)=ps(j)+p(n+np,j) 
       pss=pss+p(n+np,5) 
   140 CONTINUE  
       DO 150 i=n+1,n+np 
       k(i+np,3)=k(i,3)  
       DO 150 j=1,5  
   150 p(i+np,j)=p(i,j)  
       ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))   
     
 C...Very low multiplicities not considered. 
       IF(np.LT.mstu(47)) THEN   
         CALL luerrm(8,'(LUCLUS:) too few particles for analysis')   
         njet=-1 
         RETURN  
       ENDIF 
     
 C...Find precluster configuration. If too few jets, make harder cuts.   
       nloop=0   
       IF(mstu(46).LE.3) r2acc=paru(44)**2   
       IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2 
       rinit=1.25*paru(43)   
       IF(np.LE.mstu(47)+2) rinit=0. 
   160 rinit=0.8*rinit   
       npre=0    
       nrem=np   
       DO 170 i=n+np+1,n+2*np    
   170 k(i,4)=0  
     
 C...Sum up small momentum region. Jet if enough absolute momentum.  
       IF(mstu(46).LE.2) THEN    
         DO 180 j=1,4    
   180   p(n+1,j)=0. 
         DO 200 i=n+np+1,n+2*np  
         IF(p(i,5).GT.2.*rinit) GOTO 200 
         nrem=nrem-1 
         k(i,4)=1    
         DO 190 j=1,4    
   190   p(n+1,j)=p(n+1,j)+p(i,j)    
   200   CONTINUE    
         p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)  
         IF(p(n+1,5).GT.2.*rinit) npre=1 
         IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 160    
       ENDIF 
     
 C...Find fastest remaining particle.    
   210 npre=npre+1   
       pmax=0.   
       DO 220 i=n+np+1,n+2*np    
       IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) GOTO 220    
       imax=i    
       pmax=p(i,5)   
   220 CONTINUE  
       DO 230 j=1,5  
   230 p(n+npre,j)=p(imax,j) 
       nrem=nrem-1   
       k(imax,4)=npre    
     
 C...Sum up precluster around it according to pT separation. 
       IF(mstu(46).LE.2) THEN    
         DO 250 i=n+np+1,n+2*np  
         IF(k(i,4).NE.0) GOTO 250    
         r2=r2t(i,imax)  
         IF(r2.GT.rinit**2) GOTO 250 
         nrem=nrem-1 
         k(i,4)=npre 
         DO 240 j=1,4    
   240   p(n+npre,j)=p(n+npre,j)+p(i,j)  
   250   CONTINUE    
         p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)  
     
 C...Sum up precluster around it according to mass separation.   
       ELSE  
   260   imin=0  
         r2min=rinit**2  
         DO 270 i=n+np+1,n+2*np  
         IF(k(i,4).NE.0) GOTO 270    
         r2=r2m(i,n+npre)    
         IF(r2.GE.r2min) GOTO 270    
         imin=i  
         r2min=r2    
   270   CONTINUE    
         IF(imin.NE.0) THEN  
           DO 280 j=1,4  
   280     p(n+npre,j)=p(n+npre,j)+p(imin,j) 
           p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)    
           nrem=nrem-1   
           k(imin,4)=npre    
           GOTO 260  
         ENDIF   
       ENDIF 
     
 C...Check if more preclusters to be found. Start over if too few.   
       IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 160  
       IF(nrem.GT.0) GOTO 210    
       njet=npre 
     
 C...Reassign all particles to nearest jet. Sum up new jet momenta.  
   290 tsav=0.   
       psjt=0.   
   300 IF(mstu(46).LE.1) THEN    
         DO 310 i=n+1,n+njet 
         DO 310 j=1,4    
   310   v(i,j)=0.   
         DO 340 i=n+np+1,n+2*np  
         r2min=pss**2    
         DO 320 ijet=n+1,n+njet  
         IF(p(ijet,5).LT.rinit) GOTO 320 
         r2=r2t(i,ijet)  
         IF(r2.GE.r2min) GOTO 320    
         imin=ijet   
         r2min=r2    
   320   CONTINUE    
         k(i,4)=imin-n   
         DO 330 j=1,4    
   330   v(imin,j)=v(imin,j)+p(i,j)  
   340   CONTINUE    
         psjt=0. 
         DO 360 i=n+1,n+njet 
         DO 350 j=1,4    
   350   p(i,j)=v(i,j)   
         p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)  
   360   psjt=psjt+p(i,5)    
       ENDIF 
     
 C...Find two closest jets.  
       r2min=2.*r2acc    
       DO 370 itry1=n+1,n+njet-1 
       DO 370 itry2=itry1+1,n+njet   
       IF(mstu(46).LE.2) r2=r2t(itry1,itry2) 
       IF(mstu(46).GE.3) r2=r2m(itry1,itry2) 
       IF(r2.GE.r2min) GOTO 370  
       imin1=itry1   
       imin2=itry2   
       r2min=r2  
   370 CONTINUE  
     
 C...If allowed, join two closest jets and start over.   
       IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN  
         irec=min(imin1,imin2)   
         idel=max(imin1,imin2)   
         DO 380 j=1,4    
   380   p(irec,j)=p(imin1,j)+p(imin2,j) 
         p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)  
         DO 390 i=idel+1,n+njet  
         DO 390 j=1,5    
   390   p(i-1,j)=p(i,j) 
         IF(mstu(46).GE.2) THEN  
           DO 400 i=n+np+1,n+2*np    
           iori=n+k(i,4) 
           IF(iori.EQ.idel) k(i,4)=irec-n    
   400     IF(iori.GT.idel) k(i,4)=k(i,4)-1  
         ENDIF   
         njet=njet-1 
         GOTO 290    
     
 C...Divide up broad jet if empty cluster in list of final ones. 
       ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN    
         DO 410 i=n+1,n+njet 
   410   k(i,5)=0    
         DO 420 i=n+np+1,n+2*np  
   420   k(n+k(i,4),5)=k(n+k(i,4),5)+1   
         iemp=0  
         DO 430 i=n+1,n+njet 
   430   IF(k(i,5).EQ.0) iemp=i  
         IF(iemp.NE.0) THEN  
           nloop=nloop+1 
           ispl=0    
           r2max=0.  
           DO 440 i=n+np+1,n+2*np    
           IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) GOTO 440    
           ijet=n+k(i,4) 
           r2=r2t(i,ijet)    
           IF(r2.LE.r2max) GOTO 440  
           ispl=i    
           r2max=r2  
   440     CONTINUE  
           IF(ispl.NE.0) THEN    
             ijet=n+k(ispl,4)    
             DO 450 j=1,4    
             p(iemp,j)=p(ispl,j) 
   450       p(ijet,j)=p(ijet,j)-p(ispl,j)   
             p(iemp,5)=p(ispl,5) 
             p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)  
             IF(nloop.LE.2) GOTO 290 
           ENDIF 
         ENDIF   
       ENDIF 
     
 C...If generalized thrust has not yet converged, continue iteration.    
       IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))    
      &THEN  
         tsav=psjt/pss   
         GOTO 300    
       ENDIF 
     
 C...Reorder jets according to energy.   
       DO 460 i=n+1,n+njet   
       DO 460 j=1,5  
   460 v(i,j)=p(i,j) 
       DO 490 inew=n+1,n+njet    
       pemax=0.  
       DO 470 itry=n+1,n+njet    
       IF(v(itry,4).LE.pemax) GOTO 470   
       imax=itry 
       pemax=v(itry,4)   
   470 CONTINUE  
       k(inew,1)=31  
       k(inew,2)=97  
       k(inew,3)=inew-n  
       k(inew,4)=0   
       DO 480 j=1,5  
   480 p(inew,j)=v(imax,j)   
       v(imax,4)=-1. 
   490 k(imax,5)=inew    
     
 C...Clean up particle-jet assignments and jet information.  
       DO 500 i=n+np+1,n+2*np    
       iori=k(n+k(i,4),5)    
       k(i,4)=iori-n 
       IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n   
       k(iori,4)=k(iori,4)+1 
   500 CONTINUE  
       iemp=0    
       psjt=0.   
       DO 520 i=n+1,n+njet   
       k(i,5)=0  
       psjt=psjt+p(i,5)  
       p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0.))  
       DO 510 j=1,5  
   510 v(i,j)=0. 
   520 IF(k(i,4).EQ.0) iemp=i    
     
 C...Select storing option. Output variables. Check for failure. 
       mstu(61)=n+1  
       mstu(62)=np   
       mstu(63)=npre 
       paru(61)=ps(5)    
       paru(62)=psjt/pss 
       paru(63)=sqrt(r2min)  
       IF(njet.LE.1) paru(63)=0. 
       IF(iemp.NE.0) THEN    
         CALL luerrm(8,'(LUCLUS:) failed to reconstruct as requested')   
         njet=-1 
       ENDIF 
       IF(mstu(43).LE.1) mstu(3)=njet    
       IF(mstu(43).GE.2) n=n+njet    
       nsav=njet 
     
       RETURN    

Here is the call graph for this function:

◆ lucomp()

function lucomp ( KF )

Definition at line 4945 of file hipyset1.35.f.

     
 C...Purpose: to compress the standard KF codes for use in mass and decay    
 C...arrays; also to check whether a given code actually is defined. 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Subdivide KF code into constituent pieces.  
       lucomp=0  
       kfa=iabs(kf)  
       kfla=mod(kfa/1000,10) 
       kflb=mod(kfa/100,10)  
       kflc=mod(kfa/10,10)   
       kfls=mod(kfa,10)  
       kflr=mod(kfa/10000,10)    
     
 C...Simple cases: direct translation or special codes.  
       IF(kfa.EQ.0.OR.kfa.GE.100000) THEN    
       ELSEIF(kfa.LE.100) THEN   
         lucomp=kfa  
         IF(kf.LT.0.AND.kchg(kfa,3).EQ.0) lucomp=0   
       ELSEIF(kfls.EQ.0) THEN    
         IF(kf.EQ.130) lucomp=221    
         IF(kf.EQ.310) lucomp=222    
         IF(kfa.EQ.210) lucomp=281   
         IF(kfa.EQ.2110) lucomp=282  
         IF(kfa.EQ.2210) lucomp=283  
     
 C...Mesons. 
       ELSEIF(kfa-10000*kflr.LT.1000) THEN   
         IF(kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.0.OR.kflc.EQ.9) THEN   
         ELSEIF(kflb.LT.kflc) THEN   
         ELSEIF(kf.LT.0.AND.kflb.EQ.kflc) THEN   
         ELSEIF(kflb.EQ.kflc) THEN   
           IF(kflr.EQ.0.AND.kfls.EQ.1) THEN  
             lucomp=110+kflb 
           ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN  
             lucomp=130+kflb 
           ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN  
             lucomp=150+kflb 
           ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN  
             lucomp=170+kflb 
           ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN  
             lucomp=190+kflb 
           ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN  
             lucomp=210+kflb 
           ENDIF 
         ELSEIF(kflb.LE.5.AND.kflc.LE.3) THEN    
           IF(kflr.EQ.0.AND.kfls.EQ.1) THEN  
             lucomp=100+((kflb-1)*(kflb-2))/2+kflc   
           ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN  
             lucomp=120+((kflb-1)*(kflb-2))/2+kflc   
           ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN  
             lucomp=140+((kflb-1)*(kflb-2))/2+kflc   
           ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN  
             lucomp=160+((kflb-1)*(kflb-2))/2+kflc   
           ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN  
             lucomp=180+((kflb-1)*(kflb-2))/2+kflc   
           ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN  
             lucomp=200+((kflb-1)*(kflb-2))/2+kflc   
           ENDIF 
         ELSEIF((kfls.EQ.1.AND.kflr.LE.1).OR.(kfls.EQ.3.AND.kflr.LE.2).  
      &  or.(kfls.EQ.5.AND.kflr.EQ.0)) THEN  
           lucomp=80+kflb    
         ENDIF   
     
 C...Diquarks.   
       ELSEIF((kflr.EQ.0.OR.kflr.EQ.1).AND.kflc.EQ.0) THEN   
         IF(kfls.NE.1.AND.kfls.NE.3) THEN    
         ELSEIF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9) THEN    
         ELSEIF(kfla.LT.kflb) THEN   
         ELSEIF(kfls.EQ.1.AND.kfla.EQ.kflb) THEN 
         ELSE    
           lucomp=90 
         ENDIF   
     
 C...Spin 1/2 baryons.   
       ELSEIF(kflr.EQ.0.AND.kfls.EQ.2) THEN  
         IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN   
         ELSEIF(kfla.LE.kflc.OR.kfla.LT.kflb) THEN   
         ELSEIF(kfla.GE.6.OR.kflb.GE.4.OR.kflc.GE.4) THEN    
           lucomp=80+kfla    
         ELSEIF(kflb.LT.kflc) THEN   
           lucomp=300+((kfla+1)*kfla*(kfla-1))/6+(kflc*(kflc-1))/2+kflb  
         ELSE    
           lucomp=330+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc  
         ENDIF   
     
 C...Spin 3/2 baryons.   
       ELSEIF(kflr.EQ.0.AND.kfls.EQ.4) THEN  
         IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN   
         ELSEIF(kfla.LT.kflb.OR.kflb.LT.kflc) THEN   
         ELSEIF(kfla.GE.6.OR.kflb.GE.4) THEN 
           lucomp=80+kfla    
         ELSE    
           lucomp=360+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc  
         ENDIF   
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ ludecy()

subroutine ludecy ( IP )

Definition at line 2561 of file hipyset1.35.f.

     
 C...Purpose: to handle the decay of unstable particles. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),  
      &wtcor(10) 
       DATA wtcor/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5,150.,16./ 
     
 C...Functions: momentum in two-particle decays, four-product and    
 C...matrix element times phase space in weak decays.    
       pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)  
       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) 
       hmeps(ha)=((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))* 
      &sqrt((1.-hrq-ha)**2-4.*hrq*ha)    
     
 C...Initial values. 
       ntry=0    
       nsav=n    
       kfa=iabs(k(ip,2)) 
       kfs=isign(1,k(ip,2))  
       kc=lucomp(kfa)    
       mstj(92)=0    
     
 C...Choose lifetime and determine decay vertex. 
       IF(k(ip,1).EQ.5) THEN 
         v(ip,5)=0.  
       ELSEIF(k(ip,1).NE.4) THEN 
         v(ip,5)=-pmas(kc,4)*log(rlu(0)) 
       ENDIF 
       DO 100 j=1,4  
   100 vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)   
     
 C...Determine whether decay allowed or not. 
       mout=0    
       IF(mstj(22).EQ.2) THEN    
         IF(pmas(kc,4).GT.parj(71)) mout=1   
       ELSEIF(mstj(22).EQ.3) THEN    
         IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1  
       ELSEIF(mstj(22).EQ.4) THEN    
         IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1 
         IF(abs(vdcy(3)).GT.parj(74)) mout=1 
       ENDIF 
       IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN   
         k(ip,1)=4   
         RETURN  
       ENDIF 
     
 C...Check existence of decay channels. Particle/antiparticle rules. 
       kca=kc    
       IF(mdcy(kc,2).GT.0) THEN  
         mdmdcy=mdme(mdcy(kc,2),2)   
         IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy    
       ENDIF 
       IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN 
         CALL luerrm(9,'(LUDECY:) no decay channel defined') 
         RETURN  
       ENDIF 
       IF(mod(kfa/1000,10).EQ.0.AND.(kca.EQ.85.OR.kca.EQ.87)) kfs=-kfs   
       IF(kchg(kc,3).EQ.0) THEN  
         kfsp=1  
         kfsn=0  
         IF(rlu(0).GT.0.5) kfs=-kfs  
       ELSEIF(kfs.GT.0) THEN 
         kfsp=1  
         kfsn=0  
       ELSE  
         kfsp=0  
         kfsn=1  
       ENDIF 
     
 C...Sum branching ratios of allowed decay channels. 
   110 nope=0    
       brsu=0.   
       DO 120 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1  
       IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.    
      &kfsn*mdme(idl,1).NE.3) GOTO 120   
       IF(mdme(idl,2).GT.100) GOTO 120   
       nope=nope+1   
       brsu=brsu+brat(idl)   
   120 CONTINUE  
       IF(nope.EQ.0) THEN    
         CALL luerrm(2,'(LUDECY:) all decay channels closed by user')    
         RETURN  
       ENDIF 
     
 C...Select decay channel among allowed ones.    
   130 rbr=brsu*rlu(0)   
       idl=mdcy(kca,2)-1 
   140 idl=idl+1 
       IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.    
      &kfsn*mdme(idl,1).NE.3) THEN   
         IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 140   
       ELSEIF(mdme(idl,2).GT.100) THEN   
         IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 140   
       ELSE  
         idc=idl 
         rbr=rbr-brat(idl)   
         IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0.) GOTO 140 
       ENDIF 
     
 C...Start readout of decay channel: matrix element, reset counters. 
       mmat=mdme(idc,2)  
   150 ntry=ntry+1   
       IF(ntry.GT.1000) THEN 
         CALL luerrm(14,'(LUDECY:) caught in infinite loop') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       i=n   
       np=0  
       nq=0  
       mbst=0    
       IF(mmat.GE.11.AND.mmat.NE.46.AND.p(ip,4).GT.20.*p(ip,5)) mbst=1   
       DO 160 j=1,4  
       pv(1,j)=0.    
   160 IF(mbst.EQ.0) pv(1,j)=p(ip,j) 
       IF(mbst.EQ.1) pv(1,4)=p(ip,5) 
       pv(1,5)=p(ip,5)   
       ps=0. 
       psq=0.    
       mrem=0    
     
 C...Read out decay products. Convert to standard flavour code.  
       jtmax=5   
       IF(mdme(idc+1,2).EQ.101) jtmax=10 
       DO 170 jt=1,jtmax 
       IF(jt.LE.5) kp=kfdp(idc,jt)   
       IF(jt.GE.6) kp=kfdp(idc+1,jt-5)   
       IF(kp.EQ.0) GOTO 170  
       kpa=iabs(kp)  
       kcp=lucomp(kpa)   
       IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN 
         kfp=kp  
       ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN  
         kfp=kfs*kp  
       ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN  
         kfp=-kfs*mod(kfa/10,10) 
       ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN  
         kfp=kfs*(100*mod(kfa/10,100)+3) 
       ELSEIF(kpa.EQ.81) THEN    
         kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1) 
       ELSEIF(kp.EQ.82) THEN 
         CALL lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)),0,kfp,kdump)   
         IF(kfp.EQ.0) GOTO 150   
         mstj(93)=1  
         IF(pv(1,5).LT.parj(32)+2.*ulmass(kfp)) GOTO 150 
       ELSEIF(kp.EQ.-82) THEN    
         kfp=-kfp    
         IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)    
       ENDIF 
       IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=lucomp(kfp)    
     
 C...Add decay product to event record or to quark flavour list. 
       kfpa=iabs(kfp)    
       kqp=kchg(kcp,2)   
       IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN   
         nq=nq+1 
         kflo(nq)=kfp    
         mstj(93)=2  
         psq=psq+ulmass(kflo(nq))    
       ELSEIF(mmat.GE.42.AND.mmat.LE.43.AND.np.EQ.3.AND.mod(nq,2).EQ.1)  
      &THEN  
         nq=nq-1 
         ps=ps-p(i,5)    
         k(i,1)=1    
         kfi=k(i,2)  
         CALL lukfdi(kfp,kfi,kfldmp,k(i,2))  
         IF(k(i,2).EQ.0) GOTO 150    
         mstj(93)=1  
         p(i,5)=ulmass(k(i,2))   
         ps=ps+p(i,5)    
       ELSE  
         i=i+1   
         np=np+1 
         IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1 
         IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1    
         k(i,1)=1+mod(nq,2)  
         IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2    
         IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1  
         k(i,2)=kfp  
         k(i,3)=ip   
         k(i,4)=0    
         k(i,5)=0    
         p(i,5)=ulmass(kfp)  
         IF(mmat.EQ.45.AND.kfpa.EQ.89) p(i,5)=parj(32)   
         ps=ps+p(i,5)    
       ENDIF 
   170 CONTINUE  
     
 C...Choose decay multiplicity in phase space model. 
   180 IF(mmat.GE.11.AND.mmat.LE.30) THEN    
         psp=ps  
         cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))   
         IF(mmat.EQ.12) cnde=cnde+parj(63)   
   190   ntry=ntry+1 
         IF(ntry.GT.1000) THEN   
           CALL luerrm(14,'(LUDECY:) caught in infinite loop')   
           IF(mstu(21).GE.1) RETURN  
         ENDIF   
         IF(mmat.LE.20) THEN 
           gauss=sqrt(-2.*cnde*log(max(1e-10,rlu(0))))*  
      &    sin(paru(2)*rlu(0))   
           nd=0.5+0.5*np+0.25*nq+cnde+gauss  
           IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) GOTO 190 
           IF(mmat.EQ.13.AND.nd.EQ.2) GOTO 190   
           IF(mmat.EQ.14.AND.nd.LE.3) GOTO 190   
           IF(mmat.EQ.15.AND.nd.LE.4) GOTO 190   
         ELSE    
           nd=mmat-20    
         ENDIF   
     
 C...Form hadrons from flavour content.  
         DO 200 jt=1,4   
   200   kfl1(jt)=kflo(jt)   
         IF(nd.EQ.np+nq/2) GOTO 220  
         DO 210 i=n+np+1,n+nd-nq/2   
         jt=1+int((nq-1)*rlu(0)) 
         CALL lukfdi(kfl1(jt),0,kfl2,k(i,2)) 
         IF(k(i,2).EQ.0) GOTO 190    
   210   kfl1(jt)=-kfl2  
   220   jt=2    
         jt2=3   
         jt3=4   
         IF(nq.EQ.4.AND.rlu(0).LT.parj(66)) jt=4 
         IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))* 
      &  isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3    
         IF(jt.EQ.3) jt2=2   
         IF(jt.EQ.4) jt3=2   
         CALL lukfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))   
         IF(k(n+nd-nq/2+1,2).EQ.0) GOTO 190  
         IF(nq.EQ.4) CALL lukfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))   
         IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) GOTO 190 
     
 C...Check that sum of decay product masses not too large.   
         ps=psp  
         DO 230 i=n+np+1,n+nd    
         k(i,1)=1    
         k(i,3)=ip   
         k(i,4)=0    
         k(i,5)=0    
         p(i,5)=ulmass(k(i,2))   
   230   ps=ps+p(i,5)    
         IF(ps+parj(64).GT.pv(1,5)) GOTO 190 
     
 C...Rescale energy to subtract off spectator quark mass.    
       ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44.OR.mmat.EQ.45).    
      &and.np.GE.3) THEN 
         ps=ps-p(n+np,5) 
         pqt=(p(n+np,5)+parj(65))/pv(1,5)    
         DO 240 j=1,5    
         p(n+np,j)=pqt*pv(1,j)   
   240   pv(1,j)=(1.-pqt)*pv(1,j)    
         IF(ps+parj(64).GT.pv(1,5)) GOTO 150 
         nd=np-1 
         mrem=1  
     
 C...Phase space factors imposed in W decay. 
       ELSEIF(mmat.EQ.46) THEN   
         mstj(93)=1  
         psmc=ulmass(k(n+1,2))   
         mstj(93)=1  
         psmc=psmc+ulmass(k(n+2,2))  
         IF(max(ps,psmc)+parj(32).GT.pv(1,5)) GOTO 130   
         hr1=(p(n+1,5)/pv(1,5))**2   
         hr2=(p(n+2,5)/pv(1,5))**2   
         IF((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2).  
      &  lt.2.*rlu(0)) GOTO 130  
         nd=np   
     
 C...Fully specified final state: check mass broadening effects. 
       ELSE  
         IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) GOTO 150 
         nd=np   
       ENDIF 
     
 C...Select W mass in decay Q -> W + q, without W propagator.    
       IF(mmat.EQ.45.AND.mstj(25).LE.0) THEN 
         hlq=(parj(32)/pv(1,5))**2   
         huq=(1.-(p(n+2,5)+parj(64))/pv(1,5))**2 
         hrq=(p(n+2,5)/pv(1,5))**2   
   250   hw=hlq+rlu(0)*(huq-hlq) 
         IF(hmeps(hw).LT.rlu(0)) GOTO 250    
         p(n+1,5)=pv(1,5)*sqrt(hw)   
     
 C...Ditto, including W propagator. Divide mass range into three regions.    
       ELSEIF(mmat.EQ.45) THEN   
         hqw=(pv(1,5)/pmas(24,1))**2 
         hlw=(parj(32)/pmas(24,1))**2    
         huw=((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2 
         hrq=(p(n+2,5)/pv(1,5))**2   
         hg=pmas(24,2)/pmas(24,1)    
         hatl=atan((hlw-1.)/hg)  
         hm=min(1.,huw-0.001)    
         hmv1=hmeps(hm/hqw)/((hm-1.)**2+hg**2)   
   260   hm=hm-hg    
         hmv2=hmeps(hm/hqw)/((hm-1.)**2+hg**2)   
         hsav1=hmeps(hm/hqw) 
         hsav2=1./((hm-1.)**2+hg**2) 
         IF(hmv2.GT.hmv1.AND.hm-hg.GT.hlw) THEN  
           hmv1=hmv2 
           GOTO 260  
         ENDIF   
         hmv=min(2.*hmv1,hmeps(hm/hqw)/hg**2)    
         hm1=1.-sqrt(1./hmv-hg**2)   
         IF(hm1.GT.hlw.AND.hm1.LT.hm) THEN   
           hm=hm1    
         ELSEIF(hmv2.LE.hmv1) THEN   
           hm=max(hlw,hm-min(0.1,1.-hm)) 
         ENDIF   
         hatm=atan((hm-1.)/hg)   
         hwt1=(hatm-hatl)/hg 
         hwt2=hmv*(min(1.,huw)-hm)   
         hwt3=0. 
         IF(huw.GT.1.) THEN  
           hatu=atan((huw-1.)/hg)    
           hmp1=hmeps(1./hqw)    
           hwt3=hmp1*hatu/hg 
         ENDIF   
     
 C...Select mass region and W mass there. Accept according to weight.    
   270   hreg=rlu(0)*(hwt1+hwt2+hwt3)    
         IF(hreg.LE.hwt1) THEN   
           hw=1.+hg*tan(hatl+rlu(0)*(hatm-hatl)) 
           hacc=hmeps(hw/hqw)    
         ELSEIF(hreg.LE.hwt1+hwt2) THEN  
           hw=hm+rlu(0)*(min(1.,huw)-hm) 
           hacc=hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv 
         ELSE    
           hw=1.+hg*tan(rlu(0)*hatu) 
           hacc=hmeps(hw/hqw)/hmp1   
         ENDIF   
         IF(hacc.LT.rlu(0)) GOTO 270 
         p(n+1,5)=pmas(24,1)*sqrt(hw)    
       ENDIF 
     
 C...Determine position of grandmother, number of sisters, Q -> W sign.  
       nm=0  
       msgn=0    
       IF(mmat.EQ.3.OR.mmat.EQ.46) THEN  
         im=k(ip,3)  
         IF(im.LT.0.OR.im.GE.ip) im=0    
         IF(im.NE.0) kfam=iabs(k(im,2))  
         IF(im.NE.0.AND.mmat.EQ.3) THEN  
           DO 280 il=max(ip-2,im+1),min(ip+2,n)  
   280     IF(k(il,3).EQ.im) nm=nm+1 
           IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.    
      &    mod(kfam/1000,10).NE.0) nm=0  
         ELSEIF(im.NE.0.AND.mmat.EQ.46) THEN 
           msgn=isign(1,k(im,2)*k(ip,2)) 
           IF(kfam.GT.100.AND.mod(kfam/1000,10).EQ.0) msgn=  
      &    msgn*(-1)**mod(kfam/100,10)   
         ENDIF   
       ENDIF 
     
 C...Kinematics of one-particle decays.  
       IF(nd.EQ.1) THEN  
         DO 290 j=1,4    
   290   p(n+1,j)=p(ip,j)    
         GOTO 510    
       ENDIF 
     
 C...Calculate maximum weight ND-particle decay. 
       pv(nd,5)=p(n+nd,5)    
       IF(nd.GE.3) THEN  
         wtmax=1./wtcor(nd-2)    
         pmax=pv(1,5)-ps+p(n+nd,5)   
         pmin=0. 
         DO 300 il=nd-1,1,-1 
         pmax=pmax+p(n+il,5) 
         pmin=pmin+p(n+il+1,5)   
   300   wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))   
       ENDIF 
     
 C...Find virtual gamma mass in Dalitz decay.    
   310 IF(nd.EQ.2) THEN  
       ELSEIF(mmat.EQ.2) THEN    
         pmes=4.*pmas(11,1)**2   
         pmrho2=pmas(131,1)**2   
         pgrho2=pmas(131,2)**2   
   320   pmst=pmes*(p(ip,5)**2/pmes)**rlu(0) 
         wt=(1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*    
      &  (1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/ 
      &  ((1.-pmst/pmrho2)**2+pgrho2/pmrho2) 
         IF(wt.LT.rlu(0)) GOTO 320   
         pv(2,5)=max(2.00001*pmas(11,1),sqrt(pmst))  
     
 C...M-generator gives weight. If rejected, try again.   
       ELSE  
   330   rord(1)=1.  
         DO 350 il1=2,nd-1   
         rsav=rlu(0) 
         DO 340 il2=il1-1,1,-1   
         IF(rsav.LE.rord(il2)) GOTO 350  
   340   rord(il2+1)=rord(il2)   
   350   rord(il2+1)=rsav    
         rord(nd)=0. 
         wt=1.   
         DO 360 il=nd-1,1,-1 
         pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*(pv(1,5)-ps)    
   360   wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))   
         IF(wt.LT.rlu(0)*wtmax) GOTO 330 
       ENDIF 
     
 C...Perform two-particle decays in respective CM frame. 
   370 DO 390 il=1,nd-1  
       pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))    
       ue(3)=2.*rlu(0)-1.    
       phi=paru(2)*rlu(0)    
       ue(1)=sqrt(1.-ue(3)**2)*cos(phi)  
       ue(2)=sqrt(1.-ue(3)**2)*sin(phi)  
       DO 380 j=1,3  
       p(n+il,j)=pa*ue(j)    
   380 pv(il+1,j)=-pa*ue(j)  
       p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)    
   390 pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)  
     
 C...Lorentz transform decay products to lab frame.  
       DO 400 j=1,4  
   400 p(n+nd,j)=pv(nd,j)    
       DO 430 il=nd-1,1,-1   
       DO 410 j=1,3  
   410 be(j)=pv(il,j)/pv(il,4)   
       ga=pv(il,4)/pv(il,5)  
       DO 430 i=n+il,n+nd    
       bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)    
       DO 420 j=1,3  
   420 p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)    
   430 p(i,4)=ga*(p(i,4)+bep)    
     
 C...Matrix elements for omega and phi decays.   
       IF(mmat.EQ.1) THEN    
         wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2  
      &  -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2    
      &  +2.*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)   
         IF(max(wt*wtcor(9)/p(ip,5)**6,0.001).LT.rlu(0)) GOTO 310    
     
 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. 
       ELSEIF(mmat.EQ.2) THEN    
         four12=four(n+1,n+2)    
         four13=four(n+1,n+3)    
         four23=0.5*pmst-0.25*pmes   
         wt=(pmst-0.5*pmes)*(four12**2+four13**2)+   
      &  pmes*(four12*four13+four12**2+four13**2)    
         IF(wt.LT.rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) GOTO 370    
     
 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, 
 C...V vector), of form cos**2(theta02) in V1 rest frame.    
       ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN    
         IF((p(ip,5)**2*four(im,n+1)-four(ip,im)*four(ip,n+1))**2.LE.    
      &  rlu(0)*(four(ip,im)**2-(p(ip,5)*p(im,5))**2)*(four(ip,n+1)**2-  
      &  (p(ip,5)*p(n+1,5))**2)) GOTO 370    
     
 C...Matrix element for "onium" -> g + g + g or gamma + g + g.   
       ELSEIF(mmat.EQ.4) THEN    
         hx1=2.*four(ip,n+1)/p(ip,5)**2  
         hx2=2.*four(ip,n+2)/p(ip,5)**2  
         hx3=2.*four(ip,n+3)/p(ip,5)**2  
         wt=((1.-hx1)/(hx2*hx3))**2+((1.-hx2)/(hx1*hx3))**2+ 
      &  ((1.-hx3)/(hx1*hx2))**2 
         IF(wt.LT.2.*rlu(0)) GOTO 310    
         IF(k(ip+1,2).EQ.22.AND.(1.-hx1)*p(ip,5)**2.LT.4.*parj(32)**2)   
      &  GOTO 310    
     
 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.    
       ELSEIF(mmat.EQ.41) THEN   
         hx1=2.*four(ip,n+1)/p(ip,5)**2  
         IF(8.*hx1*(3.-2.*hx1)/9..LT.rlu(0)) GOTO 310    
     
 C...Matrix elements for weak decays (only semileptonic for c and b) 
       ELSEIF(mmat.GE.42.AND.mmat.LE.44.AND.nd.EQ.3) THEN    
         IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3) 
         IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3) 
         IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 310  
       ELSEIF(mmat.GE.42.AND.mmat.LE.44) THEN    
         DO 440 j=1,4    
         p(n+np+1,j)=0.  
         DO 440 is=n+3,n+np  
   440   p(n+np+1,j)=p(n+np+1,j)+p(is,j) 
         IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)  
         IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)  
         IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 310  
     
 C...Angular distribution in W decay.    
       ELSEIF(mmat.EQ.46.AND.msgn.NE.0) THEN 
         IF(msgn.GT.0) wt=four(im,n+1)*four(n+2,ip+1)    
         IF(msgn.LT.0) wt=four(im,n+2)*four(n+1,ip+1)    
         IF(wt.LT.rlu(0)*p(im,5)**4/wtcor(10)) GOTO 370  
       ENDIF 
     
 C...Scale back energy and reattach spectator.   
       IF(mrem.EQ.1) THEN    
         DO 450 j=1,5    
   450   pv(1,j)=pv(1,j)/(1.-pqt)    
         nd=nd+1 
         mrem=0  
       ENDIF 
     
 C...Low invariant mass for system with spectator quark gives particle,  
 C...not two jets. Readjust momenta accordingly. 
       IF((mmat.EQ.31.OR.mmat.EQ.45).AND.nd.EQ.3) THEN   
         mstj(93)=1  
         pm2=ulmass(k(n+2,2))    
         mstj(93)=1  
         pm3=ulmass(k(n+3,2))    
         IF(p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3).GE. 
      &  (parj(32)+pm2+pm3)**2) GOTO 510 
         k(n+2,1)=1  
         kftemp=k(n+2,2) 
         CALL lukfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))    
         IF(k(n+2,2).EQ.0) GOTO 150  
         p(n+2,5)=ulmass(k(n+2,2))   
         ps=p(n+1,5)+p(n+2,5)    
         pv(2,5)=p(n+2,5)    
         mmat=0  
         nd=2    
         GOTO 370    
       ELSEIF(mmat.EQ.44) THEN   
         mstj(93)=1  
         pm3=ulmass(k(n+3,2))    
         mstj(93)=1  
         pm4=ulmass(k(n+4,2))    
         IF(p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4).GE. 
      &  (parj(32)+pm3+pm4)**2) GOTO 480 
         k(n+3,1)=1  
         kftemp=k(n+3,2) 
         CALL lukfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))    
         IF(k(n+3,2).EQ.0) GOTO 150  
         p(n+3,5)=ulmass(k(n+3,2))   
         DO 460 j=1,3    
   460   p(n+3,j)=p(n+3,j)+p(n+4,j)  
         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)  
         ha=p(n+1,4)**2-p(n+2,4)**2  
         hb=ha-(p(n+1,5)**2-p(n+2,5)**2) 
         hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+   
      &  (p(n+1,3)-p(n+2,3))**2  
         hd=(pv(1,4)-p(n+3,4))**2    
         he=ha**2-2.*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2  
         hf=hd*hc-hb**2  
         hg=hd*hc-ha*hb  
         hh=(sqrt(hg**2+he*hf)-hg)/(2.*hf)   
         DO 470 j=1,3    
         pcor=hh*(p(n+1,j)-p(n+2,j)) 
         p(n+1,j)=p(n+1,j)+pcor  
   470   p(n+2,j)=p(n+2,j)-pcor  
         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)  
         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)  
         nd=nd-1 
       ENDIF 
     
 C...Check invariant mass of W jets. May give one particle or start over.    
   480 IF(mmat.GE.42.AND.mmat.LE.44.AND.iabs(k(n+1,2)).LT.10) THEN   
         pmr=sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))  
         mstj(93)=1  
         pm1=ulmass(k(n+1,2))    
         mstj(93)=1  
         pm2=ulmass(k(n+2,2))    
         IF(pmr.GT.parj(32)+pm1+pm2) GOTO 490    
         kfldum=int(1.5+rlu(0))  
         CALL lukfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)    
         CALL lukfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)    
         IF(kf1.EQ.0.OR.kf2.EQ.0) GOTO 150   
         psm=ulmass(kf1)+ulmass(kf2) 
         IF(mmat.EQ.42.AND.pmr.GT.parj(64)+psm) GOTO 490 
         IF(mmat.GE.43.AND.pmr.GT.0.2*parj(32)+psm) GOTO 490 
         IF(nd.EQ.4.OR.kfa.EQ.15) GOTO 150   
         k(n+1,1)=1  
         kftemp=k(n+1,2) 
         CALL lukfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))    
         IF(k(n+1,2).EQ.0) GOTO 150  
         p(n+1,5)=ulmass(k(n+1,2))   
         k(n+2,2)=k(n+3,2)   
         p(n+2,5)=p(n+3,5)   
         ps=p(n+1,5)+p(n+2,5)    
         pv(2,5)=p(n+3,5)    
         mmat=0  
         nd=2    
         GOTO 370    
       ENDIF 
     
 C...Phase space decay of partons from W decay.  
   490 IF(mmat.EQ.42.AND.iabs(k(n+1,2)).LT.10) THEN  
         kflo(1)=k(n+1,2)    
         kflo(2)=k(n+2,2)    
         k(n+1,1)=k(n+3,1)   
         k(n+1,2)=k(n+3,2)   
         DO 500 j=1,5    
         pv(1,j)=p(n+1,j)+p(n+2,j)   
   500   p(n+1,j)=p(n+3,j)   
         pv(1,5)=pmr 
         n=n+1   
         np=0    
         nq=2    
         ps=0.   
         mstj(93)=2  
         psq=ulmass(kflo(1)) 
         mstj(93)=2  
         psq=psq+ulmass(kflo(2)) 
         mmat=11 
         GOTO 180    
       ENDIF 
     
 C...Boost back for rapidly moving particle. 
   510 n=n+nd    
       IF(mbst.EQ.1) THEN    
         DO 520 j=1,3    
   520   be(j)=p(ip,j)/p(ip,4)   
         ga=p(ip,4)/p(ip,5)  
         DO 540 i=nsav+1,n   
         bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)  
         DO 530 j=1,3    
   530   p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)  
   540   p(i,4)=ga*(p(i,4)+bep)  
       ENDIF 
     
 C...Fill in position of decay vertex.   
       DO 560 i=nsav+1,n 
       DO 550 j=1,4  
   550 v(i,j)=vdcy(j)    
   560 v(i,5)=0. 
     
 C...Set up for parton shower evolution from jets.   
       IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN    
         k(nsav+1,1)=3   
         k(nsav+2,1)=3   
         k(nsav+3,1)=3   
         k(nsav+1,4)=mstu(5)*(nsav+2)    
         k(nsav+1,5)=mstu(5)*(nsav+3)    
         k(nsav+2,4)=mstu(5)*(nsav+3)    
         k(nsav+2,5)=mstu(5)*(nsav+1)    
         k(nsav+3,4)=mstu(5)*(nsav+1)    
         k(nsav+3,5)=mstu(5)*(nsav+2)    
         mstj(92)=-(nsav+1)  
       ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN  
         k(nsav+2,1)=3   
         k(nsav+3,1)=3   
         k(nsav+2,4)=mstu(5)*(nsav+3)    
         k(nsav+2,5)=mstu(5)*(nsav+3)    
         k(nsav+3,4)=mstu(5)*(nsav+2)    
         k(nsav+3,5)=mstu(5)*(nsav+2)    
         mstj(92)=nsav+2 
       ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46).    
      &and.iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN 
         k(nsav+1,1)=3   
         k(nsav+2,1)=3   
         k(nsav+1,4)=mstu(5)*(nsav+2)    
         k(nsav+1,5)=mstu(5)*(nsav+2)    
         k(nsav+2,4)=mstu(5)*(nsav+1)    
         k(nsav+2,5)=mstu(5)*(nsav+1)    
         mstj(92)=nsav+1 
       ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)  
      &THEN  
         k(nsav+1,1)=3   
         k(nsav+2,1)=3   
         k(nsav+3,1)=3   
         kcp=lucomp(k(nsav+1,2)) 
         kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))    
         jcon=4  
         IF(kqp.LT.0) jcon=5 
         k(nsav+1,jcon)=mstu(5)*(nsav+2) 
         k(nsav+2,9-jcon)=mstu(5)*(nsav+1)   
         k(nsav+2,jcon)=mstu(5)*(nsav+3) 
         k(nsav+3,9-jcon)=mstu(5)*(nsav+2)   
         mstj(92)=nsav+1 
       ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN 
         k(nsav+1,1)=3   
         k(nsav+3,1)=3   
         k(nsav+1,4)=mstu(5)*(nsav+3)    
         k(nsav+1,5)=mstu(5)*(nsav+3)    
         k(nsav+3,4)=mstu(5)*(nsav+1)    
         k(nsav+3,5)=mstu(5)*(nsav+1)    
         mstj(92)=nsav+1 
       ENDIF 
     
 C...Mark decayed particle.  
       IF(k(ip,1).EQ.5) k(ip,1)=15   
       IF(k(ip,1).LE.10) k(ip,1)=11  
       k(ip,4)=nsav+1    
       k(ip,5)=n 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luedit()

subroutine luedit ( MEDIT )

Definition at line 5490 of file hipyset1.35.f.

     
 C...Purpose: to perform global manipulations on the event record,   
 C...in particular to exclude unstable or undetectable partons/particles.    
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension ns(2),pts(2),pls(2) 
     
 C...Remove unwanted partons/particles.  
       IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN    
         imax=n  
         IF(mstu(2).GT.0) imax=mstu(2)   
         i1=max(1,mstu(1))-1 
         DO 110 i=max(1,mstu(1)),imax    
         IF(k(i,1).EQ.0.OR.k(i,1).GT.20) GOTO 110    
         IF(medit.EQ.1) THEN 
           IF(k(i,1).GT.10) GOTO 110 
         ELSEIF(medit.EQ.2) THEN 
           IF(k(i,1).GT.10) GOTO 110 
           kc=lucomp(k(i,2)) 
           IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)   
      &    GOTO 110  
         ELSEIF(medit.EQ.3) THEN 
           IF(k(i,1).GT.10) GOTO 110 
           kc=lucomp(k(i,2)) 
           IF(kc.EQ.0) GOTO 110  
           IF(kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) GOTO 110  
         ELSEIF(medit.EQ.5) THEN 
           IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) GOTO 110 
           kc=lucomp(k(i,2)) 
           IF(kc.EQ.0) GOTO 110  
           IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) GOTO 110 
         ENDIF   
     
 C...Pack remaining partons/particles. Origin no longer known.   
         i1=i1+1 
         DO 100 j=1,5    
         k(i1,j)=k(i,j)  
         p(i1,j)=p(i,j)  
   100   v(i1,j)=v(i,j)  
         k(i1,3)=0   
   110   CONTINUE    
         n=i1    
     
 C...Selective removal of class of entries. New position of retained.    
       ELSEIF(medit.GE.11.AND.medit.LE.15) THEN  
         i1=0    
         DO 120 i=1,n    
         k(i,3)=mod(k(i,3),mstu(5))  
         IF(medit.EQ.11.AND.k(i,1).LT.0) GOTO 120    
         IF(medit.EQ.12.AND.k(i,1).EQ.0) GOTO 120    
         IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.    
      &  k(i,1).EQ.15).AND.k(i,2).NE.94) GOTO 120    
         IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.    
      &  k(i,2).EQ.94)) GOTO 120 
         IF(medit.EQ.15.AND.k(i,1).GE.21) GOTO 120   
         i1=i1+1 
         k(i,3)=k(i,3)+mstu(5)*i1    
   120   CONTINUE    
     
 C...Find new event history information and replace old. 
         DO 140 i=1,n    
         IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0) GOTO 140 
         id=i    
   130   im=mod(k(id,3),mstu(5)) 
         IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN    
           IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND. 
      &    k(im,2).NE.94) THEN   
             id=im   
             GOTO 130    
           ENDIF 
         ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN    
           IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN  
             id=im   
             GOTO 130    
           ENDIF 
         ENDIF   
         k(i,3)=mstu(5)*(k(i,3)/mstu(5)) 
         IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)   
         IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN  
           IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)= 
      &    k(k(i,4),3)/mstu(5)   
           IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)= 
      &    k(k(i,5),3)/mstu(5)   
         ELSE    
           kcm=mod(k(i,4)/mstu(5),mstu(5))   
           IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)  
           kcd=mod(k(i,4),mstu(5))   
           IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)  
           k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd 
           kcm=mod(k(i,5)/mstu(5),mstu(5))   
           IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)  
           kcd=mod(k(i,5),mstu(5))   
           IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)  
           k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd 
         ENDIF   
   140   CONTINUE    
     
 C...Pack remaining entries. 
         i1=0    
         DO 160 i=1,n    
         IF(k(i,3)/mstu(5).EQ.0) GOTO 160    
         i1=i1+1 
         DO 150 j=1,5    
         k(i1,j)=k(i,j)  
         p(i1,j)=p(i,j)  
   150   v(i1,j)=v(i,j)  
         k(i1,3)=mod(k(i1,3),mstu(5))    
   160   CONTINUE    
         n=i1    
     
 C...Save top entries at bottom of LUJETS commonblock.   
       ELSEIF(medit.EQ.21) THEN  
         IF(2*n.GE.mstu(4)) THEN 
           CALL luerrm(11,'(LUEDIT:) no more memory left in LUJETS') 
           RETURN    
         ENDIF   
         DO 170 i=1,n    
         DO 170 j=1,5    
         k(mstu(4)-i,j)=k(i,j)   
         p(mstu(4)-i,j)=p(i,j)   
   170   v(mstu(4)-i,j)=v(i,j)   
         mstu(32)=n  
     
 C...Restore bottom entries of commonblock LUJETS to top.    
       ELSEIF(medit.EQ.22) THEN  
         DO 180 i=1,mstu(32) 
         DO 180 j=1,5    
         k(i,j)=k(mstu(4)-i,j)   
         p(i,j)=p(mstu(4)-i,j)   
   180   v(i,j)=v(mstu(4)-i,j)   
         n=mstu(32)  
     
 C...Mark primary entries at top of commonblock LUJETS as untreated. 
       ELSEIF(medit.EQ.23) THEN  
         i1=0    
         DO 190 i=1,n    
         kh=k(i,3)   
         IF(kh.GE.1) THEN    
           IF(k(kh,1).GT.20) kh=0    
         ENDIF   
         IF(kh.NE.0) GOTO 200    
         i1=i1+1 
   190   IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10  
   200   n=i1    
     
 C...Place largest axis along z axis and second largest in xy plane. 
       ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN   
         CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61),1),   
      &  p(mstu(61),2)),0d0,0d0,0d0) 
         CALL ludbrb(1,n+mstu(3),-ulangl(p(mstu(61),3),  
      &  p(mstu(61),1)),0.,0d0,0d0,0d0)  
         CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61)+1,1), 
      &  p(mstu(61)+1,2)),0d0,0d0,0d0)   
         IF(medit.EQ.31) RETURN  
     
 C...Rotate to put slim jet along +z axis.   
         DO 210 is=1,2   
         ns(is)=0    
         pts(is)=0.  
   210   pls(is)=0.  
         DO 220 i=1,n    
         IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 220    
         IF(mstu(41).GE.2) THEN  
           kc=lucomp(k(i,2)) 
           IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
      &    kc.EQ.18) GOTO 220    
           IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
      &    GOTO 220  
         ENDIF   
         is=2.-sign(0.5,p(i,3))  
         ns(is)=ns(is)+1 
         pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)   
   220   CONTINUE    
         IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)  
      &  CALL ludbrb(1,n+mstu(3),paru(1),0.,0d0,0d0,0d0) 
     
 C...Rotate to put second largest jet into -z,+x quadrant.   
         DO 230 i=1,n    
         IF(p(i,3).GE.0.) GOTO 230   
         IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 230    
         IF(mstu(41).GE.2) THEN  
           kc=lucomp(k(i,2)) 
           IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
      &    kc.EQ.18) GOTO 230    
           IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
      &    GOTO 230  
         ENDIF   
         is=2.-sign(0.5,p(i,1))  
         pls(is)=pls(is)-p(i,3)  
   230   CONTINUE    
         IF(pls(2).GT.pls(1)) CALL ludbrb(1,n+mstu(3),0.,paru(1),    
      &  0d0,0d0,0d0)    
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lueevt()

subroutine lueevt	(	KFL,
		ECM
	)

Definition at line 8085 of file hipyset1.35.f.

     
 C...Purpose: to handle the generation of an e+e- annihilation jet event.    
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Check input parameters. 
       IF(mstu(12).GE.1) CALL lulist(0)  
       IF(kfl.LT.0.OR.kfl.GT.8) THEN 
         CALL luerrm(16,'(LUEEVT:) called with unknown flavour code')    
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       IF(kfl.LE.5) ecmmin=parj(127)+2.02*parf(100+max(1,kfl))   
       IF(kfl.GE.6) ecmmin=parj(127)+2.02*pmas(kfl,1)    
       IF(ecm.LT.ecmmin) THEN    
         CALL luerrm(16,'(LUEEVT:) called with too small CM energy') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Check consistency of MSTJ options set.  
       IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN    
         CALL luerrm(6,  
      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1') 
         mstj(110)=1 
       ENDIF 
       IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN    
         CALL luerrm(6,  
      &  '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0') 
         mstj(111)=0 
       ENDIF 
     
 C...Initialize alpha_strong and total cross-section.    
       mstu(111)=mstj(108)   
       IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1)) 
      &mstu(111)=1   
       paru(112)=parj(121)   
       IF(mstu(111).EQ.2) paru(112)=parj(122)    
       IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.   
      &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL luxtot(kfl,ecm, 
      &xtot) 
       IF(mstj(116).GE.3) mstj(116)=1    
     
 C...Add initial e+e- to event record (documentation only).  
       ntry=0    
   100 ntry=ntry+1   
       IF(ntry.GT.100) THEN  
         CALL luerrm(14,'(LUEEVT:) caught in an infinite loop')  
         RETURN  
       ENDIF 
       nc=0  
       IF(mstj(115).GE.2) THEN   
         nc=nc+2 
         CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)  
         k(nc-1,1)=21    
         CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)  
         k(nc,1)=21  
       ENDIF 
     
 C...Radiative photon (in initial state).    
       mk=0  
       ecmc=ecm  
       IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL luradk(ecm,mk,pak, 
      &thek,phik,alpk)   
       IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2.*pak))   
       IF(mstj(115).GE.1.AND.mk.EQ.1) THEN   
         nc=nc+1 
         CALL lu1ent(nc,22,pak,thek,phik)    
         k(nc,3)=min(mstj(115)/2,1)  
       ENDIF 
     
 C...Virtual exchange boson (gamma or Z0).   
       IF(mstj(115).GE.3) THEN   
         nc=nc+1 
         kf=22   
         IF(mstj(102).EQ.2) kf=23    
         mstu10=mstu(10) 
         mstu(10)=1  
         p(nc,5)=ecmc    
         CALL lu1ent(nc,kf,ecmc,0.,0.)   
         k(nc,1)=21  
         k(nc,3)=1   
         mstu(10)=mstu10 
       ENDIF 
     
 C...Choice of flavour and jet configuration.    
       CALL luxkfl(kfl,ecm,ecmc,kflc)    
       IF(kflc.EQ.0) GOTO 100    
       CALL luxjet(ecmc,njet,cut)    
       kfln=21   
       IF(njet.EQ.4) CALL lux4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,   
      &x12,x14)  
       IF(njet.EQ.3) CALL lux3jt(njet,cut,kflc,ecmc,x1,x3)   
       IF(njet.EQ.2) mstj(120)=1 
     
 C...Fill jet configuration and origin.  
       IF(njet.EQ.2.AND.mstj(101).NE.5) CALL lu2ent(nc+1,kflc,-kflc,ecmc)    
       IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL lu2ent(-(nc+1),kflc,-kflc,  
      &ecmc) 
       IF(njet.EQ.3) CALL lu3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)  
       IF(njet.EQ.4.AND.kfln.EQ.21) CALL lu4ent(nc+1,kflc,kfln,kfln, 
      &-kflc,ecmc,x1,x2,x4,x12,x14)  
       IF(njet.EQ.4.AND.kfln.NE.21) CALL lu4ent(nc+1,kflc,-kfln,kfln,    
      &-kflc,ecmc,x1,x2,x4,x12,x14)  
       DO 110 ip=nc+1,n  
   110 k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)   
     
 C...Angular orientation according to matrix element.    
       IF(mstj(106).EQ.1) THEN   
         CALL luxdif(nc,njet,kflc,ecmc,chi,the,phi)  
         CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)  
         CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0) 
       ENDIF 
     
 C...Rotation and boost from radiative photon.   
       IF(mk.EQ.1) THEN  
         dbek=-pak/(ecm-pak) 
         nmin=nc+1-mstj(115)/3   
         CALL ludbrb(nmin,n,0.,-phik,0d0,0d0,0d0)    
         CALL ludbrb(nmin,n,alpk,0.,dbek*sin(thek),0d0,dbek*cos(thek))   
         CALL ludbrb(nmin,n,0.,phik,0d0,0d0,0d0) 
       ENDIF 
     
 C...Generate parton shower. Rearrange along strings and check.  
       IF(mstj(101).EQ.5) THEN   
         CALL lushow(n-1,n,ecmc) 
         mstj14=mstj(14) 
         IF(mstj(105).EQ.-1) mstj(14)=0  
         IF(mstj(105).GE.0) mstu(28)=0   
         CALL luprep(0)  
         mstj(14)=mstj14 
         IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100   
       ENDIF 
     
 C...Fragmentation/decay generation. Information for LUTABU. 
       IF(mstj(105).EQ.1) CALL luexec    
       mstu(161)=kflc    
       mstu(162)=-kflc   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luerrm()

subroutine luerrm	(		MERR,
		character, dimension(*)	CHMESS
	)

Definition at line 5049 of file hipyset1.35.f.

     
 C...Purpose: to inform user of errors in program execution. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       CHARACTER chmess*(*)  
     
 C...Write first few warnings, then be silent.   
       IF(merr.LE.10) THEN   
         mstu(27)=mstu(27)+1 
         mstu(28)=merr   
         IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),1000) 
      &  merr,mstu(31),chmess    
     
 C...Write first few errors, then be silent or stop program. 
       ELSEIF(merr.LE.20) THEN   
         mstu(23)=mstu(23)+1 
         mstu(24)=merr-10    
         IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),1100) 
      &  merr-10,mstu(31),chmess 
         IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN 
           WRITE(mstu(11),1100) merr-10,mstu(31),chmess  
           WRITE(mstu(11),1200)  
           IF(merr.NE.17) CALL lulist(2) 
           stop  
         ENDIF   
     
 C...Stop program in case of irreparable error.  
       ELSE  
         WRITE(mstu(11),1300) merr-20,mstu(31),chmess    
         stop    
       ENDIF 
     
 C...Formats for output. 
  1000 FORMAT(/5x,'Advisory warning type',i2,' given after',i6,  
      &' LUEXEC calls:'/5x,a)    
  1100 FORMAT(/5x,'Error type',i2,' has occured after',i6,   
      &' LUEXEC calls:'/5x,a)    
  1200 FORMAT(5x,'Execution will be stopped after listing of last ', 
      &'event!') 
  1300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i6, 
      &' LUEXEC calls:'/5x,a/5x,'Execution will now be stopped!')    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luexec()

subroutine luexec ( )

Definition at line 727 of file hipyset1.35.f.

     
 C...Purpose: to administrate the fragmentation and decay chain. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       dimension ps(2,6) 
     
 C...Initialize and reset.   
       mstu(24)=0    
       IF(mstu(12).GE.1) CALL lulist(0)  
       mstu(31)=mstu(31)+1   
       mstu(1)=0 
       mstu(2)=0 
       mstu(3)=0 
       mcons=1   
     
 C...Sum up momentum, energy and charge for starting entries.    
       nsav=n    
       DO 100 i=1,2  
       DO 100 j=1,6  
   100 ps(i,j)=0.    
       DO 120 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120  
       DO 110 j=1,4  
   110 ps(1,j)=ps(1,j)+p(i,j)    
       ps(1,6)=ps(1,6)+luchge(k(i,2))    
   120 CONTINUE  
       paru(21)=ps(1,4)  
     
 C...Prepare system for subsequent fragmentation/decay.  
       CALL luprep(0)    
     
 C...Loop through jet fragmentation and particle decays. 
       mbe=0 
   130 mbe=mbe+1 
       ip=0  
   140 ip=ip+1   
       kc=0  
       IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=lucomp(k(ip,2)) 
       IF(kc.EQ.0) THEN  
     
 C...Particle decay if unstable and allowed. Save long-lived particle    
 C...decays until second pass after Bose-Einstein effects.   
       ELSEIF(kchg(kc,2).EQ.0) THEN  
         IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe. 
      &  eq.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))    
      &  CALL ludecy(ip) 
     
 C...Decay products may develop a shower.    
         IF(mstj(92).GT.0) THEN  
           ip1=mstj(92)  
           qmax=sqrt(max(0.,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,  
      &    1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))    
           CALL lushow(ip1,ip1+1,qmax)   
           CALL luprep(ip1)  
           mstj(92)=0    
         ELSEIF(mstj(92).LT.0) THEN  
           ip1=-mstj(92) 
           CALL lushow(ip1,-3,p(ip,5))   
           CALL luprep(ip1)  
           mstj(92)=0    
         ENDIF   
     
 C...Jet fragmentation: string or independent fragmentation. 
       ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN 
         mfrag=mstj(1)   
         IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2 
         IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN 
           IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.   
      &    k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN  
             IF(kchg(lucomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)    
           ENDIF 
         ENDIF   
         IF(mfrag.EQ.1) CALL lustrf(ip)  
         IF(mfrag.EQ.2) CALL luindf(ip)  
         IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0 
         IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0    
       ENDIF 
     
 C...Loop back if enough space left in LUJETS and no error abort.    
       IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN  
       ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN 
         GOTO 140    
       ELSEIF(ip.LT.n) THEN  
         CALL luerrm(11,'(LUEXEC:) no more memory left in LUJETS')   
       ENDIF 
     
 C...Include simple Bose-Einstein effect parametrization if desired. 
       IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN   
         CALL luboei(nsav)   
         GOTO 130    
       ENDIF 
     
 C...Check that momentum, energy and charge were conserved.  
       DO 160 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 160  
       DO 150 j=1,4  
   150 ps(2,j)=ps(2,j)+p(i,j)    
       ps(2,6)=ps(2,6)+luchge(k(i,2))    
   160 CONTINUE  
       pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-  
      &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1.+abs(ps(2,4))+abs(ps(1,4))) 
       IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL luerrm(15,   
      &'(LUEXEC:) four-momentum was not conserved')  
       IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1) CALL luerrm(15,    
      &'(LUEXEC:) charge was not conserved') 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lufowo()

subroutine lufowo	(	H10,
		H20,
		H30,
		H40
	)

Definition at line 7317 of file hipyset1.35.f.

     
 C...Purpose: to calculate the first few Fox-Wolfram moments.    
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Copy momenta for particles and calculate H0.    
       np=0  
       h0=0. 
       hd=0. 
       DO 110 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110  
       IF(mstu(41).GE.2) THEN    
         kc=lucomp(k(i,2))   
         IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
      &  kc.EQ.18) GOTO 110  
         IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
      &  GOTO 110    
       ENDIF 
       IF(n+np.GE.mstu(4)-mstu(32)-5) THEN   
         CALL luerrm(11,'(LUFOWO:) no more memory left in LUJETS')   
         h10=-1. 
         h20=-1. 
         h30=-1. 
         h40=-1. 
         RETURN  
       ENDIF 
       np=np+1   
       DO 100 j=1,3  
   100 p(n+np,j)=p(i,j)  
       p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2) 
       h0=h0+p(n+np,4)   
       hd=hd+p(n+np,4)**2    
   110 CONTINUE  
       h0=h0**2  
     
 C...Very low multiplicities (0 or 1) not considered.    
       IF(np.LE.1) THEN  
         CALL luerrm(8,'(LUFOWO:) too few particles for analysis')   
         h10=-1. 
         h20=-1. 
         h30=-1. 
         h40=-1. 
         RETURN  
       ENDIF 
     
 C...Calculate H1 - H4.  
       h10=0.    
       h20=0.    
       h30=0.    
       h40=0.    
       DO 120 i1=n+1,n+np    
       DO 120 i2=i1+1,n+np   
       cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/   
      &(p(i1,4)*p(i2,4)) 
       h10=h10+p(i1,4)*p(i2,4)*cthe  
       h20=h20+p(i1,4)*p(i2,4)*(1.5*cthe**2-0.5) 
       h30=h30+p(i1,4)*p(i2,4)*(2.5*cthe**3-1.5*cthe)    
       h40=h40+p(i1,4)*p(i2,4)*(4.375*cthe**4-3.75*cthe**2+0.375)    
   120 CONTINUE  
     
 C...Calculate H1/H0 - H4/H0. Output.    
       mstu(61)=n+1  
       mstu(62)=np   
       h10=(hd+2.*h10)/h0    
       h20=(hd+2.*h20)/h0    
       h30=(hd+2.*h30)/h0    
       h40=(hd+2.*h40)/h0    
     
       RETURN    

Here is the call graph for this function:

◆ lugive()

subroutine lugive ( character, dimension(*) CHIN )

Definition at line 478 of file hipyset1.35.f.

     
 C...Purpose: to set values of commonblock variables.    
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/ludat4/chaf(500)   
       CHARACTER chaf*8  
       SAVE /ludat4/ 
       CHARACTER chin*(*),chfix*104,chbit*104,chold*8,chnew*8,   
      &chnam*4,chvar(17)*4,chalp(2)*26,chind*8,chini*10,chinr*16 
       DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',    
      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/  
       DATA chalp/'abcdefghijklmnopqrstuvwxyz',  
      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
     
 C...Length of character variable. Subdivide it into instructions.   
       IF(mstu(12).GE.1) CALL lulist(0)  
       chbit=chin//' '   
       lbit=101  
   100 lbit=lbit-1   
       IF(chbit(lbit:lbit).EQ.' ') GOTO 100  
       ltot=0    
       DO 110 lcom=1,lbit    
       IF(chbit(lcom:lcom).EQ.' ') GOTO 110  
       ltot=ltot+1   
       chfix(ltot:ltot)=chbit(lcom:lcom) 
   110 CONTINUE  
       llow=0    
   120 lhig=llow+1   
   130 lhig=lhig+1   
       IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') GOTO 130 
       lbit=lhig-llow-1  
       chbit(1:lbit)=chfix(llow+1:lhig-1)    
     
 C...Identify commonblock variable.  
       lnam=1    
   140 lnam=lnam+1   
       IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.   
      &lnam.LE.4) GOTO 140   
       chnam=chbit(1:lnam-1)//' '    
       DO 150 lcom=1,lnam-1  
       DO 150 lalp=1,26  
   150 IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)= 
      &chalp(2)(lalp:lalp)   
       ivar=0    
       DO 160 iv=1,17    
   160 IF(chnam.EQ.chvar(iv)) ivar=iv    
       IF(ivar.EQ.0) THEN    
         CALL luerrm(18,'(LUGIVE:) do not recognize variable '//chnam)   
         llow=lhig   
         IF(llow.LT.ltot) GOTO 120   
         RETURN  
       ENDIF 
     
 C...Identify any indices.   
       i=0   
       j=0   
       IF(chbit(lnam:lnam).EQ.'(') THEN  
         lind=lnam   
   170   lind=lind+1 
         IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 170    
         chind=' '   
         IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c').    
      &  and.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17)) THEN 
           chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)    
           READ(chind,'(I8)') i1 
           i=lucomp(i1)  
         ELSE    
           chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)    
           READ(chind,'(I8)') i  
         ENDIF   
         lnam=lind   
         IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1 
       ENDIF 
       IF(chbit(lnam:lnam).EQ.',') THEN  
         lind=lnam   
   180   lind=lind+1 
         IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 180    
         chind=' '   
         chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)  
         READ(chind,'(I8)') j    
         lnam=lind+1 
       ENDIF 
     
 C...Check that indices allowed and save old value.  
       ierr=1    
       IF(chbit(lnam:lnam).NE.'=') GOTO 190  
       IF(ivar.EQ.1) THEN    
         IF(i.NE.0.OR.j.NE.0) GOTO 190   
         iold=n  
       ELSEIF(ivar.EQ.2) THEN    
         IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) GOTO 190 
         iold=k(i,j) 
       ELSEIF(ivar.EQ.3) THEN    
         IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) GOTO 190 
         rold=p(i,j) 
       ELSEIF(ivar.EQ.4) THEN    
         IF(i.LT.1.OR.i.GT.mstu(4).OR.j.LT.1.OR.j.GT.5) GOTO 190 
         rold=v(i,j) 
       ELSEIF(ivar.EQ.5) THEN    
         IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190   
         iold=mstu(i)    
       ELSEIF(ivar.EQ.6) THEN    
         IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190   
         rold=paru(i)    
       ELSEIF(ivar.EQ.7) THEN    
         IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190   
         iold=mstj(i)    
       ELSEIF(ivar.EQ.8) THEN    
         IF(i.LT.1.OR.i.GT.200.OR.j.NE.0) GOTO 190   
         rold=parj(i)    
       ELSEIF(ivar.EQ.9) THEN    
         IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.3) GOTO 190 
         iold=kchg(i,j)  
       ELSEIF(ivar.EQ.10) THEN   
         IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.4) GOTO 190 
         rold=pmas(i,j)  
       ELSEIF(ivar.EQ.11) THEN   
         IF(i.LT.1.OR.i.GT.2000.OR.j.NE.0) GOTO 190  
         rold=parf(i)    
       ELSEIF(ivar.EQ.12) THEN   
         IF(i.LT.1.OR.i.GT.4.OR.j.LT.1.OR.j.GT.4) GOTO 190   
         rold=vckm(i,j)  
       ELSEIF(ivar.EQ.13) THEN   
         IF(i.LT.1.OR.i.GT.mstu(6).OR.j.LT.1.OR.j.GT.3) GOTO 190 
         iold=mdcy(i,j)  
       ELSEIF(ivar.EQ.14) THEN   
         IF(i.LT.1.OR.i.GT.mstu(7).OR.j.LT.1.OR.j.GT.2) GOTO 190 
         iold=mdme(i,j)  
       ELSEIF(ivar.EQ.15) THEN   
         IF(i.LT.1.OR.i.GT.mstu(7).OR.j.NE.0) GOTO 190   
         rold=brat(i)    
       ELSEIF(ivar.EQ.16) THEN   
         IF(i.LT.1.OR.i.GT.mstu(7).OR.j.LT.1.OR.j.GT.5) GOTO 190 
         iold=kfdp(i,j)  
       ELSEIF(ivar.EQ.17) THEN   
         IF(i.LT.1.OR.i.GT.mstu(6).OR.j.NE.0) GOTO 190   
         chold=chaf(i)   
       ENDIF 
       ierr=0    
   190 IF(ierr.EQ.1) THEN    
         CALL luerrm(18,'(LUGIVE:) unallowed indices for '// 
      &  chbit(1:lnam-1))    
         llow=lhig   
         IF(llow.LT.ltot) GOTO 120   
         RETURN  
       ENDIF 
     
 C...Print current value of variable. Loop back. 
       IF(lnam.GE.lbit) THEN 
         chbit(lnam:14)=' '  
         chbit(15:60)=' has the value                                '   
         IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR. 
      &  ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN   
           WRITE(chbit(51:60),'(I10)') iold  
         ELSEIF(ivar.NE.17) THEN 
           WRITE(chbit(47:60),'(F14.5)') rold    
         ELSE    
           chbit(53:60)=chold    
         ENDIF   
         IF(mstu(13).GE.1) WRITE(mstu(11),1000) chbit(1:60)  
         llow=lhig   
         IF(llow.LT.ltot) GOTO 120   
         RETURN  
       ENDIF 
     
 C...Read in new variable value. 
       IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR.   
      &ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN 
         chini=' '   
         chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)   
         READ(chini,'(I10)') inew    
       ELSEIF(ivar.NE.17) THEN   
         chinr=' '   
         chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)   
         READ(chinr,'(F16.2)') rnew  
       ELSE  
         chnew=chbit(lnam+1:lbit)//' '   
       ENDIF 
     
 C...Store new variable value.   
       IF(ivar.EQ.1) THEN    
         n=inew  
       ELSEIF(ivar.EQ.2) THEN    
         k(i,j)=inew 
       ELSEIF(ivar.EQ.3) THEN    
         p(i,j)=rnew 
       ELSEIF(ivar.EQ.4) THEN    
         v(i,j)=rnew 
       ELSEIF(ivar.EQ.5) THEN    
         mstu(i)=inew    
       ELSEIF(ivar.EQ.6) THEN    
         paru(i)=rnew    
       ELSEIF(ivar.EQ.7) THEN    
         mstj(i)=inew    
       ELSEIF(ivar.EQ.8) THEN    
         parj(i)=rnew    
       ELSEIF(ivar.EQ.9) THEN    
         kchg(i,j)=inew  
       ELSEIF(ivar.EQ.10) THEN   
         pmas(i,j)=rnew  
       ELSEIF(ivar.EQ.11) THEN   
         parf(i)=rnew    
       ELSEIF(ivar.EQ.12) THEN   
         vckm(i,j)=rnew  
       ELSEIF(ivar.EQ.13) THEN   
         mdcy(i,j)=inew  
       ELSEIF(ivar.EQ.14) THEN   
         mdme(i,j)=inew  
       ELSEIF(ivar.EQ.15) THEN   
         brat(i)=rnew    
       ELSEIF(ivar.EQ.16) THEN   
         kfdp(i,j)=inew  
       ELSEIF(ivar.EQ.17) THEN   
         chaf(i)=chnew   
       ENDIF 
     
 C...Write old and new value. Loop back. 
       chbit(lnam:14)=' '    
       chbit(15:60)=' changed from                to               ' 
       IF(ivar.EQ.1.OR.ivar.EQ.2.OR.ivar.EQ.5.OR.ivar.EQ.7.OR.   
      &ivar.EQ.9.OR.ivar.EQ.13.OR.ivar.EQ.14.OR.ivar.EQ.16) THEN 
         WRITE(chbit(33:42),'(I10)') iold    
         WRITE(chbit(51:60),'(I10)') inew    
       ELSEIF(ivar.NE.17) THEN   
         WRITE(chbit(29:42),'(F14.5)') rold  
         WRITE(chbit(47:60),'(F14.5)') rnew  
       ELSE  
         chbit(35:42)=chold  
         chbit(53:60)=chnew  
       ENDIF 
       IF(mstu(13).GE.1) WRITE(mstu(11),1000) chbit(1:60)    
       llow=lhig 
       IF(llow.LT.ltot) GOTO 120 
     
 C...Format statement for output on unit MSTU(11) (by default 6).    
  1000 FORMAT(5x,a60)    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luhepc()

subroutine luhepc ( MCONV )

Definition at line 9337 of file hipyset1.35.f.

     
 C...Purpose: to convert JETSET event record contents to or from 
 C...the standard event record commonblock.  
       parameter(nmxhep=9000)   
       common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),   
      &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)   
       SAVE /hepevt/ 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Conversion from JETSET to standard, the easy part.  
       IF(mconv.EQ.1) THEN   
         nevhep=0    
         IF(n.GT.nmxhep) CALL luerrm(8,  
      &  '(LUHEPC:) no more space in /HEPEVT/')  
         nhep=min(n,nmxhep)  
         DO 140 i=1,nhep 
         isthep(i)=0 
         IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1    
         IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2   
         IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3   
         IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1) 
         idhep(i)=k(i,2) 
         jmohep(1,i)=k(i,3)  
         jmohep(2,i)=0   
         IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN  
           jdahep(1,i)=k(i,4)    
           jdahep(2,i)=k(i,5)    
         ELSE    
           jdahep(1,i)=0 
           jdahep(2,i)=0 
         ENDIF   
         DO 100 j=1,5    
   100   phep(j,i)=p(i,j)    
         DO 110 j=1,4    
   110   vhep(j,i)=v(i,j)    
     
 C...Fill in missing mother information. 
         IF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN  
           i1=k(i,3)-1   
   120     i1=i1+1   
           IF(i1.GE.i) CALL luerrm(8,    
      &    '(LUHEPC:) translation of inconsistent event history')    
           IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) GOTO 120   
           kc=lucomp(k(i1,2))    
           IF(i1.LT.i.AND.kc.EQ.0) GOTO 120  
           IF(i1.LT.i.AND.kchg(kc,2).EQ.0) GOTO 120  
           jmohep(2,i)=i1    
         ELSEIF(k(i,2).EQ.94) THEN   
           njet=2    
           IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3  
           IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4  
           jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))  
           IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=   
      &    mod(k(i+1,4)/mstu(5),mstu(5)) 
         ENDIF   
     
 C...Fill in missing daughter information.   
         IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN 
           DO 130 i1=jdahep(1,i),jdahep(2,i) 
           i2=mod(k(i1,4)/mstu(5),mstu(5))   
   130     jdahep(1,i2)=i    
         ENDIF   
         IF(k(i,2).GE.91.AND.k(i,2).LE.94) GOTO 140  
         i1=jmohep(1,i)  
         IF(i1.LE.0.OR.i1.GT.nhep) GOTO 140  
         IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) GOTO 140    
         IF(jdahep(1,i1).EQ.0) THEN  
           jdahep(1,i1)=i    
         ELSE    
           jdahep(2,i1)=i    
         ENDIF   
   140   CONTINUE    
         DO 150 i=1,nhep 
         IF(k(i,1).NE.13.AND.k(i,1).NE.14) GOTO 150  
         IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)    
   150   CONTINUE    
     
 C...Conversion from standard to JETSET, the easy part.  
       ELSE  
         IF(nhep.GT.mstu(4)) CALL luerrm(8,  
      &  '(LUHEPC:) no more space in /LUJETS/')  
         n=min(nhep,mstu(4)) 
         nkq=0   
         kqsum=0 
         DO 180 i=1,n    
         k(i,1)=0    
         IF(isthep(i).EQ.1) k(i,1)=1 
         IF(isthep(i).EQ.2) k(i,1)=11    
         IF(isthep(i).EQ.3) k(i,1)=21    
         k(i,2)=idhep(i) 
         k(i,3)=jmohep(1,i)  
         k(i,4)=jdahep(1,i)  
         k(i,5)=jdahep(2,i)  
         DO 160 j=1,5    
   160   p(i,j)=phep(j,i)    
         DO 170 j=1,4    
   170   v(i,j)=vhep(j,i)    
         v(i,5)=0.   
         IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN  
           i1=jdahep(1,i)    
           IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))* 
      &    phep(5,i)/phep(4,i)   
         ENDIF   
     
 C...Fill in missing information on colour connection in jet systems.    
         IF(isthep(i).EQ.1) THEN 
           kc=lucomp(k(i,2)) 
           kq=0  
           IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2)) 
           IF(kq.NE.0) nkq=nkq+1 
           IF(kq.NE.2) kqsum=kqsum+kq    
           IF(kq.NE.0.AND.kqsum.NE.0) THEN   
             k(i,1)=2    
           ELSEIF(kq.EQ.2.AND.i.LT.n) THEN   
             IF(k(i+1,2).EQ.21) k(i,1)=2 
           ENDIF 
         ENDIF   
   180   CONTINUE    
         IF(nkq.EQ.1.OR.kqsum.NE.0) CALL luerrm(8,   
      &  '(LUHEPC:) input parton configuration not colour singlet')  
       ENDIF 
     

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luindf()

subroutine luindf ( IP )

Definition at line 2148 of file hipyset1.35.f.

     
 C...Purpose: to handle the fragmentation of a jet system (or a single   
 C...jet) according to independent fragmentation models. 
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),    
      &kflo(2),pxo(2),pyo(2),wo(2)   
     
 C...Reset counters. Identify parton system and take copy. Check flavour.    
       nsav=n    
       njet=0    
       kqsum=0   
       DO 100 j=1,5  
   100 dps(j)=0. 
       i=ip-1    
   110 i=i+1 
       IF(i.GT.min(n,mstu(4)-mstu(32))) THEN 
         CALL luerrm(12,'(LUINDF:) failed to reconstruct jet system')    
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 110  
       kc=lucomp(k(i,2)) 
       IF(kc.EQ.0) GOTO 110  
       kq=kchg(kc,2)*isign(1,k(i,2)) 
       IF(kq.EQ.0) GOTO 110  
       njet=njet+1   
       IF(kq.NE.2) kqsum=kqsum+kq    
       DO 120 j=1,5  
       k(nsav+njet,j)=k(i,j) 
       p(nsav+njet,j)=p(i,j) 
   120 dps(j)=dps(j)+p(i,j)  
       k(nsav+njet,3)=i  
       IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.   
      &k(i+1,1).EQ.2)) GOTO 110  
       IF(njet.NE.1.AND.kqsum.NE.0) THEN 
         CALL luerrm(12,'(LUINDF:) unphysical flavour combination')  
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Boost copied system to CM frame. Find CM energy and sum flavours.   
       IF(njet.NE.1) CALL ludbrb(nsav+1,nsav+njet,0.,0.,-dps(1)/dps(4),  
      &-dps(2)/dps(4),-dps(3)/dps(4))    
       pecm=0.   
       DO 130 j=1,3  
   130 nfi(j)=0  
       DO 140 i=nsav+1,nsav+njet 
       pecm=pecm+p(i,4)  
       kfa=iabs(k(i,2))  
       IF(kfa.LE.3) THEN 
         nfi(kfa)=nfi(kfa)+isign(1,k(i,2))   
       ELSEIF(kfa.GT.1000) THEN  
         kfla=mod(kfa/1000,10)   
         kflb=mod(kfa/100,10)    
         IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))   
         IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))   
       ENDIF 
   140 CONTINUE  
     
 C...Loop over attempts made. Reset counters.    
       ntry=0    
   150 ntry=ntry+1   
       n=nsav+njet   
       IF(ntry.GT.200) THEN  
         CALL luerrm(14,'(LUINDF:) caught in infinite loop') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       DO 160 j=1,3  
       nfl(j)=nfi(j) 
       ifet(j)=0 
   160 kflf(j)=0 
     
 C...Loop over jets to be fragmented.    
       DO 230 ip1=nsav+1,nsav+njet   
       mstj(91)=0    
       nsav1=n   
     
 C...Initial flavour and momentum values. Jet along +z axis. 
       kflh=iabs(k(ip1,2))   
       IF(kflh.GT.10) kflh=mod(kflh/1000,10) 
       kflo(2)=0 
       wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2) 
     
 C...Initial values for quark or diquark jet.    
   170 IF(iabs(k(ip1,2)).NE.21) THEN 
         nstr=1  
         kflo(1)=k(ip1,2)    
         CALL luptdi(0,pxo(1),pyo(1))    
         wo(1)=wf    
     
 C...Initial values for gluon treated like random quark jet. 
       ELSEIF(mstj(2).LE.2) THEN 
         nstr=1  
         IF(mstj(2).EQ.2) mstj(91)=1 
         kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)   
         CALL luptdi(0,pxo(1),pyo(1))    
         wo(1)=wf    
     
 C...Initial values for gluon treated like quark-antiquark jet pair, 
 C...sharing energy according to Altarelli-Parisi splitting function.    
       ELSE  
         nstr=2  
         IF(mstj(2).EQ.4) mstj(91)=1 
         kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)   
         kflo(2)=-kflo(1)    
         CALL luptdi(0,pxo(1),pyo(1))    
         pxo(2)=-pxo(1)  
         pyo(2)=-pyo(1)  
         wo(1)=wf*rlu(0)**(1./3.)    
         wo(2)=wf-wo(1)  
       ENDIF 
     
 C...Initial values for rank, flavour, pT and W+.    
       DO 220 istr=1,nstr    
   180 i=n   
       irank=0   
       kfl1=kflo(istr)   
       px1=pxo(istr) 
       py1=pyo(istr) 
       w=wo(istr)    
     
 C...New hadron. Generate flavour and hadron species.    
   190 i=i+1 
       IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN 
         CALL luerrm(11,'(LUINDF:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       irank=irank+1 
       k(i,1)=1  
       k(i,3)=ip1    
       k(i,4)=0  
       k(i,5)=0  
   200 CALL lukfdi(kfl1,0,kfl2,k(i,2))   
       IF(k(i,2).EQ.0) GOTO 180  
       IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND. 
      &iabs(kfl2).GT.10) THEN    
         IF(rlu(0).GT.parj(19)) GOTO 200 
       ENDIF 
     
 C...Find hadron mass. Generate four-momentum.   
       p(i,5)=ulmass(k(i,2)) 
       CALL luptdi(kfl1,px2,py2) 
       p(i,1)=px1+px2    
       p(i,2)=py1+py2    
       pr=p(i,5)**2+p(i,1)**2+p(i,2)**2  
       CALL luzdis(kfl1,kfl2,pr,z)   
       p(i,3)=0.5*(z*w-pr/(z*w)) 
       p(i,4)=0.5*(z*w+pr/(z*w)) 
       IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND. 
      &p(i,3).LE.0.001) THEN 
         IF(w.GE.p(i,5)+0.5*parj(32)) GOTO 180   
         p(i,3)=0.0001   
         p(i,4)=sqrt(pr) 
         z=p(i,4)/w  
       ENDIF 
     
 C...Remaining flavour and momentum. 
       kfl1=-kfl2    
       px1=-px2  
       py1=-py2  
       w=(1.-z)*w    
       DO 210 j=1,5  
   210 v(i,j)=0. 
     
 C...Check if pL acceptable. Go back for new hadron if enough energy.    
       IF(mstj(3).GE.0.AND.p(i,3).LT.0.) i=i-1   
       IF(w.GT.parj(31)) GOTO 190    
   220 n=i   
       IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1*parj(32) 
       IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) GOTO 170   
     
 C...Rotate jet to new direction.    
       the=ulangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))    
       phi=ulangl(p(ip1,1),p(ip1,2)) 
       CALL ludbrb(nsav1+1,n,the,phi,0d0,0d0,0d0)    
       k(k(ip1,3),4)=nsav1+1 
       k(k(ip1,3),5)=n   
     
 C...End of jet generation loop. Skip conservation in some cases.    
   230 CONTINUE  
       IF(njet.EQ.1.OR.mstj(3).LE.0) GOTO 470    
       IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) GOTO 150 
     
 C...Subtract off produced hadron flavours, finished if zero.    
       DO 240 i=nsav+njet+1,n    
       kfa=iabs(k(i,2))  
       kfla=mod(kfa/1000,10) 
       kflb=mod(kfa/100,10)  
       kflc=mod(kfa/10,10)   
       IF(kfla.EQ.0) THEN    
         IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb    
         IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb    
       ELSE  
         IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))   
         IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))   
         IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))   
       ENDIF 
   240 CONTINUE  
       nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+ 
      &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3    
       IF(nreq.EQ.0) GOTO 320    
     
 C...Take away flavour of low-momentum particles until enough freedom.   
       nrem=0    
   250 irem=0    
       p2min=pecm**2 
       DO 260 i=nsav+njet+1,n    
       p2=p(i,1)**2+p(i,2)**2+p(i,3)**2  
       IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i    
   260 IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2  
       IF(irem.EQ.0) GOTO 150    
       k(irem,1)=7   
       kfa=iabs(k(irem,2))   
       kfla=mod(kfa/1000,10) 
       kflb=mod(kfa/100,10)  
       kflc=mod(kfa/10,10)   
       IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8    
       IF(k(irem,1).EQ.8) GOTO 250   
       IF(kfla.EQ.0) THEN    
         isgn=isign(1,k(irem,2))*(-1)**kflb  
         IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn  
         IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn  
       ELSE  
         IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))    
         IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))    
         IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))    
       ENDIF 
       nrem=nrem+1   
       nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+ 
      &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3    
       IF(nreq.GT.nrem) GOTO 250 
       DO 270 i=nsav+njet+1,n    
   270 IF(k(i,1).EQ.8) k(i,1)=1  
     
 C...Find combination of existing and new flavours for hadron.   
   280 nfet=2    
       IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3  
       IF(nreq.LT.nrem) nfet=1   
       IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0    
       DO 290 j=1,nfet   
       ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*rlu(0) 
       kflf(j)=isign(1,nfl(1))   
       IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))   
   290 IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))  
       IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))    
      &GOTO 280  
       IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.    
      &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3).    
      &lt.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) GOTO 280    
       IF(nfet.EQ.0) kflf(1)=1+int((2.+parj(2))*rlu(0))  
       IF(nfet.EQ.0) kflf(2)=-kflf(1)    
       IF(nfet.EQ.1) kflf(2)=isign(1+int((2.+parj(2))*rlu(0)),-kflf(1))  
       IF(nfet.LE.2) kflf(3)=0   
       IF(kflf(3).NE.0) THEN 
         kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+  
      &  100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1)) 
         IF(kflf(1).EQ.kflf(3).OR.(1.+3.*parj(4))*rlu(0).GT.1.)  
      &  kflfc=kflfc+isign(2,kflfc)  
       ELSE  
         kflfc=kflf(1)   
       ENDIF 
       CALL lukfdi(kflfc,kflf(2),kfldmp,kf)  
       IF(kf.EQ.0) GOTO 280  
       DO 300 j=1,max(2,nfet)    
   300 nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))    
     
 C...Store hadron at random among free positions.    
       npos=min(1+int(rlu(0)*nrem),nrem) 
       DO 310 i=nsav+njet+1,n    
       IF(k(i,1).EQ.7) npos=npos-1   
       IF(k(i,1).EQ.1.OR.npos.NE.0) GOTO 310 
       k(i,1)=1  
       k(i,2)=kf 
       p(i,5)=ulmass(k(i,2)) 
       p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)  
   310 CONTINUE  
       nrem=nrem-1   
       nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+ 
      &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3    
       IF(nrem.GT.0) GOTO 280    
     
 C...Compensate for missing momentum in global scheme (3 options).   
   320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN  
         DO 330 j=1,3    
         psi(j)=0.   
         DO 330 i=nsav+njet+1,n  
   330   psi(j)=psi(j)+p(i,j)    
         psi(4)=psi(1)**2+psi(2)**2+psi(3)**2    
         pws=0.  
         DO 340 i=nsav+njet+1,n  
         IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)  
         IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+  
      &  psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4)) 
   340   IF(mod(mstj(3),5).EQ.3) pws=pws+1.  
         DO 360 i=nsav+njet+1,n  
         IF(mod(mstj(3),5).EQ.1) pw=p(i,4)   
         IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+   
      &  psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4)) 
         IF(mod(mstj(3),5).EQ.3) pw=1.   
         DO 350 j=1,3    
   350   p(i,j)=p(i,j)-psi(j)*pw/pws 
   360   p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)    
     
 C...Compensate for missing momentum withing each jet separately.    
       ELSEIF(mod(mstj(3),5).EQ.4) THEN  
         DO 370 i=n+1,n+njet 
         k(i,1)=0    
         DO 370 j=1,5    
   370   p(i,j)=0.   
         DO 390 i=nsav+njet+1,n  
         ir1=k(i,3)  
         ir2=n+ir1-nsav  
         k(ir2,1)=k(ir2,1)+1 
         pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/  
      &  (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)   
         DO 380 j=1,3    
   380   p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)   
         p(ir2,4)=p(ir2,4)+p(i,4)    
   390   p(ir2,5)=p(ir2,5)+pls   
         pss=0.  
         DO 400 i=n+1,n+njet 
   400   IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8*p(i,5)+0.2))  
         DO 420 i=nsav+njet+1,n  
         ir1=k(i,3)  
         ir2=n+ir1-nsav  
         pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/  
      &  (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)   
         DO 410 j=1,3    
   410   p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1./(p(ir2,5)*pss)-1.)*pls* 
      &  p(ir1,j)    
   420   p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)    
       ENDIF 
     
 C...Scale momenta for energy conservation.  
       IF(mod(mstj(3),5).NE.0) THEN  
         pms=0.  
         pes=0.  
         pqs=0.  
         DO 430 i=nsav+njet+1,n  
         pms=pms+p(i,5)  
         pes=pes+p(i,4)  
   430   pqs=pqs+p(i,5)**2/p(i,4)    
         IF(pms.GE.pecm) GOTO 150    
         neco=0  
   440   neco=neco+1 
         pfac=(pecm-pqs)/(pes-pqs)   
         pes=0.  
         pqs=0.  
         DO 460 i=nsav+njet+1,n  
         DO 450 j=1,3    
   450   p(i,j)=pfac*p(i,j)  
         p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)    
         pes=pes+p(i,4)  
   460   pqs=pqs+p(i,5)**2/p(i,4)    
         IF(neco.LT.10.AND.abs(pecm-pes).GT.2e-6*pecm) GOTO 440  
       ENDIF 
     
 C...Origin of produced particles and parton daughter pointers.  
   470 DO 480 i=nsav+njet+1,n    
       IF(mstu(16).NE.2) k(i,3)=nsav+1   
   480 IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)  
       DO 490 i=nsav+1,nsav+njet 
       i1=k(i,3) 
       k(i1,1)=k(i1,1)+10    
       IF(mstu(16).NE.2) THEN    
         k(i1,4)=nsav+1  
         k(i1,5)=nsav+1  
       ELSE  
         k(i1,4)=k(i1,4)-njet+1  
         k(i1,5)=k(i1,5)-njet+1  
         IF(k(i1,5).LT.k(i1,4)) THEN 
           k(i1,4)=0 
           k(i1,5)=0 
         ENDIF   
       ENDIF 
   490 CONTINUE  
     
 C...Document independent fragmentation system. Remove copy of jets. 
       nsav=nsav+1   
       k(nsav,1)=11  
       k(nsav,2)=93  
       k(nsav,3)=ip  
       k(nsav,4)=nsav+1  
       k(nsav,5)=n-njet+1    
       DO 500 j=1,4  
       p(nsav,j)=dps(j)  
   500 v(nsav,j)=v(ip,j) 
       p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))  
       v(nsav,5)=0.  
       DO 510 i=nsav+njet,n  
       DO 510 j=1,5  
       k(i-njet+1,j)=k(i,j)  
       p(i-njet+1,j)=p(i,j)  
   510 v(i-njet+1,j)=v(i,j)  
       n=n-njet+1    
     
 C...Boost back particle system. Set production vertices.    
       IF(njet.NE.1) CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),   
      &dps(2)/dps(4),dps(3)/dps(4))  
       DO 520 i=nsav+1,n 
       DO 520 j=1,4  
   520 v(i,j)=v(ip,j)    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lujmas()

subroutine lujmas	(	PMH,
		PML
	)

Definition at line 7165 of file hipyset1.35.f.

     
 C...Purpose: to determine, approximately, the two jet masses that   
 C...minimize the sum m_H|2 + m_L|2, a la Clavelli and Wyler.    
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension sm(3,3),sax(3),ps(3,5)  
     
 C...Reset.  
       np=0  
       DO 110 j1=1,3 
       DO 100 j2=j1,3    
   100 sm(j1,j2)=0.  
       DO 110 j2=1,4 
   110 ps(j1,j2)=0.  
       pss=0.    
     
 C...Take copy of particles that are to be considered in mass analysis.  
       DO 150 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150  
       IF(mstu(41).GE.2) THEN    
         kc=lucomp(k(i,2))   
         IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
      &  kc.EQ.18) GOTO 150  
         IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
      &  GOTO 150    
       ENDIF 
       IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN 
         CALL luerrm(11,'(LUJMAS:) no more memory left in LUJETS')   
         pmh=-2. 
         pml=-2. 
         RETURN  
       ENDIF 
       np=np+1   
       DO 120 j=1,5  
   120 p(n+np,j)=p(i,j)  
       IF(mstu(42).EQ.0) p(n+np,5)=0.    
       IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)  
       p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)    
     
 C...Fill information in sphericity tensor and total momentum vector.    
       DO 130 j1=1,3 
       DO 130 j2=j1,3    
   130 sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)   
       pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)   
       DO 140 j=1,4  
   140 ps(3,j)=ps(3,j)+p(n+np,j) 
   150 CONTINUE  
     
 C...Very low multiplicities (0 or 1) not considered.    
       IF(np.LE.1) THEN  
         CALL luerrm(8,'(LUJMAS:) too few particles for analysis')   
         pmh=-1. 
         pml=-1. 
         RETURN  
       ENDIF 
       paru(61)=sqrt(max(0.,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-ps(3,3)**2))    
     
 C...Find largest eigenvalue to matrix (third degree equation).  
       DO 160 j1=1,3 
       DO 160 j2=j1,3    
   160 sm(j1,j2)=sm(j1,j2)/pss   
       sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-   
      &sm(1,3)**2-sm(2,3)**2)/3.-1./9.   
       sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*  
      &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.    
       sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.) 
       sma=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp) 
     
 C...Find largest eigenvector by solving equation system.    
       DO 170 j1=1,3 
       sm(j1,j1)=sm(j1,j1)-sma   
       DO 170 j2=j1+1,3  
   170 sm(j2,j1)=sm(j1,j2)   
       smax=0.   
       DO 180 j1=1,3 
       DO 180 j2=1,3 
       IF(abs(sm(j1,j2)).LE.smax) GOTO 180   
       ja=j1 
       jb=j2 
       smax=abs(sm(j1,j2))   
   180 CONTINUE  
       smax=0.   
       DO 190 j3=ja+1,ja+2   
       j1=j3-3*((j3-1)/3)    
       rl=sm(j1,jb)/sm(ja,jb)    
       DO 190 j2=1,3 
       sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)  
       IF(abs(sm(j1,j2)).LE.smax) GOTO 190   
       jc=j1 
       smax=abs(sm(j1,j2))   
   190 CONTINUE  
       jb1=jb+1-3*(jb/3) 
       jb2=jb+2-3*((jb+1)/3) 
       sax(jb1)=-sm(jc,jb2)  
       sax(jb2)=sm(jc,jb1)   
       sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)  
     
 C...Divide particles into two initial clusters by hemisphere.   
       DO 200 i=n+1,n+np 
       psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)    
       is=1  
       IF(psax.LT.0.) is=2   
       k(i,3)=is 
       DO 200 j=1,4  
   200 ps(is,j)=ps(is,j)+p(i,j)  
       pms=(ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+    
      &(ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2) 
     
 C...Reassign one particle at a time; find maximum decrease of m|2 sum.  
   210 pmd=0.    
       im=0  
       DO 220 j=1,4  
   220 ps(3,j)=ps(1,j)-ps(2,j)   
       DO 230 i=n+1,n+np 
       pps=p(i,4)*ps(3,4)-p(i,1)*ps(3,1)-p(i,2)*ps(3,2)-p(i,3)*ps(3,3)   
       IF(k(i,3).EQ.1) pmdi=2.*(p(i,5)**2-pps)   
       IF(k(i,3).EQ.2) pmdi=2.*(p(i,5)**2+pps)   
       IF(pmdi.LT.pmd) THEN  
         pmd=pmdi    
         im=i    
       ENDIF 
   230 CONTINUE  
     
 C...Loop back if significant reduction in sum of m|2.   
       IF(pmd.LT.-paru(48)*pms) THEN 
         pms=pms+pmd 
         is=k(im,3)  
         DO 240 j=1,4    
         ps(is,j)=ps(is,j)-p(im,j)   
   240   ps(3-is,j)=ps(3-is,j)+p(im,j)   
         k(im,3)=3-is    
         GOTO 210    
       ENDIF 
     
 C...Final masses and output.    
       mstu(61)=n+1  
       mstu(62)=np   
       ps(1,5)=sqrt(max(0.,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)) 
       ps(2,5)=sqrt(max(0.,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)) 
       pmh=max(ps(1,5),ps(2,5))  
       pml=min(ps(1,5),ps(2,5))  
     
       RETURN    

Here is the call graph for this function:

◆ lujoin()

subroutine lujoin	(		NJOIN,
		dimension(*)	IJOIN
	)

Definition at line 425 of file hipyset1.35.f.

     
 C...Purpose: to connect a sequence of partons with colour flow indices, 
 C...as required for subsequent shower evolution (or other operations).  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension ijoin(*)    
     
 C...Check that partons are of right types to be connected.  
       IF(njoin.LT.2) GOTO 120   
       kqsum=0   
       DO 100 ijn=1,njoin    
       i=ijoin(ijn)  
       IF(i.LE.0.OR.i.GT.n) GOTO 120 
       IF(k(i,1).LT.1.OR.k(i,1).GT.3) GOTO 120   
       kc=lucomp(k(i,2)) 
       IF(kc.EQ.0) GOTO 120  
       kq=kchg(kc,2)*isign(1,k(i,2)) 
       IF(kq.EQ.0) GOTO 120  
       IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) GOTO 120    
       IF(kq.NE.2) kqsum=kqsum+kq    
   100 IF(ijn.EQ.1) kqs=kq   
       IF(kqsum.NE.0) GOTO 120   
     
 C...Connect the partons sequentially (closing for gluon loop).  
       kcs=(9-kqs)/2 
       IF(kqs.EQ.2) kcs=int(4.5+rlu(0))  
       DO 110 ijn=1,njoin    
       i=ijoin(ijn)  
       k(i,1)=3  
       IF(ijn.NE.1) ip=ijoin(ijn-1)  
       IF(ijn.EQ.1) ip=ijoin(njoin)  
       IF(ijn.NE.njoin) in=ijoin(ijn+1)  
       IF(ijn.EQ.njoin) in=ijoin(1)  
       k(i,kcs)=mstu(5)*in   
       k(i,9-kcs)=mstu(5)*ip 
       IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0    
   110 IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0  
     
 C...Error exit: no action taken.    
       RETURN    
   120 CALL luerrm(12,   
      &'(LUJOIN:) given entries can not be joined by one string')    
     
       RETURN    

Here is the call graph for this function:

◆ lukfdi()

subroutine lukfdi	(	KFL1,
		KFL2,
		KFL3,
		KF
	)

Definition at line 3251 of file hipyset1.35.f.

     
 C...Purpose: to generate a new flavour pair and combine off a hadron.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Default flavour values. Input consistency checks.   
       kf1a=iabs(kfl1)   
       kf2a=iabs(kfl2)   
       kfl3=0    
       kf=0  
       IF(kf1a.EQ.0) RETURN  
       IF(kf2a.NE.0) THEN    
         IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN 
         IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN    
         IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN    
       ENDIF 
     
 C...Check if tabulated flavour probabilities are to be used.    
       IF(mstj(15).EQ.1) THEN    
         ktab1=-1    
         IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a  
         kfl1a=mod(kf1a/1000,10) 
         kfl1b=mod(kf1a/100,10)  
         kfl1s=mod(kf1a,10)  
         IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4) 
      &  ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2 
         IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1  
         IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a  
         ktab2=0 
         IF(kf2a.NE.0) THEN  
           ktab2=-1  
           IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a    
           kfl2a=mod(kf2a/1000,10)   
           kfl2b=mod(kf2a/100,10)    
           kfl2s=mod(kf2a,10)    
           IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)   
      &    ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2   
           IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1    
         ENDIF   
         IF(ktab1.GE.0.AND.ktab2.GE.0) GOTO 140  
       ENDIF 
     
 C...Parameters and breaking diquark parameter combinations. 
   100 par2=parj(2)  
       par3=parj(3)  
       par4=3.*parj(4)   
       IF(mstj(12).GE.2) THEN    
         par3m=sqrt(parj(3)) 
         par4m=1./(3.*sqrt(parj(4))) 
         pardm=parj(7)/(parj(7)+par3m*parj(6))   
         pars0=parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))   
         pars1=parj(7)*pars0/(2.*par3m)+parj(5)*(parj(6)*(1.+par4m)+ 
      &  par2*par3m*parj(6)*parj(7)) 
         pars2=parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)    
         parsm=max(pars0,pars1,pars2)    
         par4=par4*(1.+parsm)/(1.+parsm/(3.*par4m))  
       ENDIF 
     
 C...Choice of whether to generate meson or baryon.  
       mbary=0   
       kfda=0    
       IF(kf1a.LE.10) THEN   
         IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1.+parj(1))*rlu(0).GT.1.)   
      &  mbary=1 
         IF(kf2a.GT.10) mbary=2  
         IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a  
       ELSE  
         mbary=2 
         IF(kf1a.LE.10000) kfda=kf1a 
       ENDIF 
     
 C...Possibility of process diquark -> meson + new diquark.  
       IF(kfda.NE.0.AND.mstj(12).GE.2) THEN  
         kflda=mod(kfda/1000,10) 
         kfldb=mod(kfda/100,10)  
         kflds=mod(kfda,10)  
         wtdq=pars0  
         IF(max(kflda,kfldb).EQ.3) wtdq=pars1    
         IF(min(kflda,kfldb).EQ.3) wtdq=pars2    
         IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m) 
         IF((1.+wtdq)*rlu(0).GT.1.) mbary=-1 
         IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN    
       ENDIF 
     
 C...Flavour for meson, possibly with new flavour.   
       IF(mbary.LE.0) THEN   
         kfs=isign(1,kfl1)   
         IF(mbary.EQ.0) THEN 
           IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),-kfl1)   
           kfla=max(kf1a,kf2a+iabs(kfl3))    
           kflb=min(kf1a,kf2a+iabs(kfl3))    
           IF(kfla.NE.kf1a) kfs=-kfs 
     
 C...Splitting of diquark into meson plus new diquark.   
         ELSE    
           kfl1a=mod(kf1a/1000,10)   
           kfl1b=mod(kf1a/100,10)    
   110     kfl1d=kfl1a+int(rlu(0)+0.5)*(kfl1b-kfl1a) 
           kfl1e=kfl1a+kfl1b-kfl1d   
           IF((kfl1d.EQ.3.AND.rlu(0).GT.pardm).OR.(kfl1e.EQ.3.AND.   
      &    rlu(0).LT.pardm)) THEN    
             kfl1d=kfl1a+kfl1b-kfl1d 
             kfl1e=kfl1a+kfl1b-kfl1e 
           ENDIF 
           kfl3a=1+int((2.+par2*par3m*parj(7))*rlu(0))   
           IF((kfl1e.NE.kfl3a.AND.rlu(0).GT.(1.+par4m)/max(2.,1.+par4m)).    
      &    or.(kfl1e.EQ.kfl3a.AND.rlu(0).GT.2./max(2.,1.+par4m)))    
      &    GOTO 110  
           kflds=3   
           IF(kfl1e.NE.kfl3a) kflds=2*int(rlu(0)+1./(1.+par4m))+1    
           kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+  
      &    kflds,-kfl1)  
           kfla=max(kfl1d,kfl3a) 
           kflb=min(kfl1d,kfl3a) 
           IF(kfla.NE.kfl1d) kfs=-kfs    
         ENDIF   
     
 C...Form meson, with spin and flavour mixing for diagonal states.   
         IF(kfla.LE.2) kmul=int(parj(11)+rlu(0)) 
         IF(kfla.EQ.3) kmul=int(parj(12)+rlu(0)) 
         IF(kfla.GE.4) kmul=int(parj(13)+rlu(0)) 
         IF(kmul.EQ.0.AND.parj(14).GT.0.) THEN   
           IF(rlu(0).LT.parj(14)) kmul=2 
         ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0.) THEN 
           rmul=rlu(0)   
           IF(rmul.LT.parj(15)) kmul=3   
           IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4    
           IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5   
         ENDIF   
         kfls=3  
         IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1   
         IF(kmul.EQ.5) kfls=5    
         IF(kfla.NE.kflb) THEN   
           kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla 
         ELSE    
           rmix=rlu(0)   
           imix=2*kfla+10*kmul   
           IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+   
      &    int(rmix+parf(imix)))+kfls    
           IF(kfla.GE.4) kf=110*kfla+kfls    
         ENDIF   
         IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)    
         IF(kmul.EQ.4) kf=kf+isign(20000,kf) 
     
 C...Generate diquark flavour.   
       ELSE  
   120   IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN   
           kfla=kf1a 
   130     kflb=1+int((2.+par2*par3)*rlu(0)) 
           kflc=1+int((2.+par2*par3)*rlu(0)) 
           kflds=1   
           IF(kflb.GE.kflc) kflds=3  
           IF(kflds.EQ.1.AND.par4*rlu(0).GT.1.) GOTO 130 
           IF(kflds.EQ.3.AND.par4.LT.rlu(0)) GOTO 130    
           kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1) 
     
 C...Take diquark flavour from input.    
         ELSEIF(kf1a.LE.10) THEN 
           kfla=kf1a 
           kflb=mod(kf2a/1000,10)    
           kflc=mod(kf2a/100,10) 
           kflds=mod(kf2a,10)    
     
 C...Generate (or take from input) quark to go with diquark. 
         ELSE    
           IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),kfl1)    
           kfla=kf2a+iabs(kfl3)  
           kflb=mod(kf1a/1000,10)    
           kflc=mod(kf1a/100,10) 
           kflds=mod(kf1a,10)    
         ENDIF   
     
 C...SU(6) factors for formation of baryon. Try again if fails.  
         kbary=kflds 
         IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5 
         IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1 
         wt=parf(60+kbary)+parj(18)*parf(70+kbary)   
         IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN   
           wtdq=pars0    
           IF(max(kflb,kflc).EQ.3) wtdq=pars1    
           IF(min(kflb,kflc).EQ.3) wtdq=pars2    
           IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)   
           IF(kflds.EQ.1) wt=wt*(1.+wtdq)/(1.+parsm/(3.*par4m))  
           IF(kflds.EQ.3) wt=wt*(1.+wtdq)/(1.+parsm) 
         ENDIF   
         IF(kf2a.EQ.0.AND.wt.LT.rlu(0)) GOTO 120 
     
 C...Form baryon. Distinguish Lambda- and Sigmalike baryons. 
         kfld=max(kfla,kflb,kflc)    
         kflf=min(kfla,kflb,kflc)    
         kfle=kfla+kflb+kflc-kfld-kflf   
         kfls=2  
         IF((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0).GT.  
      &  parf(60+kbary)) kfls=4  
         kfll=0  
         IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN    
           IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1    
           IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25+rlu(0)) 
           IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75+rlu(0)) 
         ENDIF   
         IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)    
         IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)    
       ENDIF 
       RETURN    
     
 C...Use tabulated probabilities to select new flavour and hadron.   
   140 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN 
         kt3l=1  
         kt3u=6  
       ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN  
         kt3l=1  
         kt3u=6  
       ELSEIF(ktab2.EQ.0) THEN   
         kt3l=1  
         kt3u=22 
       ELSE  
         kt3l=ktab2  
         kt3u=ktab2  
       ENDIF 
       rfl=0.    
       DO 150 kts=0,2    
       DO 150 kt3=kt3l,kt3u  
       rfl=rfl+parf(120+80*ktab1+25*kts+kt3) 
   150 CONTINUE  
       rfl=rlu(0)*rfl    
       DO 160 kts=0,2    
       ktabs=kts 
       DO 160 kt3=kt3l,kt3u  
       ktab3=kt3 
       rfl=rfl-parf(120+80*ktab1+25*kts+kt3) 
   160 IF(rfl.LE.0.) GOTO 170    
   170 CONTINUE  
     
 C...Reconstruct flavour of produced quark/diquark.  
       IF(ktab3.LE.6) THEN   
         kfl3a=ktab3 
         kfl3b=0 
         kfl3=isign(kfl3a,kfl1*(2*ktab1-13)) 
       ELSE  
         kfl3a=1 
         IF(ktab3.GE.8) kfl3a=2  
         IF(ktab3.GE.11) kfl3a=3 
         IF(ktab3.GE.16) kfl3a=4 
         kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2   
         kfl3=1000*kfl3a+100*kfl3b+1 
         IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=  
      &  kfl3+2  
         kfl3=isign(kfl3,kfl1*(13-2*ktab1))  
       ENDIF 
     
 C...Reconstruct meson code. 
       IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.  
      &kfl3b.NE.0)) THEN 
         rfl=rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+  
      &  25*ktabs)+parf(145+80*ktab1+25*ktabs))  
         kf=110+2*ktabs+1    
         IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1 
         IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+    
      &  25*ktabs)) kf=330+2*ktabs+1 
       ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN    
         kfla=max(ktab1,ktab3)   
         kflb=min(ktab1,ktab3)   
         kfs=isign(1,kfl1)   
         IF(kfla.NE.kf1a) kfs=-kfs   
         kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla  
       ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN    
         kfs=isign(1,kfl1)   
         IF(kfl1a.EQ.kfl3a) THEN 
           kfla=max(kfl1b,kfl3b) 
           kflb=min(kfl1b,kfl3b) 
           IF(kfla.NE.kfl1b) kfs=-kfs    
         ELSEIF(kfl1a.EQ.kfl3b) THEN 
           kfla=kfl3a    
           kflb=kfl1b    
           kfs=-kfs  
         ELSEIF(kfl1b.EQ.kfl3a) THEN 
           kfla=kfl1a    
           kflb=kfl3b    
         ELSEIF(kfl1b.EQ.kfl3b) THEN 
           kfla=max(kfl1a,kfl3a) 
           kflb=min(kfl1a,kfl3a) 
           IF(kfla.NE.kfl1a) kfs=-kfs    
         ELSE    
           CALL luerrm(2,'(LUKFDI:) no matching flavours for qq -> qq')  
           GOTO 100  
         ENDIF   
         kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla  
     
 C...Reconstruct baryon code.    
       ELSE  
         IF(ktab1.GE.7) THEN 
           kfla=kfl3a    
           kflb=kfl1a    
           kflc=kfl1b    
         ELSE    
           kfla=kfl1a    
           kflb=kfl3a    
           kflc=kfl3b    
         ENDIF   
         kfld=max(kfla,kflb,kflc)    
         kflf=min(kfla,kflb,kflc)    
         kfle=kfla+kflb+kflc-kfld-kflf   
         IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)  
         IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)    
       ENDIF 
     
 C...Check that constructed flavour code is an allowed one.  
       IF(kfl2.NE.0) kfl3=0  
       kc=lucomp(kf) 
       IF(kc.EQ.0) THEN  
         CALL luerrm(2,'(LUKFDI:) user-defined flavour probabilities '// 
      &  'failed')   
         GOTO 100    
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lulist()

subroutine lulist ( MLIST )

Definition at line 5694 of file hipyset1.35.f.

     
 C...Purpose: to give program heading, or list an event, or particle 
 C...data, or current parameter values.  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chmo(12)*3,chdl(7)*4 
       dimension ps(6)   
       DATA chmo/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
      &'Oct','Nov','Dec'/,chdl/'(())',' ','()','!!','<>','==','(==)'/    
     
 C...Initialization printout: version number and date of last change.    
 C      IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN  
 C        WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185), 
 C     &  CHMO(MSTU(184)),MSTU(183)   
 C        MSTU(12)=0  
 C        IF(MLIST.EQ.0) RETURN   
 C      ENDIF 
     
 C...List event data, including additional lines after N.    
       IF(mlist.GE.1.AND.mlist.LE.3) THEN    
         IF(mlist.EQ.1) WRITE(mstu(11),1100) 
         IF(mlist.EQ.2) WRITE(mstu(11),1200) 
         IF(mlist.EQ.3) WRITE(mstu(11),1300) 
         lmx=12  
         IF(mlist.GE.2) lmx=16   
         istr=0  
         imax=n  
         IF(mstu(2).GT.0) imax=mstu(2)   
         DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))  
         IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) GOTO 120  
     
 C...Get particle name, pad it and check it is not too long. 
         CALL luname(k(i,2),chap)    
         len=0   
         DO 100 lem=1,16 
   100   IF(chap(lem:lem).NE.' ') len=lem    
         mdl=(k(i,1)+19)/10  
         ldl=0   
         IF(mdl.EQ.2.OR.mdl.GE.8) THEN   
           chac=chap 
           IF(len.GT.lmx) chac(lmx:lmx)='?'  
         ELSE    
           ldl=1 
           IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2    
           IF(len.EQ.0) THEN 
             chac=chdl(mdl)(1:2*ldl)//' '    
           ELSE  
             chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))// 
      &      chdl(mdl)(ldl+1:2*ldl)//' ' 
             IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'  
           ENDIF 
         ENDIF   
     
 C...Add information on string connection.   
         IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)  
      &  THEN    
           kc=lucomp(k(i,2)) 
           kcc=0 
           IF(kc.NE.0) kcc=kchg(kc,2)    
           IF(kcc.NE.0.AND.istr.EQ.0) THEN   
             istr=1  
             IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'    
           ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN   
             IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'    
           ELSEIF(kcc.NE.0) THEN 
             istr=0  
             IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'    
           ENDIF 
         ENDIF   
     
 C...Write data for particle/jet.    
         IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999.) THEN    
           WRITE(mstu(11),1400) i,chac(1:12),(k(i,j1),j1=1,3),   
      &    (p(i,j2),j2=1,5)  
         ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999.) THEN   
           WRITE(mstu(11),1500) i,chac(1:12),(k(i,j1),j1=1,3),   
      &    (p(i,j2),j2=1,5)  
         ELSEIF(mlist.EQ.1) THEN 
           WRITE(mstu(11),1600) i,chac(1:12),(k(i,j1),j1=1,3),   
      &    (p(i,j2),j2=1,5)  
         ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.    
      &  k(i,1).EQ.14)) THEN 
           WRITE(mstu(11),1700) i,chac,(k(i,j1),j1=1,3), 
      &    k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),   
      &    k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),   
      &    (p(i,j2),j2=1,5)  
         ELSE    
           WRITE(mstu(11),1800) i,chac,(k(i,j1),j1=1,5),(p(i,j2),j2=1,5) 
         ENDIF   
         IF(mlist.EQ.3) WRITE(mstu(11),1900) (v(i,j),j=1,5)  
     
 C...Insert extra separator lines specified by user. 
         IF(mstu(70).GE.1) THEN  
           isep=0    
           DO 110 j=1,min(10,mstu(70))   
   110     IF(i.EQ.mstu(70+j)) isep=1    
           IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),2000) 
           IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),2100) 
         ENDIF   
   120   CONTINUE    
     
 C...Sum of charges and momenta. 
         DO 130 j=1,6    
   130   ps(j)=plu(0,j)  
         IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999.) THEN 
           WRITE(mstu(11),2200) ps(6),(ps(j),j=1,5)  
         ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999.) THEN    
           WRITE(mstu(11),2300) ps(6),(ps(j),j=1,5)  
         ELSEIF(mlist.EQ.1) THEN 
           WRITE(mstu(11),2400) ps(6),(ps(j),j=1,5)  
         ELSE    
           WRITE(mstu(11),2500) ps(6),(ps(j),j=1,5)  
         ENDIF   
     
 C...Give simple list of KF codes defined in program.    
       ELSEIF(mlist.EQ.11) THEN  
         WRITE(mstu(11),2600)    
         DO 140 kf=1,40  
         CALL luname(kf,chap)    
         CALL luname(-kf,chan)   
         IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),2700) kf,chap    
   140   IF(chan.NE.' ') WRITE(mstu(11),2700) kf,chap,-kf,chan   
         DO 150 kfls=1,3,2   
         DO 150 kfla=1,8 
         DO 150 kflb=1,kfla-(3-kfls)/2   
         kf=1000*kfla+100*kflb+kfls  
         CALL luname(kf,chap)    
         CALL luname(-kf,chan)   
   150   WRITE(mstu(11),2700) kf,chap,-kf,chan   
         DO 170 kmul=0,5 
         kfls=3  
         IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1   
         IF(kmul.EQ.5) kfls=5    
         kflr=0  
         IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1   
         IF(kmul.EQ.4) kflr=2    
         DO 170 kflb=1,8 
         DO 160 kflc=1,kflb-1    
         kf=10000*kflr+100*kflb+10*kflc+kfls 
         CALL luname(kf,chap)    
         CALL luname(-kf,chan)   
   160   WRITE(mstu(11),2700) kf,chap,-kf,chan   
         kf=10000*kflr+110*kflb+kfls 
         CALL luname(kf,chap)    
   170   WRITE(mstu(11),2700) kf,chap    
         kf=130  
         CALL luname(kf,chap)    
         WRITE(mstu(11),2700) kf,chap    
         kf=310  
         CALL luname(kf,chap)    
         WRITE(mstu(11),2700) kf,chap    
         DO 190 kflsp=1,3    
         kfls=2+2*(kflsp/3)  
         DO 190 kfla=1,8 
         DO 190 kflb=1,kfla  
         DO 180 kflc=1,kflb  
         IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc)) GOTO 180  
         IF(kflsp.EQ.2.AND.kfla.EQ.kflc) GOTO 180    
         IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls   
         IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls   
         CALL luname(kf,chap)    
         CALL luname(-kf,chan)   
         WRITE(mstu(11),2700) kf,chap,-kf,chan   
   180   CONTINUE    
   190   CONTINUE    
     
 C...List parton/particle data table. Check whether to be listed.    
       ELSEIF(mlist.EQ.12) THEN  
         WRITE(mstu(11),2800)    
         mstj24=mstj(24) 
         mstj(24)=0  
         kfmax=20883 
         IF(mstu(2).NE.0) kfmax=mstu(2)  
         DO 220 kf=max(1,mstu(1)),kfmax  
         kc=lucomp(kf)   
         IF(kc.EQ.0) GOTO 220    
         IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) GOTO 220  
         IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10), 
      &  mod(kf/100,10)).GT.mstu(14)) GOTO 220   
     
 C...Find particle name and mass. Print information. 
         CALL luname(kf,chap)    
         IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) GOTO 220  
         CALL luname(-kf,chan)   
         pm=ulmass(kf)   
         WRITE(mstu(11),2900) kf,kc,chap,chan,kchg(kc,1),kchg(kc,2), 
      &  kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)   
     
 C...Particle decay: channel number, branching ration, matrix element,   
 C...decay products. 
         IF(kf.GT.100.AND.kc.LE.100) GOTO 220    
         DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1   
         DO 200 j=1,5    
   200   CALL luname(kfdp(idc,j),chad(j))    
   210   WRITE(mstu(11),3000) idc,mdme(idc,1),mdme(idc,2),brat(idc), 
      &  (chad(j),j=1,5) 
   220   CONTINUE    
         mstj(24)=mstj24 
     
 C...List parameter value table. 
       ELSEIF(mlist.EQ.13) THEN  
         WRITE(mstu(11),3100)    
         DO 230 i=1,200  
   230   WRITE(mstu(11),3200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)  
       ENDIF 
     
 C...Format statements for output on unit MSTU(11) (by default 6).   
  1000 FORMAT(///20x,'The Lund Monte Carlo - JETSET version ',i1,'.',i1/ 
      &20x,'**  Last date of change:  ',i2,1x,a3,1x,i4,'  **'/)  
  1100 FORMAT(///28x,'Event listing (summary)'//4x,'I  particle/jet KS', 
      &5x,'KF orig    p_x      p_y      p_z       E        m'/)  
  1200 FORMAT(///28x,'Event listing (standard)'//4x,'I  particle/jet',   
      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',   
      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)  
  1300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I  particle/j',    
      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)', 
      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73x,   
      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)    
  1400 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.3)  
  1500 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.2)  
  1600 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.1)  
  1700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i1,2i4),5f13.5)    
  1800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i9),5f13.5)    
  1900 FORMAT(66x,5(1x,f12.3))   
  2000 FORMAT(1x,78('='))    
  2100 FORMAT(1x,130('='))   
  2200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)  
  2300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)  
  2400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)  
  2500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',   
      &5f13.5)   
  2600 FORMAT(///20x,'List of KF codes in program'/) 
  2700 FORMAT(4x,i6,4x,a16,6x,i6,4x,a16) 
  2800 FORMAT(///30x,'Particle/parton data table'//5x,'KF',5x,'KC',4x,   
      &'particle',8x,'antiparticle',6x,'chg  col  anti',8x,'mass',7x,    
      &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',    
      &1x,'ME',3x,'Br.rat.',4x,'decay products') 
  2900 FORMAT(/1x,i6,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),  
      &2x,f12.5,3x,i2)   
  3000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)    
  3100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',   
      &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')  
  3200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luname()

subroutine luname	(		KF,
		character	CHAU
	)

Definition at line 4771 of file hipyset1.35.f.

     
 C...Purpose: to give the particle/parton name as a character string.    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat4/chaf(500)   
       CHARACTER chaf*8  
       SAVE /ludat4/ 
       CHARACTER chau*16 
     
 C...Initial values. Charge. Subdivide code. 
       chau=' '  
       kfa=iabs(kf)  
       kc=lucomp(kf) 
       IF(kc.EQ.0) RETURN    
       kq=luchge(kf) 
       kfla=mod(kfa/1000,10) 
       kflb=mod(kfa/100,10)  
       kflc=mod(kfa/10,10)   
       kfls=mod(kfa,10)  
       kflr=mod(kfa/10000,10)    
     
 C...Read out root name and spin for simple particle.    
       IF(kfa.LE.100.OR.(kfa.GT.100.AND.kc.GT.100)) THEN 
         chau=chaf(kc)   
         len=0   
         DO 100 lem=1,8  
   100   IF(chau(lem:lem).NE.' ') len=lem    
     
 C...Construct root name for diquark. Add on spin.   
       ELSEIF(kflc.EQ.0) THEN    
         chau(1:2)=chaf(kfla)(1:1)//chaf(kflb)(1:1)  
         IF(kfls.EQ.1) chau(3:4)='_0'    
         IF(kfls.EQ.3) chau(3:4)='_1'    
         len=4   
     
 C...Construct root name for heavy meson. Add on spin and heavy flavour. 
       ELSEIF(kfla.EQ.0) THEN    
         IF(kflb.EQ.5) chau(1:1)='B' 
         IF(kflb.EQ.6) chau(1:1)='T' 
         IF(kflb.EQ.7) chau(1:1)='L' 
         IF(kflb.EQ.8) chau(1:1)='H' 
         len=1   
         IF(kflr.EQ.0.AND.kfls.EQ.1) THEN    
         ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN    
           chau(2:2)='*' 
           len=2 
         ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN    
           chau(2:3)='_1'    
           len=3 
         ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN    
           chau(2:4)='*_0'   
           len=4 
         ELSEIF(kflr.EQ.2) THEN  
           chau(2:4)='*_1'   
           len=4 
         ELSEIF(kfls.EQ.5) THEN  
           chau(2:4)='*_2'   
           len=4 
         ENDIF   
         IF(kflc.GE.3.AND.kflr.EQ.0.AND.kfls.LE.3) THEN  
           chau(len+1:len+2)='_'//chaf(kflc)(1:1)    
           len=len+2 
         ELSEIF(kflc.GE.3) THEN  
           chau(len+1:len+1)=chaf(kflc)(1:1) 
           len=len+1 
         ENDIF   
     
 C...Construct root name and spin for heavy baryon.  
       ELSE  
         IF(kflb.LE.2.AND.kflc.LE.2) THEN    
           chau='Sigma ' 
           IF(kflc.GT.kflb) chau='Lambda'    
           IF(kfls.EQ.4) chau='Sigma*'   
           len=5 
           IF(chau(6:6).NE.' ') len=6    
         ELSEIF(kflb.LE.2.OR.kflc.LE.2) THEN 
           chau='Xi '    
           IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Xi''' 
           IF(kfls.EQ.4) chau='Xi*'  
           len=2 
           IF(chau(3:3).NE.' ') len=3    
         ELSE    
           chau='Omega ' 
           IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Omega'''  
           IF(kfls.EQ.4) chau='Omega*'   
           len=5 
           IF(chau(6:6).NE.' ') len=6    
         ENDIF   
     
 C...Add on heavy flavour content for heavy baryon.  
         chau(len+1:len+2)='_'//chaf(kfla)(1:1)  
         len=len+2   
         IF(kflb.GE.kflc.AND.kflc.GE.4) THEN 
           chau(len+1:len+2)=chaf(kflb)(1:1)//chaf(kflc)(1:1)    
           len=len+2 
         ELSEIF(kflb.GE.kflc.AND.kflb.GE.4) THEN 
           chau(len+1:len+1)=chaf(kflb)(1:1) 
           len=len+1 
         ELSEIF(kflc.GT.kflb.AND.kflb.GE.4) THEN 
           chau(len+1:len+2)=chaf(kflc)(1:1)//chaf(kflb)(1:1)    
           len=len+2 
         ELSEIF(kflc.GT.kflb.AND.kflc.GE.4) THEN 
           chau(len+1:len+1)=chaf(kflc)(1:1) 
           len=len+1 
         ENDIF   
       ENDIF 
     
 C...Add on bar sign for antiparticle (where necessary). 
       IF(kf.GT.0.OR.len.EQ.0) THEN  
       ELSEIF(kfa.GT.10.AND.kfa.LE.40.AND.kq.NE.0) THEN  
       ELSEIF(kfa.EQ.89.OR.(kfa.GE.91.AND.kfa.LE.99)) THEN   
       ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kq.NE.0) THEN 
       ELSEIF(mstu(15).LE.1) THEN    
         chau(len+1:len+1)='~'   
         len=len+1   
       ELSE  
         chau(len+1:len+3)='bar' 
         len=len+3   
       ENDIF 
     
 C...Add on charge where applicable (conventional cases skipped).    
       IF(kq.EQ.6) chau(len+1:len+2)='++'    
       IF(kq.EQ.-6) chau(len+1:len+2)='--'   
       IF(kq.EQ.3) chau(len+1:len+1)='+' 
       IF(kq.EQ.-3) chau(len+1:len+1)='-'    
       IF(kq.EQ.0.AND.(kfa.LE.22.OR.len.EQ.0)) THEN  
       ELSEIF(kq.EQ.0.AND.(kfa.GE.81.AND.kfa.LE.100)) THEN   
       ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kflb.EQ.kflc.AND. 
      &kflb.NE.1) THEN   
       ELSEIF(kq.EQ.0) THEN  
         chau(len+1:len+1)='0'   
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luonia()

subroutine luonia	(	KFL,
		ECM
	)

Definition at line 9184 of file hipyset1.35.f.

     
 C...Purpose: to generate Upsilon and toponium decays into three 
 C...gluons or two gluons and a photon.  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Printout. Check input parameters.   
       IF(mstu(12).GE.1) CALL lulist(0)  
       IF(kfl.LT.0.OR.kfl.GT.8) THEN 
         CALL luerrm(16,'(LUONIA:) called with unknown flavour code')    
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       IF(ecm.LT.parj(127)+2.02*parf(101)) THEN  
         CALL luerrm(16,'(LUONIA:) called with too small CM energy') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Initial e+e- and onium state (optional).    
       nc=0  
       IF(mstj(115).GE.2) THEN   
         nc=nc+2 
         CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)  
         k(nc-1,1)=21    
         CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)  
         k(nc,1)=21  
       ENDIF 
       kflc=iabs(kfl)    
       IF(mstj(115).GE.3.AND.kflc.GE.5) THEN 
         nc=nc+1 
         kf=110*kflc+3   
         mstu10=mstu(10) 
         mstu(10)=1  
         p(nc,5)=ecm 
         CALL lu1ent(nc,kf,ecm,0.,0.)    
         k(nc,1)=21  
         k(nc,3)=1   
         mstu(10)=mstu10 
       ENDIF 
     
 C...Choose x1 and x2 according to matrix element.   
       ntry=0    
   100 x1=rlu(0) 
       x2=rlu(0) 
       x3=2.-x1-x2   
       IF(x3.GE.1..OR.((1.-x1)/(x2*x3))**2+((1.-x2)/(x1*x3))**2+ 
      &((1.-x3)/(x1*x2))**2.LE.2.*rlu(0)) GOTO 100   
       ntry=ntry+1   
       njet=3    
       IF(mstj(101).LE.4) CALL lu3ent(nc+1,21,21,21,ecm,x1,x3)   
       IF(mstj(101).GE.5) CALL lu3ent(-(nc+1),21,21,21,ecm,x1,x3)    
     
 C...Photon-gluon-gluon events. Small system modifications. Jet origin.  
       mstu(111)=mstj(108)   
       IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1)) 
      &mstu(111)=1   
       paru(112)=parj(121)   
       IF(mstu(111).EQ.2) paru(112)=parj(122)    
       qf=0. 
       IF(kflc.NE.0) qf=kchg(kflc,1)/3.  
       rgam=7.2*qf**2*paru(101)/ulalps(ecm**2)   
       mk=0  
       ecmc=ecm  
       IF(rlu(0).GT.rgam/(1.+rgam)) THEN 
         IF(1.-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))   
      &  njet=2  
         IF(njet.EQ.2.AND.mstj(101).LE.4) CALL lu2ent(nc+1,21,21,ecm)    
         IF(njet.EQ.2.AND.mstj(101).GE.5) CALL lu2ent(-(nc+1),21,21,ecm) 
       ELSE  
         mk=1    
         ecmc=sqrt(1.-x1)*ecm    
         IF(ecmc.LT.2.*parj(127)) GOTO 100   
         k(nc+1,1)=1 
         k(nc+1,2)=22    
         k(nc+1,4)=0 
         k(nc+1,5)=0 
         IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3) 
         IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3) 
         IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2) 
         IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2) 
         njet=2  
         IF(ecmc.LT.4.*parj(127)) THEN   
           mstu10=mstu(10)   
           mstu(10)=1    
           p(nc+2,5)=ecmc    
           CALL lu1ent(nc+2,83,0.5*(x2+x3)*ecm,paru(1),0.)   
           mstu(10)=mstu10   
           njet=0    
         ENDIF   
       ENDIF 
       DO 110 ip=nc+1,n  
   110 k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)   
     
 C...Differential cross-sections. Upper limit for cross-section. 
       IF(mstj(106).EQ.1) THEN   
         sq2=sqrt(2.)    
         hf1=1.-parj(131)*parj(132)  
         hf3=parj(133)**2    
         ct13=(x1*x3-2.*x1-2.*x3+2.)/(x1*x3) 
         st13=sqrt(1.-ct13**2)   
         sigl=0.5*x3**2*((1.-x2)**2+(1.-x3)**2)*st13**2  
         sigu=(x1*(1.-x1))**2+(x2*(1.-x2))**2+(x3*(1.-x3))**2-sigl   
         sigt=0.5*sigl   
         sigi=(sigl*ct13/st13+0.5*x1*x3*(1.-x2)**2*st13)/sq2 
         sigmax=(2.*hf1+hf3)*abs(sigu)+2.*(hf1+hf3)*abs(sigl)+2.*(hf1+   
      &  2.*hf3)*abs(sigt)+2.*sq2*(hf1+2.*hf3)*abs(sigi) 
     
 C...Angular orientation of event.   
   120   chi=paru(2)*rlu(0)  
         cthe=2.*rlu(0)-1.   
         phi=paru(2)*rlu(0)  
         cchi=cos(chi)   
         schi=sin(chi)   
         c2chi=cos(2.*chi)   
         s2chi=sin(2.*chi)   
         the=acos(cthe)  
         sthe=sin(the)   
         c2phi=cos(2.*(phi-parj(134)))   
         s2phi=sin(2.*(phi-parj(134)))   
         sig=((1.+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2.*(sthe**2*hf1-  
      &  sthe**2*c2phi*hf3)*sigl+2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*    
      &  c2chi*c2phi-2.*cthe*s2chi*s2phi)*hf3)*sigt-2.*sq2*(2.*sthe*cthe*    
      &  cchi*hf1-2.*sthe*(cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi 
         IF(sig.LT.sigmax*rlu(0)) GOTO 120   
         CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)  
         CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0) 
       ENDIF 
     
 C...Generate parton shower. Rearrange along strings and check.  
       IF(mstj(101).GE.5.AND.njet.GE.2) THEN 
         CALL lushow(nc+mk+1,-njet,ecmc) 
         mstj14=mstj(14) 
         IF(mstj(105).EQ.-1) mstj(14)=0  
         IF(mstj(105).GE.0) mstu(28)=0   
         CALL luprep(0)  
         mstj(14)=mstj14 
         IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100   
       ENDIF 
     
 C...Generate fragmentation. Information for LUTABU: 
       IF(mstj(105).EQ.1) CALL luexec    
       mstu(161)=110*kflc+3  
       mstu(162)=0   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luprep()

subroutine luprep ( IP )

Definition at line 845 of file hipyset1.35.f.

     
 C...Purpose: to rearrange partons along strings, to allow small systems 
 C...to collapse into one or two particles and to check flavours.    
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       dimension dps(5),dpc(5),ue(3) 
     
 C...Rearrange parton shower product listing along strings: begin loop.  
       i1=n  
       DO 130 mqgst=1,2  
       DO 120 i=max(1,ip),n  
       IF(k(i,1).NE.3) GOTO 120  
       kc=lucomp(k(i,2)) 
       IF(kc.EQ.0) GOTO 120  
       kq=kchg(kc,2) 
       IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 120  
     
 C...Pick up loose string end.   
       kcs=4 
       IF(kq*isign(1,k(i,2)).LT.0) kcs=5 
       ia=i  
       nstp=0    
   100 nstp=nstp+1   
       IF(nstp.GT.4*n) THEN  
         CALL luerrm(14,'(LUPREP:) caught in infinite loop') 
         RETURN  
       ENDIF 
     
 C...Copy undecayed parton.  
       IF(k(ia,1).EQ.3) THEN 
         IF(i1.GE.mstu(4)-mstu(32)-5) THEN   
           CALL luerrm(11,'(LUPREP:) no more memory left in LUJETS') 
           RETURN    
         ENDIF   
         i1=i1+1 
         k(i1,1)=2   
         IF(nstp.GE.2.AND.iabs(k(ia,2)).NE.21) k(i1,1)=1 
         k(i1,2)=k(ia,2) 
         k(i1,3)=ia  
         k(i1,4)=0   
         k(i1,5)=0   
         DO 110 j=1,5    
         p(i1,j)=p(ia,j) 
   110   v(i1,j)=v(ia,j) 
         k(ia,1)=k(ia,1)+10  
         IF(k(i1,1).EQ.1) GOTO 120   
       ENDIF 
     
 C...Go to next parton in colour space.  
       ib=ia 
       IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5)).   
      &ne.0) THEN    
         ia=mod(k(ib,kcs),mstu(5))   
         k(ib,kcs)=k(ib,kcs)+mstu(5)**2  
         mrev=0  
       ELSE  
         IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),mstu(5)). 
      &  eq.0) kcs=9-kcs 
         ia=mod(k(ib,kcs)/mstu(5),mstu(5))   
         k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2    
         mrev=1  
       ENDIF 
       IF(ia.LE.0.OR.ia.GT.n) THEN   
         CALL luerrm(12,'(LUPREP:) colour rearrangement failed') 
         RETURN  
       ENDIF 
       IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5), 
      &mstu(5)).EQ.ib) THEN  
         IF(mrev.EQ.1) kcs=9-kcs 
         IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs  
         k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2    
       ELSE  
         IF(mrev.EQ.0) kcs=9-kcs 
         IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs  
         k(ia,kcs)=k(ia,kcs)+mstu(5)**2  
       ENDIF 
       IF(ia.NE.i) GOTO 100  
       k(i1,1)=1 
   120 CONTINUE  
   130 CONTINUE  
       n=i1  
     
 C...Find lowest-mass colour singlet jet system, OK if above threshold.  
       IF(mstj(14).LE.0) GOTO 320    
       ns=n  
   140 nsin=n-ns 
       pdm=1.+parj(32)   
       ic=0  
       DO 190 i=max(1,ip),ns 
       IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN  
       ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN  
         nsin=nsin+1 
         ic=i    
         DO 150 j=1,4    
   150   dps(j)=p(i,j)   
         mstj(93)=1  
         dps(5)=ulmass(k(i,2))   
       ELSEIF(k(i,1).EQ.2) THEN  
         DO 160 j=1,4    
   160   dps(j)=dps(j)+p(i,j)    
       ELSEIF(ic.NE.0.AND.kchg(lucomp(k(i,2)),2).NE.0) THEN  
         DO 170 j=1,4    
   170   dps(j)=dps(j)+p(i,j)    
         mstj(93)=1  
         dps(5)=dps(5)+ulmass(k(i,2))    
         pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-dps(5)    
         IF(pd.LT.pdm) THEN  
           pdm=pd    
           DO 180 j=1,5  
   180     dpc(j)=dps(j) 
           ic1=ic    
           ic2=i 
         ENDIF   
         ic=0    
       ELSE  
         nsin=nsin+1 
       ENDIF 
   190 CONTINUE  
       IF(pdm.GE.parj(32)) GOTO 320  
     
 C...Fill small-mass system as cluster.  
       nsav=n    
       pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))   
       k(n+1,1)=11   
       k(n+1,2)=91   
       k(n+1,3)=ic1  
       k(n+1,4)=n+2  
       k(n+1,5)=n+3  
       p(n+1,1)=dpc(1)   
       p(n+1,2)=dpc(2)   
       p(n+1,3)=dpc(3)   
       p(n+1,4)=dpc(4)   
       p(n+1,5)=pecm 
     
 C...Form two particles from flavours of lowest-mass system, if feasible.    
       k(n+2,1)=1    
       k(n+3,1)=1    
       IF(mstu(16).NE.2) THEN    
         k(n+2,3)=n+1    
         k(n+3,3)=n+1    
       ELSE  
         k(n+2,3)=ic1    
         k(n+3,3)=ic2    
       ENDIF 
       k(n+2,4)=0    
       k(n+3,4)=0    
       k(n+2,5)=0    
       k(n+3,5)=0    
       IF(iabs(k(ic1,2)).NE.21) THEN 
         kc1=lucomp(k(ic1,2))    
         kc2=lucomp(k(ic2,2))    
         IF(kc1.EQ.0.OR.kc2.EQ.0) GOTO 320   
         kq1=kchg(kc1,2)*isign(1,k(ic1,2))   
         kq2=kchg(kc2,2)*isign(1,k(ic2,2))   
         IF(kq1+kq2.NE.0) GOTO 320   
   200   CALL lukfdi(k(ic1,2),0,kfln,k(n+2,2))   
         CALL lukfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2)) 
         IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 200 
       ELSE  
         IF(iabs(k(ic2,2)).NE.21) GOTO 320   
   210   CALL lukfdi(1+int((2.+parj(2))*rlu(0)),0,kfln,kfdmp)    
         CALL lukfdi(kfln,0,kflm,k(n+2,2))   
         CALL lukfdi(-kfln,-kflm,kfldmp,k(n+3,2))    
         IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 210 
       ENDIF 
       p(n+2,5)=ulmass(k(n+2,2)) 
       p(n+3,5)=ulmass(k(n+3,2)) 
       IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) GOTO 320 
       IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) GOTO 260   
     
 C...Perform two-particle decay of jet system, if possible.  
       IF(pecm.GE.0.02*dpc(4)) THEN  
         pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-  
      &  (p(n+2,5)-p(n+3,5))**2))/(2.*pecm)  
         ue(3)=2.*rlu(0)-1.  
         phi=paru(2)*rlu(0)  
         ue(1)=sqrt(1.-ue(3)**2)*cos(phi)    
         ue(2)=sqrt(1.-ue(3)**2)*sin(phi)    
         DO 220 j=1,3    
         p(n+2,j)=pa*ue(j)   
   220   p(n+3,j)=-pa*ue(j)  
         p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)    
         p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)    
         CALL ludbrb(n+2,n+3,0.,0.,dpc(1)/dpc(4),dpc(2)/dpc(4),  
      &  dpc(3)/dpc(4))  
       ELSE  
         np=0    
         DO 230 i=ic1,ic2    
   230   IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1  
         ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-   
      &  p(ic1,3)*p(ic2,3)   
         IF(np.GE.3.OR.ha.LE.1.25*p(ic1,5)*p(ic2,5)) GOTO 260    
         hd1=0.5*(p(n+2,5)**2-p(ic1,5)**2)   
         hd2=0.5*(p(n+3,5)**2-p(ic2,5)**2)   
         hr=sqrt(max(0.,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/    
      &  (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1. 
         hc=p(ic1,5)**2+2.*ha+p(ic2,5)**2    
         hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc    
         hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc    
         DO 240 j=1,4    
         p(n+2,j)=(1.+hk1)*p(ic1,j)-hk2*p(ic2,j) 
   240   p(n+3,j)=(1.+hk2)*p(ic2,j)-hk1*p(ic1,j) 
       ENDIF 
       DO 250 j=1,4  
       v(n+1,j)=v(ic1,j) 
       v(n+2,j)=v(ic1,j) 
   250 v(n+3,j)=v(ic2,j) 
       v(n+1,5)=0.   
       v(n+2,5)=0.   
       v(n+3,5)=0.   
       n=n+3 
       GOTO 300  
     
 C...Else form one particle from the flavours available, if possible.    
   260 k(n+1,5)=n+2  
       IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN  
         GOTO 320    
       ELSEIF(iabs(k(ic1,2)).NE.21) THEN 
         CALL lukfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))  
       ELSE  
         kfln=1+int((2.+parj(2))*rlu(0)) 
         CALL lukfdi(kfln,-kfln,kfldmp,k(n+2,2)) 
       ENDIF 
       IF(k(n+2,2).EQ.0) GOTO 260    
       p(n+2,5)=ulmass(k(n+2,2)) 
     
 C...Find parton/particle which combines to largest extra mass.  
       ir=0  
       ha=0. 
       DO 280 mcomb=1,3  
       IF(ir.NE.0) GOTO 280  
       DO 270 i=max(1,ip),n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2. 
      &and.k(i,1).GE.1.AND.k(i,1).LE.2)) GOTO 270    
       IF(mcomb.EQ.1) kci=lucomp(k(i,2)) 
       IF(mcomb.EQ.1.AND.kci.EQ.0) GOTO 270  
       IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) GOTO 270  
       IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100) 
      &GOTO 270  
       hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)   
       IF(hcr.GT.ha) THEN    
         ir=i    
         ha=hcr  
       ENDIF 
   270 CONTINUE  
   280 CONTINUE  
     
 C...Shuffle energy and momentum to put new particle on mass shell.  
       hb=pecm**2+ha 
       hc=p(n+2,5)**2+ha 
       hd=p(ir,5)**2+ha
 C******************CHANGES BY HIJING************  
       hk2=0.0
       IF(ha**2-(pecm*p(ir,5))**2.EQ.0.0.OR.hb+hd.EQ.0.0) GO TO 285
 C******************
       hk2=0.5*(hb*sqrt(((hb+hc)**2-4.*(hb+hd)*p(n+2,5)**2)/ 
      &(ha**2-(pecm*p(ir,5))**2))-(hb+hc))/(hb+hd)   
   285 hk1=(0.5*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb 
       DO 290 j=1,4  
       p(n+2,j)=(1.+hk1)*dpc(j)-hk2*p(ir,j)  
       p(ir,j)=(1.+hk2)*p(ir,j)-hk1*dpc(j)   
       v(n+1,j)=v(ic1,j) 
   290 v(n+2,j)=v(ic1,j) 
       v(n+1,5)=0.   
       v(n+2,5)=0.   
       n=n+2 
     
 C...Mark collapsed system and store daughter pointers. Iterate. 
   300 DO 310 i=ic1,ic2  
       IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(lucomp(k(i,2)),2).NE.0)  
      &THEN  
         k(i,1)=k(i,1)+10    
         IF(mstu(16).NE.2) THEN  
           k(i,4)=nsav+1 
           k(i,5)=nsav+1 
         ELSE    
           k(i,4)=nsav+2 
           k(i,5)=n  
         ENDIF   
       ENDIF 
   310 CONTINUE  
       IF(n.LT.mstu(4)-mstu(32)-5) GOTO 140  
     
 C...Check flavours and invariant masses in parton systems.  
   320 np=0  
       kfn=0 
       kqs=0 
       DO 330 j=1,5  
   330 dps(j)=0. 
       DO 360 i=max(1,ip),n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 360  
       kc=lucomp(k(i,2)) 
       IF(kc.EQ.0) GOTO 360  
       kq=kchg(kc,2)*isign(1,k(i,2)) 
       IF(kq.EQ.0) GOTO 360  
       np=np+1   
       IF(kq.NE.2) THEN  
         kfn=kfn+1   
         kqs=kqs+kq  
         mstj(93)=1  
         dps(5)=dps(5)+ulmass(k(i,2))    
       ENDIF 
       DO 340 j=1,4  
   340 dps(j)=dps(j)+p(i,j)  
       IF(k(i,1).EQ.1) THEN  
         IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL 
      &  luerrm(2,'(LUPREP:) unphysical flavour combination')    
         IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.  
      &  (0.9*parj(32)+dps(5))**2) CALL luerrm(3,    
      &  '(LUPREP:) too small mass in jet system')   
         np=0    
         kfn=0   
         kqs=0   
         DO 350 j=1,5    
   350   dps(j)=0.   
       ENDIF 
   360 CONTINUE  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luptdi()

subroutine luptdi	(	KFL,
		PX,
		PY
	)

Definition at line 3574 of file hipyset1.35.f.

     
 C...Purpose: to generate transverse momentum according to a Gaussian.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
     
 C...Generate p_T and azimuthal angle, gives p_x and p_y.    
       kfla=iabs(kfl)    
       pt=parj(21)*sqrt(-log(max(1e-10,rlu(0)))) 
       IF(mstj(91).EQ.1) pt=parj(22)*pt  
       IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0. 
       phi=paru(2)*rlu(0)    
       px=pt*cos(phi)    
       py=pt*sin(phi)    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luradk()

subroutine luradk	(	ECM,
		MK,
		PAK,
		THEK,
		PHIK,
		ALPK
	)

Definition at line 8389 of file hipyset1.35.f.

     
 C...Purpose: to generate initial state photon radiation.    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
     
 C...Function: cumulative hard photon spectrum in QFD case.  
       fxk(xx)=2.*log(xx)+parj(161)*log(1.-xx)+parj(162)*xx+ 
      &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)    
     
 C...Determine whether radiative photon or not.  
       mk=0  
       pak=0.    
       IF(parj(160).LT.rlu(0)) RETURN    
       mk=1  
     
 C...Photon energy range. Find photon momentum in QED case.  
       xkl=parj(135) 
       xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)   
       IF(mstj(102).LE.1) THEN   
   100   xk=1./(1.+(1./xkl-1.)*((1./xku-1.)/(1./xkl-1.))**rlu(0))    
         IF(1.+(1.-xk)**2.LT.2.*rlu(0)) GOTO 100 
     
 C...Ditto in QFD case, by numerical inversion of integrated spectrum.   
       ELSE  
         szm=1.-(parj(123)/ecm)**2   
         szw=parj(123)*parj(124)/ecm**2  
         fxkl=fxk(xkl)   
         fxku=fxk(xku)   
         fxkd=1e-4*(fxku-fxkl)   
         fxkr=fxkl+rlu(0)*(fxku-fxkl)    
         nxk=0   
   110   nxk=nxk+1   
         xk=0.5*(xkl+xku)    
         fxkv=fxk(xk)    
         IF(fxkv.GT.fxkr) THEN   
           xku=xk    
           fxku=fxkv 
         ELSE    
           xkl=xk    
           fxkl=fxkv 
         ENDIF   
         IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) GOTO 110    
         xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)    
       ENDIF 
       pak=0.5*ecm*xk    
     
 C...Photon polar and azimuthal angle.   
       pme=2.*(ulmass(11)/ecm)**2    
   120 cthm=pme*(2./pme)**rlu(0) 
       IF(1.-(xk**2*cthm*(1.-0.5*cthm)+2.*(1.-xk)*pme/max(pme,   
      &cthm*(1.-0.5*cthm)))/(1.+(1.-xk)**2).LT.rlu(0)) GOTO 120  
       cthe=1.-cthm  
       IF(rlu(0).GT.0.5) cthe=-cthe  
       sthe=sqrt(max(0.,(cthm-pme)*(2.-cthm)))   
       thek=ulangl(cthe,sthe)    
       phik=paru(2)*rlu(0)   
     
 C...Rotation angle for hadronic system. 
       sgn=1.    
       IF(0.5*(2.-xk*(1.-cthe))**2/((2.-xk)**2+(xk*cthe)**2).GT. 
      &rlu(0)) sgn=-1.   
       alpk=asin(sgn*sthe*(xk-sgn*(2.*sqrt(1.-xk)-2.+xk)*cthe)/  
      &(2.-xk*(1.-sgn*cthe)))    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lurobo()

subroutine lurobo	(	THE,
		PHI,
		BEX,
		BEY,
		BEZ
	)

Definition at line 5317 of file hipyset1.35.f.

     
 C...Purpose: to perform rotations and boosts.   
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)    
     
 C...Find range of rotation/boost. Convert boost to double precision.    
       imin=1    
       IF(mstu(1).GT.0) imin=mstu(1) 
       imax=n    
       IF(mstu(2).GT.0) imax=mstu(2) 
       dbx=bex   
       dby=bey   
       dbz=bez   
       GOTO 100  
     
 C...Entry for specific range and double precision boost.    
       entry ludbrb(imi,ima,the,phi,dbex,dbey,dbez)  
       imin=imi  
       IF(imin.LE.0) imin=1  
       imax=ima  
       IF(imax.LE.0) imax=n  
       dbx=dbex  
       dby=dbey  
       dbz=dbez  
     
 C...Check range of rotation/boost.  
   100 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN   
         CALL luerrm(11,'(LUROBO:) range outside LUJETS memory') 
         RETURN  
       ENDIF 
     
 C...Rotate, typically from z axis to direction (theta,phi). 
       IF(the**2+phi**2.GT.1e-20) THEN   
         rot(1,1)=cos(the)*cos(phi)  
         rot(1,2)=-sin(phi)  
         rot(1,3)=sin(the)*cos(phi)  
         rot(2,1)=cos(the)*sin(phi)  
         rot(2,2)=cos(phi)   
         rot(2,3)=sin(the)*sin(phi)  
         rot(3,1)=-sin(the)  
         rot(3,2)=0. 
         rot(3,3)=cos(the)   
         DO 130 i=imin,imax  
         IF(k(i,1).LE.0) GOTO 130    
         DO 110 j=1,3    
         pr(j)=p(i,j)    
   110   vr(j)=v(i,j)    
         DO 120 j=1,3    
         p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3) 
   120   v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3) 
   130   CONTINUE    
       ENDIF 
     
 C...Boost, typically from rest to momentum/energy=beta. 
       IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN    
         db=sqrt(dbx**2+dby**2+dbz**2)   
         IF(db.GT.0.99999999d0) THEN 
 C...Rescale boost vector if too close to unity. 
           CALL luerrm(3,'(LUROBO:) boost vector too large') 
           dbx=dbx*(0.99999999d0/db) 
           dby=dby*(0.99999999d0/db) 
           dbz=dbz*(0.99999999d0/db) 
           db=0.99999999d0   
         ENDIF   
         dga=1d0/sqrt(1d0-db**2) 
         DO 150 i=imin,imax  
         IF(k(i,1).LE.0) GOTO 150    
         DO 140 j=1,4    
         dp(j)=p(i,j)    
   140   dv(j)=v(i,j)    
         dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)   
         dgabp=dga*(dga*dbp/(1d0+dga)+dp(4)) 
         p(i,1)=dp(1)+dgabp*dbx  
         p(i,2)=dp(2)+dgabp*dby  
         p(i,3)=dp(3)+dgabp*dbz  
         p(i,4)=dga*(dp(4)+dbp)  
         dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)   
         dgabv=dga*(dga*dbv/(1d0+dga)+dv(4)) 
         v(i,1)=dv(1)+dgabv*dbx  
         v(i,2)=dv(2)+dgabv*dby  
         v(i,3)=dv(3)+dgabv*dbz  
         v(i,4)=dga*(dv(4)+dbv)  
   150   CONTINUE    
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lushow()

subroutine lushow	(	IP1,
		IP2,
		QMAX
	)

Definition at line 3701 of file hipyset1.35.f.

     
 C...Purpose: to generate timelike parton showers from given partons.    
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension pmth(5,40),ps(5),pma(4),pmsd(4),iep(4),ipa(4),  
      &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4)   
     
 C...Initialization of cutoff masses etc.    
       IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.  
      &qmax.LE.min(parj(82),parj(83)).OR.mstj(41).GE.3) RETURN   
       pmth(1,21)=ulmass(21) 
       pmth(2,21)=sqrt(pmth(1,21)**2+0.25*parj(82)**2)   
       pmth(3,21)=2.*pmth(2,21)  
       pmth(4,21)=pmth(3,21) 
       pmth(5,21)=pmth(3,21) 
       pmth(1,22)=ulmass(22) 
       pmth(2,22)=sqrt(pmth(1,22)**2+0.25*parj(83)**2)   
       pmth(3,22)=2.*pmth(2,22)  
       pmth(4,22)=pmth(3,22) 
       pmth(5,22)=pmth(3,22) 
       pmqth1=parj(82)   
       IF(mstj(41).EQ.2) pmqth1=min(parj(82),parj(83))   
       pmqth2=pmth(2,21) 
       IF(mstj(41).EQ.2) pmqth2=min(pmth(2,21),pmth(2,22))   
       DO 100 if=1,8 
       pmth(1,if)=ulmass(if) 
       pmth(2,if)=sqrt(pmth(1,if)**2+0.25*pmqth1**2) 
       pmth(3,if)=pmth(2,if)+pmqth2  
       pmth(4,if)=sqrt(pmth(1,if)**2+0.25*parj(82)**2)+pmth(2,21)    
   100 pmth(5,if)=sqrt(pmth(1,if)**2+0.25*parj(83)**2)+pmth(2,22)    
       pt2min=max(0.5*parj(82),1.1*parj(81))**2  
       alams=parj(81)**2 
       alfm=log(pt2min/alams)    
     
 C...Store positions of shower initiating partons.   
       m3jc=0    
       IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN 
         npa=1   
         ipa(1)=ip1  
       ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-   
      &mstu(32))) THEN   
         npa=2   
         ipa(1)=ip1  
         ipa(2)=ip2  
       ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0.  
      &and.ip2.GE.-3) THEN   
         npa=iabs(ip2)   
         DO 110 i=1,npa  
   110   ipa(i)=ip1+i-1  
       ELSE  
         CALL luerrm(12, 
      &  '(LUSHOW:) failed to reconstruct showering system') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Check on phase space available for emission.    
       irej=0    
       DO 120 j=1,5  
   120 ps(j)=0.  
       pm=0. 
       DO 130 i=1,npa    
       kfla(i)=iabs(k(ipa(i),2)) 
       pma(i)=p(ipa(i),5)    
       IF(kfla(i).NE.0.AND.(kfla(i).LE.8.OR.kfla(i).EQ.21))  
      &pma(i)=pmth(3,kfla(i))    
       pm=pm+pma(i)  
       IF(kfla(i).EQ.0.OR.(kfla(i).GT.8.AND.kfla(i).NE.21).OR.   
      &pma(i).GT.qmax) irej=irej+1   
       DO 130 j=1,4  
   130 ps(j)=ps(j)+p(ipa(i),j)   
       IF(irej.EQ.npa) RETURN    
       ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))   
       IF(npa.EQ.1) ps(5)=ps(4)  
       IF(ps(5).LE.pm+pmqth1) RETURN 
       IF(npa.EQ.2.AND.mstj(47).GE.1) THEN   
         IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.  
      &  kfla(2).LE.8) m3jc=1    
         IF(mstj(47).GE.2) m3jc=1    
       ENDIF 
     
 C...Define imagined single initiator of shower for parton system.   
       ns=n  
       IF(n.GT.mstu(4)-mstu(32)-5) THEN  
         CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       IF(npa.GE.2) THEN 
         k(n+1,1)=11 
         k(n+1,2)=21 
         k(n+1,3)=0  
         k(n+1,4)=0  
         k(n+1,5)=0  
         p(n+1,1)=0. 
         p(n+1,2)=0. 
         p(n+1,3)=0. 
         p(n+1,4)=ps(5)  
         p(n+1,5)=ps(5)  
         v(n+1,5)=ps(5)**2   
         n=n+1   
       ENDIF 
     
 C...Loop over partons that may branch.  
       nep=npa   
       im=ns 
       IF(npa.EQ.1) im=ns-1  
   140 im=im+1   
       IF(n.GT.ns) THEN  
         IF(im.GT.n) GOTO 380    
         kflm=iabs(k(im,2))  
         IF(kflm.EQ.0.OR.(kflm.GT.8.AND.kflm.NE.21)) GOTO 140    
         IF(p(im,5).LT.pmth(2,kflm)) GOTO 140    
         igm=k(im,3) 
       ELSE  
         igm=-1  
       ENDIF 
       IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN  
         CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Position of aunt (sister to branching parton).  
 C...Origin and flavour of daughters.    
       iau=0 
       IF(igm.GT.0) THEN 
         IF(k(im-1,3).EQ.igm) iau=im-1   
         IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1 
       ENDIF 
       IF(igm.GE.0) THEN 
         k(im,4)=n+1 
         DO 150 i=1,nep  
   150   k(n+i,3)=im 
       ELSE  
         k(n+1,3)=ipa(1) 
       ENDIF 
       IF(igm.LE.0) THEN 
         DO 160 i=1,nep  
   160   k(n+i,2)=k(ipa(i),2)    
       ELSEIF(kflm.NE.21) THEN   
         k(n+1,2)=k(im,2)    
         k(n+2,2)=k(im,5)    
       ELSEIF(k(im,5).EQ.21) THEN    
         k(n+1,2)=21 
         k(n+2,2)=21 
       ELSE  
         k(n+1,2)=k(im,5)    
         k(n+2,2)=-k(im,5)   
       ENDIF 
     
 C...Reset flags on daughers and tries made. 
       DO 170 ip=1,nep   
       k(n+ip,1)=3   
       k(n+ip,4)=0   
       k(n+ip,5)=0   
       kfld(ip)=iabs(k(n+ip,2))  
       itry(ip)=0    
       isl(ip)=0 
       isi(ip)=0 
   170 IF(kfld(ip).GT.0.AND.(kfld(ip).LE.8.OR.kfld(ip).EQ.21)) isi(ip)=1 
       islm=0    
     
 C...Maximum virtuality of daughters.    
       IF(igm.LE.0) THEN 
         DO 180 i=1,npa  
         IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)- 
      &  ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)  
         p(n+i,5)=min(qmax,ps(5))    
         IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))    
   180   IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)    
       ELSE  
         IF(mstj(43).LE.2) pem=v(im,2)   
         IF(mstj(43).GE.3) pem=p(im,4)   
         p(n+1,5)=min(p(im,5),v(im,1)*pem)   
         p(n+2,5)=min(p(im,5),(1.-v(im,1))*pem)  
         IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)  
       ENDIF 
       DO 190 i=1,nep    
       pmsd(i)=p(n+i,5)  
       IF(isi(i).EQ.1) THEN  
         IF(p(n+i,5).LE.pmth(3,kfld(i))) p(n+i,5)=pmth(1,kfld(i))    
       ENDIF 
   190 v(n+i,5)=p(n+i,5)**2  
     
 C...Choose one of the daughters for evolution.  
   200 inum=0    
       IF(nep.EQ.1) inum=1   
       DO 210 i=1,nep    
   210 IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i  
       DO 220 i=1,nep    
       IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN   
         IF(p(n+i,5).GE.pmth(2,kfld(i))) inum=i  
       ENDIF 
   220 CONTINUE  
       IF(inum.EQ.0) THEN    
         rmax=0. 
         DO 230 i=1,nep  
         IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN  
           rpm=p(n+i,5)/pmsd(i)  
           IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,kfld(i))) THEN  
             rmax=rpm    
             inum=i  
           ENDIF 
         ENDIF   
   230   CONTINUE    
       ENDIF 
     
 C...Store information on choice of evolving daughter.   
       inum=max(1,inum)  
       iep(1)=n+inum 
       DO 240 i=2,nep    
       iep(i)=iep(i-1)+1 
   240 IF(iep(i).GT.n+nep) iep(i)=n+1    
       DO 250 i=1,nep    
   250 kfl(i)=iabs(k(iep(i),2))  
       itry(inum)=itry(inum)+1   
       IF(itry(inum).GT.200) THEN    
         CALL luerrm(14,'(LUSHOW:) caught in infinite loop') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       z=0.5 
       IF(kfl(1).EQ.0.OR.(kfl(1).GT.8.AND.kfl(1).NE.21)) GOTO 300    
       IF(p(iep(1),5).LT.pmth(2,kfl(1))) GOTO 300    
     
 C...Calculate allowed z range.  
       IF(nep.EQ.1) THEN 
         pmed=ps(4)  
       ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN    
         pmed=p(im,5)    
       ELSE  
         IF(inum.EQ.1) pmed=v(im,1)*pem  
         IF(inum.EQ.2) pmed=(1.-v(im,1))*pem 
       ENDIF 
       IF(mod(mstj(43),2).EQ.1) THEN 
         zc=pmth(2,21)/pmed  
         zce=pmth(2,22)/pmed 
       ELSE  
         zc=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,21)/pmed)**2)))    
         IF(zc.LT.1e-4) zc=(pmth(2,21)/pmed)**2  
         zce=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,22)/pmed)**2)))   
         IF(zce.LT.1e-4) zce=(pmth(2,22)/pmed)**2    
       ENDIF 
       zc=min(zc,0.491)  
       zce=min(zce,0.491)    
       IF((mstj(41).EQ.1.AND.zc.GT.0.49).OR.(mstj(41).EQ.2.AND.  
      &min(zc,zce).GT.0.49)) THEN    
         p(iep(1),5)=pmth(1,kfl(1))  
         v(iep(1),5)=p(iep(1),5)**2  
         GOTO 300    
       ENDIF 
     
 C...Integral of Altarelli-Parisi z kernel for QCD.  
       IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN   
         fbr=6.*log((1.-zc)/zc)+mstj(45)*(0.5-zc)    
       ELSEIF(mstj(49).EQ.0) THEN    
         fbr=(8./3.)*log((1.-zc)/zc) 
     
 C...Integral of Altarelli-Parisi z kernel for scalar gluon. 
       ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN   
         fbr=(parj(87)+mstj(45)*parj(88))*(1.-2.*zc) 
       ELSEIF(mstj(49).EQ.1) THEN    
         fbr=(1.-2.*zc)/3.   
         IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4.*fbr   
     
 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. 
       ELSEIF(kfl(1).EQ.21) THEN 
         fbr=6.*mstj(45)*(0.5-zc)    
       ELSE  
         fbr=2.*log((1.-zc)/zc)  
       ENDIF 
     
 C...Integral of Altarelli-Parisi kernel for photon emission.    
       IF(mstj(41).EQ.2.AND.kfl(1).GE.1.AND.kfl(1).LE.8) 
      &fbre=(kchg(kfl(1),1)/3.)**2*2.*log((1.-zce)/zce)  
     
 C...Inner veto algorithm starts. Find maximum mass for evolution.   
   260 pms=v(iep(1),5)   
       IF(igm.GE.0) THEN 
         pm2=0.  
         DO 270 i=2,nep  
         pm=p(iep(i),5)  
         IF(kfl(i).GT.0.AND.(kfl(i).LE.8.OR.kfl(i).EQ.21)) pm=   
      &  pmth(2,kfl(i))  
   270   pm2=pm2+pm  
         pms=min(pms,(p(im,5)-pm2)**2)   
       ENDIF 
     
 C...Select mass for daughter in QCD evolution.  
       b0=27./6. 
       DO 280 if=4,mstj(45)  
   280 IF(pms.GT.4.*pmth(2,if)**2) b0=(33.-2.*if)/6. 
       IF(mstj(44).LE.0) THEN    
         pmsqcd=pms*exp(max(-100.,log(rlu(0))*paru(2)/(paru(111)*fbr)))  
       ELSEIF(mstj(44).EQ.1) THEN    
         pmsqcd=4.*alams*(0.25*pms/alams)**(rlu(0)**(b0/fbr))    
       ELSE  
         pmsqcd=pms*rlu(0)**(alfm*b0/fbr)    
       ENDIF 
       IF(zc.GT.0.49.OR.pmsqcd.LE.pmth(4,kfl(1))**2) pmsqcd= 
      &pmth(2,kfl(1))**2 
       v(iep(1),5)=pmsqcd    
       mce=1 
     
 C...Select mass for daughter in QED evolution.  
       IF(mstj(41).EQ.2.AND.kfl(1).GE.1.AND.kfl(1).LE.8) THEN    
         pmsqed=pms*exp(max(-100.,log(rlu(0))*paru(2)/(paru(101)*fbre))) 
         IF(zce.GT.0.49.OR.pmsqed.LE.pmth(5,kfl(1))**2) pmsqed=  
      &  pmth(2,kfl(1))**2   
         IF(pmsqed.GT.pmsqcd) THEN   
           v(iep(1),5)=pmsqed    
           mce=2 
         ENDIF   
       ENDIF 
     
 C...Check whether daughter mass below cutoff.   
       p(iep(1),5)=sqrt(v(iep(1),5)) 
       IF(p(iep(1),5).LE.pmth(3,kfl(1))) THEN    
         p(iep(1),5)=pmth(1,kfl(1))  
         v(iep(1),5)=p(iep(1),5)**2  
         GOTO 300    
       ENDIF 
     
 C...Select z value of branching: q -> qgamma.   
       IF(mce.EQ.2) THEN 
         z=1.-(1.-zce)*(zce/(1.-zce))**rlu(0)    
         IF(1.+z**2.LT.2.*rlu(0)) GOTO 260   
         k(iep(1),5)=22  
     
 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.  
       ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN   
         z=1.-(1.-zc)*(zc/(1.-zc))**rlu(0)   
         IF(1.+z**2.LT.2.*rlu(0)) GOTO 260   
         k(iep(1),5)=21  
       ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5-zc).LT.rlu(0)*fbr) THEN    
         z=(1.-zc)*(zc/(1.-zc))**rlu(0)  
         IF(rlu(0).GT.0.5) z=1.-z    
         IF((1.-z*(1.-z))**2.LT.rlu(0)) GOTO 260 
         k(iep(1),5)=21  
       ELSEIF(mstj(49).NE.1) THEN    
         z=zc+(1.-2.*zc)*rlu(0)  
         IF(z**2+(1.-z)**2.LT.rlu(0)) GOTO 260   
         kflb=1+int(mstj(45)*rlu(0)) 
         pmq=4.*pmth(2,kflb)**2/v(iep(1),5)  
         IF(pmq.GE.1.) GOTO 260  
         pmq0=4.*pmth(2,21)**2/v(iep(1),5)   
         IF(mod(mstj(43),2).EQ.0.AND.(1.+0.5*pmq)*sqrt(1.-pmq).LT.   
      &  rlu(0)*(1.+0.5*pmq0)*sqrt(1.-pmq0)) GOTO 260    
         k(iep(1),5)=kflb    
     
 C...Ditto for scalar gluon model.   
       ELSEIF(kfl(1).NE.21) THEN 
         z=1.-sqrt(zc**2+rlu(0)*(1.-2.*zc))  
         k(iep(1),5)=21  
       ELSEIF(rlu(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN  
         z=zc+(1.-2.*zc)*rlu(0)  
         k(iep(1),5)=21  
       ELSE  
         z=zc+(1.-2.*zc)*rlu(0)  
         kflb=1+int(mstj(45)*rlu(0)) 
         pmq=4.*pmth(2,kflb)**2/v(iep(1),5)  
         IF(pmq.GE.1.) GOTO 260  
         k(iep(1),5)=kflb    
       ENDIF 
       IF(mce.EQ.1.AND.mstj(44).GE.2) THEN   
         IF(z*(1.-z)*v(iep(1),5).LT.pt2min) GOTO 260 
         IF(alfm/log(v(iep(1),5)*z*(1.-z)/alams).LT.rlu(0)) GOTO 260 
       ENDIF 
     
 C...Check if z consistent with chosen m.    
       IF(kfl(1).EQ.21) THEN 
         kflgd1=iabs(k(iep(1),5))    
         kflgd2=kflgd1   
       ELSE  
         kflgd1=kfl(1)   
         kflgd2=iabs(k(iep(1),5))    
       ENDIF 
       IF(nep.EQ.1) THEN 
         ped=ps(4)   
       ELSEIF(nep.GE.3) THEN 
         ped=p(iep(1),4) 
       ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN    
         ped=0.5*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)    
       ELSE  
         IF(iep(1).EQ.n+1) ped=v(im,1)*pem   
         IF(iep(1).EQ.n+2) ped=(1.-v(im,1))*pem  
       ENDIF 
       IF(mod(mstj(43),2).EQ.1) THEN 
         pmqth3=0.5*parj(82) 
         IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)    
         pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(iep(1),5)  
         pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)  
         zd=sqrt(max(0.,(1.-v(iep(1),5)/ped**2)*((1.-pmq1-pmq2)**2-  
      &  4.*pmq1*pmq2))) 
         zh=1.+pmq1-pmq2 
       ELSE  
         zd=sqrt(max(0.,1.-v(iep(1),5)/ped**2))  
         zh=1.   
       ENDIF 
       zl=0.5*(zh-zd)    
       zu=0.5*(zh+zd)    
       IF(z.LT.zl.OR.z.GT.zu) GOTO 260   
       IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1.-zl)/max(1e-20,zl* 
      &(1.-zu))) 
       IF(kfl(1).NE.21) v(iep(1),3)=log((1.-zl)/max(1e-10,1.-zu))    
     
 C...Three-jet matrix element correction.    
       IF(igm.EQ.0.AND.m3jc.EQ.1) THEN   
         x1=z*(1.+v(iep(1),5)/v(ns+1,5)) 
         x2=1.-v(iep(1),5)/v(ns+1,5) 
         x3=(1.-x1)+(1.-x2)  
         IF(mce.EQ.2) THEN   
           ki1=k(ipa(inum),2)    
           ki2=k(ipa(3-inum),2)  
           qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3. 
           qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3. 
           wshow=qf1**2*(1.-x1)/x3*(1.+(x1/(2.-x2))**2)+ 
      &    qf2**2*(1.-x2)/x3*(1.+(x2/(2.-x1))**2)    
           wme=(qf1*(1.-x1)/x3-qf2*(1.-x2)/x3)**2*(x1**2+x2**2)  
         ELSEIF(mstj(49).NE.1) THEN  
           wshow=1.+(1.-x1)/x3*(x1/(2.-x2))**2+  
      &    (1.-x2)/x3*(x2/(2.-x1))**2    
           wme=x1**2+x2**2   
         ELSE    
           wshow=4.*x3*((1.-x1)/(2.-x2)**2+(1.-x2)/(2.-x1)**2)   
           wme=x3**2 
         ENDIF   
         IF(wme.LT.rlu(0)*wshow) GOTO 260    
     
 C...Impose angular ordering by rejection of nonordered emission.    
       ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN  
         maom=1  
         zm=v(im,1)  
         IF(iep(1).EQ.n+2) zm=1.-v(im,1) 
         the2id=z*(1.-z)*(zm*p(im,4))**2/v(iep(1),5) 
         iaom=im 
   290   IF(k(iaom,5).EQ.22) THEN    
           iaom=k(iaom,3)    
           IF(k(iaom,3).LE.ns) maom=0    
           IF(maom.EQ.1) GOTO 290    
         ENDIF   
         IF(maom.EQ.1) THEN  
           the2im=v(iaom,1)*(1.-v(iaom,1))*p(iaom,4)**2/v(iaom,5)    
           IF(the2id.LT.the2im) GOTO 260 
         ENDIF   
       ENDIF 
     
 C...Impose user-defined maximum angle at first branching.   
       IF(mstj(48).EQ.1) THEN    
         IF(nep.EQ.1.AND.im.EQ.ns) THEN  
           the2id=z*(1.-z)*ps(4)**2/v(iep(1),5)  
           IF(the2id.LT.1./parj(85)**2) GOTO 260 
         ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN    
           the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)  
           IF(the2id.LT.1./parj(85)**2) GOTO 260 
         ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN    
           the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)  
           IF(the2id.LT.1./parj(86)**2) GOTO 260 
         ENDIF   
       ENDIF 
     
 C...End of inner veto algorithm. Check if only one leg evolved so far.  
   300 v(iep(1),1)=z 
       isl(1)=0  
       isl(2)=0  
       IF(nep.EQ.1) GOTO 330 
       IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) GOTO 200  
       DO 310 i=1,nep    
       IF(itry(i).EQ.0.AND.kfld(i).GT.0.AND.(kfld(i).LE.8.OR.kfld(i).EQ. 
      &21)) THEN 
         IF(p(n+i,5).GE.pmth(2,kfld(i))) GOTO 200    
       ENDIF 
   310 CONTINUE  
     
 C...Check if chosen multiplet m1,m2,z1,z2 is physical.  
       IF(nep.EQ.3) THEN 
         pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))    
         pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))    
         pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))    
         pts=0.25*(2.*pa1s*pa2s+2.*pa1s*pa3s+2.*pa2s*pa3s-   
      &  pa1s**2-pa2s**2-pa3s**2)/pa1s   
         IF(pts.LE.0.) GOTO 200  
       ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN    
         DO 320 i1=n+1,n+2   
         kflda=iabs(k(i1,2)) 
         IF(kflda.EQ.0.OR.(kflda.GT.8.AND.kflda.NE.21)) GOTO 320 
         IF(p(i1,5).LT.pmth(2,kflda)) GOTO 320   
         IF(kflda.EQ.21) THEN    
           kflgd1=iabs(k(i1,5))  
           kflgd2=kflgd1 
         ELSE    
           kflgd1=kflda  
           kflgd2=iabs(k(i1,5))  
         ENDIF   
         i2=2*n+3-i1 
         IF(igm.EQ.0.OR.mstj(43).LE.2) THEN  
           ped=0.5*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5) 
         ELSE    
           IF(i1.EQ.n+1) zm=v(im,1)  
           IF(i1.EQ.n+2) zm=1.-v(im,1)   
           pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-  
      &    4.*v(n+1,5)*v(n+2,5)) 
           ped=pem*(0.5*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)    
         ENDIF   
         IF(mod(mstj(43),2).EQ.1) THEN   
           pmqth3=0.5*parj(82)   
           IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)  
           pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(i1,5)    
           pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)    
           zd=sqrt(max(0.,(1.-v(i1,5)/ped**2)*((1.-pmq1-pmq2)**2-    
      &    4.*pmq1*pmq2)))   
           zh=1.+pmq1-pmq2   
         ELSE    
           zd=sqrt(max(0.,1.-v(i1,5)/ped**2))    
           zh=1. 
         ENDIF   
         zl=0.5*(zh-zd)  
         zu=0.5*(zh+zd)  
         IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1 
         IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1 
         IF(kflda.EQ.21) v(i1,4)=log(zu*(1.-zl)/max(1e-20,zl*(1.-zu)))   
         IF(kflda.NE.21) v(i1,4)=log((1.-zl)/max(1e-10,1.-zu))   
   320   CONTINUE    
         IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN  
           isl(3-islm)=0 
           islm=3-islm   
         ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN    
           zdr1=max(0.,v(n+1,3)/v(n+1,4)-1.) 
           zdr2=max(0.,v(n+2,3)/v(n+2,4)-1.) 
           IF(zdr2.GT.rlu(0)*(zdr1+zdr2)) isl(1)=0   
           IF(isl(1).EQ.1) isl(2)=0  
           IF(isl(1).EQ.0) islm=1    
           IF(isl(2).EQ.0) islm=2    
         ENDIF   
         IF(isl(1).EQ.1.OR.isl(2).EQ.1) GOTO 200 
       ENDIF 
       IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.    
      &pmth(2,kfld(1)).OR.p(n+2,5).GE.pmth(2,kfld(2)))) THEN 
         pmq1=v(n+1,5)/v(im,5)   
         pmq2=v(n+2,5)/v(im,5)   
         zd=sqrt(max(0.,(1.-v(im,5)/pem**2)*((1.-pmq1-pmq2)**2-  
      &  4.*pmq1*pmq2))) 
         zh=1.+pmq1-pmq2 
         zl=0.5*(zh-zd)  
         zu=0.5*(zh+zd)  
         IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) GOTO 200 
       ENDIF 
     
 C...Accepted branch. Construct four-momentum for initial partons.   
   330 mazip=0   
       mazic=0   
       IF(nep.EQ.1) THEN 
         p(n+1,1)=0. 
         p(n+1,2)=0. 
         p(n+1,3)=sqrt(max(0.,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-   
      &  p(n+1,5)))) 
         p(n+1,4)=p(ipa(1),4)    
         v(n+1,2)=p(n+1,4)   
       ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN    
         ped1=0.5*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)    
         p(n+1,1)=0. 
         p(n+1,2)=0. 
         p(n+1,3)=sqrt(max(0.,(ped1+p(n+1,5))*(ped1-p(n+1,5))))  
         p(n+1,4)=ped1   
         p(n+2,1)=0. 
         p(n+2,2)=0. 
         p(n+2,3)=-p(n+1,3)  
         p(n+2,4)=p(im,5)-ped1   
         v(n+1,2)=p(n+1,4)   
         v(n+2,2)=p(n+2,4)   
       ELSEIF(nep.EQ.3) THEN 
         p(n+1,1)=0. 
         p(n+1,2)=0. 
         p(n+1,3)=sqrt(max(0.,pa1s)) 
         p(n+2,1)=sqrt(pts)  
         p(n+2,2)=0. 
         p(n+2,3)=0.5*(pa3s-pa2s-pa1s)/p(n+1,3)  
         p(n+3,1)=-p(n+2,1)  
         p(n+3,2)=0. 
         p(n+3,3)=-(p(n+1,3)+p(n+2,3))   
         v(n+1,2)=p(n+1,4)   
         v(n+2,2)=p(n+2,4)   
         v(n+3,2)=p(n+3,4)   
     
 C...Construct transverse momentum for ordinary branching in shower. 
       ELSE  
         zm=v(im,1)  
         pzm=sqrt(max(0.,(pem+p(im,5))*(pem-p(im,5))))   
         pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4.*v(n+1,5)*v(n+2,5)    
         IF(pzm.LE.0.) THEN  
           pts=0.    
         ELSEIF(mod(mstj(43),2).EQ.1) THEN   
           pts=(pem**2*(zm*(1.-zm)*v(im,5)-(1.-zm)*v(n+1,5)- 
      &    zm*v(n+2,5))-0.25*pmls)/pzm**2    
         ELSE    
           pts=pmls*(zm*(1.-zm)*pem**2/v(im,5)-0.25)/pzm**2  
         ENDIF   
         pt=sqrt(max(0.,pts))    
     
 C...Find coefficient of azimuthal asymmetry due to gluon polarization.  
         hazip=0.    
         IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21.    
      &  and.iau.NE.0) THEN  
           IF(k(igm,3).NE.0) mazip=1 
           zau=v(igm,1)  
           IF(iau.EQ.im+1) zau=1.-v(igm,1)   
           IF(mazip.EQ.0) zau=0. 
           IF(k(igm,2).NE.21) THEN   
             hazip=2.*zau/(1.+zau**2)    
           ELSE  
             hazip=(zau/(1.-zau*(1.-zau)))**2    
           ENDIF 
           IF(k(n+1,2).NE.21) THEN   
             hazip=hazip*(-2.*zm*(1.-zm))/(1.-2.*zm*(1.-zm)) 
           ELSE  
             hazip=hazip*(zm*(1.-zm)/(1.-zm*(1.-zm)))**2 
           ENDIF 
         ENDIF   
     
 C...Find coefficient of azimuthal asymmetry due to soft gluon   
 C...interference.   
         hazic=0.    
         IF(mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.k(n+2,2).EQ.21).    
      &  and.iau.NE.0) THEN  
           IF(k(igm,3).NE.0) mazic=n+1   
           IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2    
           IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.   
      &    zm.GT.0.5) mazic=n+2  
           IF(k(iau,2).EQ.22) mazic=0    
           zs=zm 
           IF(mazic.EQ.n+2) zs=1.-zm 
           zgm=v(igm,1)  
           IF(iau.EQ.im-1) zgm=1.-v(igm,1)   
           IF(mazic.EQ.0) zgm=1. 
           hazic=(p(im,5)/p(igm,5))*sqrt((1.-zs)*(1.-zgm)/(zs*zgm))  
           hazic=min(0.95,hazic) 
         ENDIF   
       ENDIF 
     
 C...Construct kinematics for ordinary branching in shower.  
   340 IF(nep.EQ.2.AND.igm.GT.0) THEN    
         IF(mod(mstj(43),2).EQ.1) THEN   
           p(n+1,4)=pem*v(im,1)  
         ELSE    
           p(n+1,4)=pem*(0.5*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+ 
      &    sqrt(pmls)*zm)/v(im,5)    
         ENDIF   
         phi=paru(2)*rlu(0)  
         p(n+1,1)=pt*cos(phi)    
         p(n+1,2)=pt*sin(phi)    
         IF(pzm.GT.0.) THEN  
           p(n+1,3)=0.5*(v(n+2,5)-v(n+1,5)-v(im,5)+2.*pem*p(n+1,4))/pzm  
         ELSE    
           p(n+1,3)=0.   
         ENDIF   
         p(n+2,1)=-p(n+1,1)  
         p(n+2,2)=-p(n+1,2)  
         p(n+2,3)=pzm-p(n+1,3)   
         p(n+2,4)=pem-p(n+1,4)   
         IF(mstj(43).LE.2) THEN  
           v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)  
           v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)  
         ENDIF   
       ENDIF 
     
 C...Rotate and boost daughters. 
       IF(igm.GT.0) THEN 
         IF(mstj(43).LE.2) THEN  
           bex=p(igm,1)/p(igm,4) 
           bey=p(igm,2)/p(igm,4) 
           bez=p(igm,3)/p(igm,4) 
           ga=p(igm,4)/p(igm,5)  
           gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1.+ga)-   
      &    p(im,4))  
         ELSE    
           bex=0.    
           bey=0.    
           bez=0.    
           ga=1. 
           gabep=0.  
         ENDIF   
         the=ulangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+   
      &  (p(im,2)+gabep*bey)**2))    
         phi=ulangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey) 
         DO 350 i=n+1,n+2    
         dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+ 
      &  sin(the)*cos(phi)*p(i,3)    
         dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+ 
      &  sin(the)*sin(phi)*p(i,3)    
         dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)  
         dp(4)=p(i,4)    
         dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)   
         dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))    
         p(i,1)=dp(1)+dgabp*bex  
         p(i,2)=dp(2)+dgabp*bey  
         p(i,3)=dp(3)+dgabp*bez  
   350   p(i,4)=ga*(dp(4)+dbp)   
       ENDIF 
     
 C...Weight with azimuthal distribution, if required.    
       IF(mazip.NE.0.OR.mazic.NE.0) THEN 
         DO 360 j=1,3    
         dpt(1,j)=p(im,j)    
         dpt(2,j)=p(iau,j)   
   360   dpt(3,j)=p(n+1,j)   
         dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)  
         dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)  
         dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2    
         DO 370 j=1,3    
         dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm    
   370   dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm    
         dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)  
         dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)  
         IF(min(dpt(4,4),dpt(5,4)).GT.0.1*parj(82)) THEN 
           cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+ 
      &    dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))    
           IF(mazip.NE.0) THEN   
             IF(1.+hazip*(2.*cad**2-1.).LT.rlu(0)*(1.+abs(hazip)))   
      &      GOTO 340    
           ENDIF 
           IF(mazic.NE.0) THEN   
             IF(mazic.EQ.n+2) cad=-cad   
             IF((1.-hazic)*(1.-hazic*cad)/(1.+hazic**2-2.*hazic*cad).    
      &      lt.rlu(0)) GOTO 340 
           ENDIF 
         ENDIF   
       ENDIF 
     
 C...Continue loop over partons that may branch, until none left.    
       IF(igm.GE.0) k(im,1)=14   
       n=n+nep   
       nep=2 
       IF(n.GT.mstu(4)-mstu(32)-5) THEN  
         CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) n=ns  
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       GOTO 140  
     
 C...Set information on imagined shower initiator.   
   380 IF(npa.GE.2) THEN 
         k(ns+1,1)=11    
         k(ns+1,2)=94    
         k(ns+1,3)=ip1   
         IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2   
         k(ns+1,4)=ns+2  
         k(ns+1,5)=ns+1+npa  
         iim=1   
       ELSE  
         iim=0   
       ENDIF 
     
 C...Reconstruct string drawing information. 
       DO 390 i=ns+1+iim,n   
       IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN    
         k(i,1)=1    
       ELSEIF(k(i,1).LE.10) THEN 
         k(i,4)=mstu(5)*(k(i,4)/mstu(5)) 
         k(i,5)=mstu(5)*(k(i,5)/mstu(5)) 
       ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN 
         id1=mod(k(i,4),mstu(5)) 
         IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1   
         id2=2*mod(k(i,4),mstu(5))+1-id1 
         k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1 
         k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2 
         k(id1,4)=k(id1,4)+mstu(5)*i 
         k(id1,5)=k(id1,5)+mstu(5)*id2   
         k(id2,4)=k(id2,4)+mstu(5)*id1   
         k(id2,5)=k(id2,5)+mstu(5)*i 
       ELSE  
         id1=mod(k(i,4),mstu(5)) 
         id2=id1+1   
         k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1 
         k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1 
         k(id1,4)=k(id1,4)+mstu(5)*i 
         k(id1,5)=k(id1,5)+mstu(5)*i 
         k(id2,4)=0  
         k(id2,5)=0  
       ENDIF 
   390 CONTINUE  
     
 C...Transformation from CM frame.   
       IF(npa.GE.2) THEN 
         bex=ps(1)/ps(4) 
         bey=ps(2)/ps(4) 
         bez=ps(3)/ps(4) 
         ga=ps(4)/ps(5)  
         gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))  
      &  /(1.+ga)-p(ipa(1),4))   
       ELSE  
         bex=0.  
         bey=0.  
         bez=0.  
         gabep=0.    
       ENDIF 
       the=ulangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)    
      &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))   
       phi=ulangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)   
       IF(npa.EQ.3) THEN 
         chi=ulangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*  
      &  sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*   
      &  bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+   
      &  gabep*bey)) 
         CALL ludbrb(ns+1,n,0.,chi,0d0,0d0,0d0)  
       ENDIF 
       dbex=dble(bex)    
       dbey=dble(bey)    
       dbez=dble(bez)    
       CALL ludbrb(ns+1,n,the,phi,dbex,dbey,dbez)    
     
 C...Decay vertex of shower. 
       DO 400 i=ns+1,n   
       DO 400 j=1,5  
   400 v(i,j)=v(ip1,j)   
     
 C...Delete trivial shower, else connect initiators. 
       IF(n.EQ.ns+npa+iim) THEN  
         n=ns    
       ELSE  
         DO 410 ip=1,npa 
         k(ipa(ip),1)=14 
         k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip 
         k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip 
         k(ns+iim+ip,3)=ipa(ip)  
         IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1  
         k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)   
   410   k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)   
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lusphe()

subroutine lusphe	(	SPH,
		APL
	)

Definition at line 6377 of file hipyset1.35.f.

     
 C...Purpose: to perform sphericity tensor analysis to give sphericity,  
 C...aplanarity and the related event axes.  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension sm(3,3),sv(3,3) 
     
 C...Calculate matrix to be diagonalized.    
       np=0  
       DO 100 j1=1,3 
       DO 100 j2=j1,3    
   100 sm(j1,j2)=0.  
       ps=0. 
       DO 120 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120  
       IF(mstu(41).GE.2) THEN    
         kc=lucomp(k(i,2))   
         IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
      &  kc.EQ.18) GOTO 120  
         IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
      &  GOTO 120    
       ENDIF 
       np=np+1   
       pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)    
       pwt=1.    
       IF(abs(paru(41)-2.).GT.0.001) pwt=max(1e-10,pa)**(paru(41)-2.)    
       DO 110 j1=1,3 
       DO 110 j2=j1,3    
   110 sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)   
       ps=ps+pwt*pa**2   
   120 CONTINUE  
     
 C...Very low multiplicities (0 or 1) not considered.    
       IF(np.LE.1) THEN  
         CALL luerrm(8,'(LUSPHE:) too few particles for analysis')   
         sph=-1. 
         apl=-1. 
         RETURN  
       ENDIF 
       DO 130 j1=1,3 
       DO 130 j2=j1,3    
   130 sm(j1,j2)=sm(j1,j2)/ps    
     
 C...Find eigenvalues to matrix (third degree equation). 
       sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-   
      &sm(1,3)**2-sm(2,3)**2)/3.-1./9.   
       sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*  
      &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.    
       sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.) 
       p(n+1,4)=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)    
       p(n+3,4)=1./3.+sqrt(-sq)*min(2.*sp,-sqrt(3.*(1.-sp**2))-sp)   
       p(n+2,4)=1.-p(n+1,4)-p(n+3,4) 
       IF(p(n+2,4).LT.1e-5) THEN 
         CALL luerrm(8,'(LUSPHE:) all particles back-to-back')   
         sph=-1. 
         apl=-1. 
         RETURN  
       ENDIF 
     
 C...Find first and last eigenvector by solving equation system. 
       DO 170 i=1,3,2    
       DO 140 j1=1,3 
       sv(j1,j1)=sm(j1,j1)-p(n+i,4)  
       DO 140 j2=j1+1,3  
       sv(j1,j2)=sm(j1,j2)   
   140 sv(j2,j1)=sm(j1,j2)   
       smax=0.   
       DO 150 j1=1,3 
       DO 150 j2=1,3 
       IF(abs(sv(j1,j2)).LE.smax) GOTO 150   
       ja=j1 
       jb=j2 
       smax=abs(sv(j1,j2))   
   150 CONTINUE  
       smax=0.   
       DO 160 j3=ja+1,ja+2   
       j1=j3-3*((j3-1)/3)    
       rl=sv(j1,jb)/sv(ja,jb)    
       DO 160 j2=1,3 
       sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)  
       IF(abs(sv(j1,j2)).LE.smax) GOTO 160   
       jc=j1 
       smax=abs(sv(j1,j2))   
   160 CONTINUE  
       jb1=jb+1-3*(jb/3) 
       jb2=jb+2-3*((jb+1)/3) 
       p(n+i,jb1)=-sv(jc,jb2)    
       p(n+i,jb2)=sv(jc,jb1) 
       p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/ 
      &sv(ja,jb) 
       pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)  
       sgn=(-1.)**int(rlu(0)+0.5)    
       DO 170 j=1,3  
   170 p(n+i,j)=sgn*p(n+i,j)/pa  
     
 C...Middle axis orthogonal to other two. Fill other codes.  
       sgn=(-1.)**int(rlu(0)+0.5)    
       p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))    
       p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))    
       p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))    
       DO 180 i=1,3  
       k(n+i,1)=31   
       k(n+i,2)=95   
       k(n+i,3)=i    
       k(n+i,4)=0    
       k(n+i,5)=0    
       p(n+i,5)=0.   
       DO 180 j=1,5  
   180 v(i,j)=0. 
     
 C...Select storing option. Calculate sphericity and aplanarity. 
       mstu(61)=n+1  
       mstu(62)=np   
       IF(mstu(43).LE.1) mstu(3)=3   
       IF(mstu(43).GE.2) n=n+3   
       sph=1.5*(p(n+2,4)+p(n+3,4))   
       apl=1.5*p(n+3,4)  
     
       RETURN    

Here is the call graph for this function:

◆ lustrf()

subroutine lustrf ( IP )

Definition at line 1176 of file hipyset1.35.f.

 C...Purpose: to handle the fragmentation of an arbitrary colour singlet 
 C...jet system according to the Lund string fragmentation model.    
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),    
      &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),  
      &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5)    
     
 C...Function: four-product of two vectors.  
       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) 
       dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-   
      &dp(i,3)*dp(j,3)   
     
 C...Reset counters. Identify parton system. 
       mstj(91)=0    
       nsav=n    
       np=0  
       kqsum=0   
       DO 100 j=1,5  
   100 dps(j)=0. 
       mju(1)=0  
       mju(2)=0  
       i=ip-1    
   110 i=i+1 
       IF(i.GT.min(n,mstu(4)-mstu(32))) THEN 
         CALL luerrm(12,'(LUSTRF:) failed to reconstruct jet system')    
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 110 
       kc=lucomp(k(i,2)) 
       IF(kc.EQ.0) GOTO 110  
       kq=kchg(kc,2)*isign(1,k(i,2)) 
       IF(kq.EQ.0) GOTO 110  
       IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN  
         CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Take copy of partons to be considered. Check flavour sum.   
       np=np+1   
       DO 120 j=1,5  
       k(n+np,j)=k(i,j)  
       p(n+np,j)=p(i,j)  
   120 dps(j)=dps(j)+p(i,j)  
       k(n+np,3)=i   
       IF(p(n+np,4)**2.LT.p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2) THEN   
         p(n+np,4)=sqrt(p(n+np,1)**2+p(n+np,2)**2+p(n+np,3)**2+  
      &  p(n+np,5)**2)   
         dps(4)=dps(4)+max(0.,p(n+np,4)-p(i,4))  
       ENDIF 
       IF(kq.NE.2) kqsum=kqsum+kq    
       IF(k(i,1).EQ.41) THEN 
         kqsum=kqsum+2*kq    
         IF(kqsum.EQ.kq) mju(1)=n+np 
         IF(kqsum.NE.kq) mju(2)=n+np 
       ENDIF 
       IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) GOTO 110  
       IF(kqsum.NE.0) THEN   
         CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')  
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Boost copied system to CM frame (for better numerical precision).   
       CALL ludbrb(n+1,n+np,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4), 
      &-dps(3)/dps(4))   
     
 C...Search for very nearby partons that may be recombined.  
       ntryr=0   
       paru12=paru(12)   
       paru13=paru(13)   
       mju(3)=mju(1) 
       mju(4)=mju(2) 
       nr=np 
   130 IF(nr.GE.3) THEN  
         pdrmin=2.*paru12    
         DO 140 i=n+1,n+nr   
         IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) GOTO 140 
         i1=i+1  
         IF(i.EQ.n+nr) i1=n+1    
         IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) GOTO 140  
         IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)    
      &  GOTO 140    
         IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21) GOTO 140 
         pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+   
      &  p(i1,2)**2+p(i1,3)**2)) 
         pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)    
         pdr=4.*(pap-pvp)**2/(paru13**2*pap+2.*(pap-pvp))    
         IF(pdr.LT.pdrmin) THEN  
           ir=i  
           pdrmin=pdr    
         ENDIF   
   140   CONTINUE    
     
 C...Recombine very nearby partons to avoid machine precision problems.  
         IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN    
           DO 150 j=1,4  
   150     p(n+1,j)=p(n+1,j)+p(n+nr,j)   
           p(n+1,5)=sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2- 
      &    p(n+1,3)**2)) 
           nr=nr-1   
           GOTO 130  
         ELSEIF(pdrmin.LT.paru12) THEN   
           DO 160 j=1,4  
   160     p(ir,j)=p(ir,j)+p(ir+1,j) 
           p(ir,5)=sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2- 
      &    p(ir,3)**2))  
           DO 170 i=ir+1,n+nr-1  
           k(i,2)=k(i+1,2)   
           DO 170 j=1,5  
   170     p(i,j)=p(i+1,j)   
           IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)    
           nr=nr-1   
           IF(mju(1).GT.ir) mju(1)=mju(1)-1  
           IF(mju(2).GT.ir) mju(2)=mju(2)-1  
           GOTO 130  
         ENDIF   
       ENDIF 
       ntryr=ntryr+1 
     
 C...Reset particle counter. Skip ahead if no junctions are present; 
 C...this is usually the case!   
       nrs=max(5*nr+11,np)   
       ntry=0    
   180 ntry=ntry+1   
       IF(ntry.GT.100.AND.ntryr.LE.4) THEN   
         paru12=4.*paru12    
         paru13=2.*paru13    
         GOTO 130    
       ELSEIF(ntry.GT.100) THEN  
         CALL luerrm(14,'(LUSTRF:) caught in infinite loop') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       i=n+nrs   
       IF(mju(1).EQ.0.AND.mju(2).EQ.0) GOTO 500  
       DO 490 jt=1,2 
       njs(jt)=0 
       IF(mju(jt).EQ.0) GOTO 490 
       js=3-2*jt 
     
 C...Find and sum up momentum on three sides of junction. Check flavours.    
       DO 190 iu=1,3 
       iju(iu)=0 
       DO 190 j=1,5  
   190 pju(iu,j)=0.  
       iu=0  
       DO 200 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js 
       IF(k(i1,2).NE.21.AND.iu.LE.2) THEN    
         iu=iu+1 
         iju(iu)=i1  
       ENDIF 
       DO 200 j=1,4  
   200 pju(iu,j)=pju(iu,j)+p(i1,j)   
       DO 210 iu=1,3 
   210 pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)    
       IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND. 
      &k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN   
         CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')  
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
     
 C...Calculate (approximate) boost to rest frame of junction.    
       t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/  
      &(pju(1,5)*pju(2,5))   
       t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/  
      &(pju(1,5)*pju(3,5))   
       t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/  
      &(pju(2,5)*pju(3,5))   
       t11=sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))  
       t22=sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))  
       tsq=sqrt((2.*t11*t22+t12-1.)*(1.+t12))    
       t1f=(tsq-t22*(1.+t12))/(1.-t12**2)    
       t2f=(tsq-t11*(1.+t12))/(1.-t12**2)    
       DO 220 j=1,3  
   220 tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5)) 
       tju(4)=sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2) 
       DO 230 iu=1,3 
   230 pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)- 
      &tju(3)*pju(iu,3)  
     
 C...Put junction at rest if motion could give inconsistencies.  
       IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN   
         DO 240 j=1,3    
   240   tju(j)=0.   
         tju(4)=1.   
         pju(1,5)=pju(1,4)   
         pju(2,5)=pju(2,4)   
         pju(3,5)=pju(3,4)   
       ENDIF 
     
 C...Start preparing for fragmentation of two strings from junction. 
       ista=i    
       DO 470 iu=1,2 
       ns=iju(iu+1)-iju(iu)  
     
 C...Junction strings: find longitudinal string directions.  
       DO 260 is=1,ns    
       is1=iju(iu)+is-1  
       is2=iju(iu)+is    
       DO 250 j=1,5  
       dp(1,j)=0.5*p(is1,j)  
       IF(is.EQ.1) dp(1,j)=p(is1,j)  
       dp(2,j)=0.5*p(is2,j)  
   250 IF(is.EQ.ns) dp(2,j)=-pju(iu,j)   
       IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2) 
       IF(is.EQ.ns) dp(2,5)=0.   
       dp(3,5)=dfour(1,1)    
       dp(4,5)=dfour(2,2)    
       dhkc=dfour(1,2)   
       IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN    
         dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
         dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
         dp(3,5)=0d0 
         dp(4,5)=0d0 
         dhkc=dfour(1,2) 
       ENDIF 
       dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))    
       dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.) 
       dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.) 
       in1=n+nr+4*is-3   
       p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))    
       DO 260 j=1,4  
       p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)   
   260 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j) 
     
 C...Junction strings: initialize flavour, momentum and starting pos.    
       isav=i    
   270 ntry=ntry+1   
       IF(ntry.GT.100.AND.ntryr.LE.4) THEN   
         paru12=4.*paru12    
         paru13=2.*paru13    
         GOTO 130    
       ELSEIF(ntry.GT.100) THEN  
         CALL luerrm(14,'(LUSTRF:) caught in infinite loop') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       i=isav    
       irankj=0  
       ie(1)=k(n+1+(jt/2)*(np-1),3)  
       in(4)=n+nr+1  
       in(5)=in(4)+1 
       in(6)=n+nr+4*ns+1 
       DO 280 jq=1,2 
       DO 280 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4 
       p(in1,1)=2-jq 
       p(in1,2)=jq-1 
   280 p(in1,3)=1.   
       kfl(1)=k(iju(iu),2)   
       px(1)=0.  
       py(1)=0.  
       gam(1)=0. 
       DO 290 j=1,5  
   290 pju(iu+3,j)=0.    
     
 C...Junction strings: find initial transverse directions.   
       DO 300 j=1,4  
       dp(1,j)=p(in(4),j)    
       dp(2,j)=p(in(4)+1,j)  
       dp(3,j)=0.    
   300 dp(4,j)=0.    
       dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)    
       dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)    
       dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)   
       dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)   
       dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)   
       IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.    
       IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.    
       IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.    
       IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.    
       dhc12=dfour(1,2)  
       dhcx1=dfour(3,1)/dhc12    
       dhcx2=dfour(3,2)/dhc12    
       dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12) 
       dhcy1=dfour(4,1)/dhc12    
       dhcy2=dfour(4,2)/dhc12    
       dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12   
       dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)    
       DO 310 j=1,4  
       dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))   
       p(in(6),j)=dp(3,j)    
   310 p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-  
      &dhcyx*dp(3,j))    
     
 C...Junction strings: produce new particle, origin. 
   320 i=i+1 
       IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN   
         CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       irankj=irankj+1   
       k(i,1)=1  
       k(i,3)=ie(1)  
       k(i,4)=0  
       k(i,5)=0  
     
 C...Junction strings: generate flavour, hadron, pT, z and Gamma.    
   330 CALL lukfdi(kfl(1),0,kfl(3),k(i,2))   
       IF(k(i,2).EQ.0) GOTO 270  
       IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.  
      &iabs(kfl(3)).GT.10) THEN  
         IF(rlu(0).GT.parj(19)) GOTO 330 
       ENDIF 
       p(i,5)=ulmass(k(i,2)) 
       CALL luptdi(kfl(1),px(3),py(3))   
       pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2 
       CALL luzdis(kfl(1),kfl(3),pr(1),z)    
       gam(3)=(1.-z)*(gam(1)+pr(1)/z)    
       DO 340 j=1,3  
   340 in(j)=in(3+j) 
     
 C...Junction strings: stepping within or from 'low' string region easy. 
       IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*  
      &p(in(1),5)**2.GE.pr(1)) THEN  
         p(in(1)+2,4)=z*p(in(1)+2,3) 
         p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2) 
         DO 350 j=1,4    
   350   p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)  
         GOTO 420    
       ELSEIF(in(1)+1.EQ.in(2)) THEN 
         p(in(2)+2,4)=p(in(2)+2,3)   
         p(in(2)+2,1)=1. 
         in(2)=in(2)+4   
         IF(in(2).GT.n+nr+4*ns) GOTO 270 
         IF(four(in(1),in(2)).LE.1e-2) THEN  
           p(in(1)+2,4)=p(in(1)+2,3) 
           p(in(1)+2,1)=0.   
           in(1)=in(1)+4 
         ENDIF   
       ENDIF 
     
 C...Junction strings: find new transverse directions.   
   360 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.   
      &in(1).GT.in(2)) GOTO 270  
       IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN 
         DO 370 j=1,4    
         dp(1,j)=p(in(1),j)  
         dp(2,j)=p(in(2),j)  
         dp(3,j)=0.  
   370   dp(4,j)=0.  
         dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
         dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
         dhc12=dfour(1,2)    
         IF(dhc12.LE.1e-2) THEN  
           p(in(1)+2,4)=p(in(1)+2,3) 
           p(in(1)+2,1)=0.   
           in(1)=in(1)+4 
           GOTO 360  
         ENDIF   
         in(3)=n+nr+4*ns+5   
         dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4) 
         dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4) 
         dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4) 
         IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.  
         IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.  
         IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.  
         IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.  
         dhcx1=dfour(3,1)/dhc12  
         dhcx2=dfour(3,2)/dhc12  
         dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)   
         dhcy1=dfour(4,1)/dhc12  
         dhcy2=dfour(4,2)/dhc12  
         dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12 
         dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)  
         DO 380 j=1,4    
         dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j)) 
         p(in(3),j)=dp(3,j)  
   380   p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-    
      &  dhcyx*dp(3,j))  
 C...Express pT with respect to new axes, if sensible.   
         pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))    
         pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))    
         IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN   
           px(3)=pxp 
           py(3)=pyp 
         ENDIF   
       ENDIF 
     
 C...Junction strings: sum up known four-momentum, coefficients for m2.  
       DO 400 j=1,4  
       dhg(j)=0. 
       p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+  
      &py(3)*p(in(3)+1,j)    
       DO 390 in1=in(4),in(1)-4,4    
   390 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j) 
       DO 400 in2=in(5),in(2)-4,4    
   400 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j) 
       dhm(1)=four(i,i)  
       dhm(2)=2.*four(i,in(1))   
       dhm(3)=2.*four(i,in(2))   
       dhm(4)=2.*four(in(1),in(2))   
     
 C...Junction strings: find coefficients for Gamma expression.   
       DO 410 in2=in(1)+1,in(2),4    
       DO 410 in1=in(1),in2-1,4  
       dhc=2.*four(in1,in2)  
       dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc   
       IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc 
       IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc 
   410 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc   
     
 C...Junction strings: solve (m2, Gamma) equation system for energies.   
       dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)  
       IF(abs(dhs1).LT.1e-4) GOTO 270    
       dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)* 
      &(p(i,5)**2-dhm(1))+dhg(2)*dhm(3)  
       dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1)) 
       p(in(2)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-  
      &dhs2/dhs1)    
       IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0.) GOTO 270 
       p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/  
      &(dhm(2)+dhm(4)*p(in(2)+2,4))  
     
 C...Junction strings: step to new region if necessary.  
       IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN 
         p(in(2)+2,4)=p(in(2)+2,3)   
         p(in(2)+2,1)=1. 
         in(2)=in(2)+4   
         IF(in(2).GT.n+nr+4*ns) GOTO 270 
         IF(four(in(1),in(2)).LE.1e-2) THEN  
           p(in(1)+2,4)=p(in(1)+2,3) 
           p(in(1)+2,1)=0.   
           in(1)=in(1)+4 
         ENDIF   
         GOTO 360    
       ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN 
         p(in(1)+2,4)=p(in(1)+2,3)   
         p(in(1)+2,1)=0. 
         in(1)=in(1)+js  
         GOTO 710    
       ENDIF 
     
 C...Junction strings: particle four-momentum, remainder, loop back. 
   420 DO 430 j=1,4  
       p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j) 
   430 pju(iu+3,j)=pju(iu+3,j)+p(i,j)    
       IF(p(i,4).LE.0.) GOTO 270 
       pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-    
      &tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3) 
       IF(pju(iu+3,5).LT.pju(iu,5)) THEN 
         kfl(1)=-kfl(3)  
         px(1)=-px(3)    
         py(1)=-py(3)    
         gam(1)=gam(3)   
         IF(in(3).NE.in(6)) THEN 
           DO 440 j=1,4  
           p(in(6),j)=p(in(3),j) 
   440     p(in(6)+1,j)=p(in(3)+1,j) 
         ENDIF   
         DO 450 jq=1,2   
         in(3+jq)=in(jq) 
         p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)   
   450   p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)  
         GOTO 320    
       ENDIF 
     
 C...Junction strings: save quantities left after each string.   
       IF(iabs(kfl(1)).GT.10) GOTO 270   
       i=i-1 
       kfjh(iu)=kfl(1)   
       DO 460 j=1,4  
   460 pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)  
   470 CONTINUE  
     
 C...Junction strings: put together to new effective string endpoint.    
       njs(jt)=i-ista    
       kfjs(jt)=k(k(mju(jt+2),3),2)  
       kfls=2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4)))+1   
       IF(kfjh(1).EQ.kfjh(2)) kfls=3 
       IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),  
      &iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+  
      &kfls,kfjh(1)) 
       DO 480 j=1,4  
       pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)  
   480 pjs(jt+2,j)=pju(4,j)+pju(5,j) 
       pjs(jt,5)=sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2- 
      &pjs(jt,3)**2))    
   490 CONTINUE  
     
 C...Open versus closed strings. Choose breakup region for latter.   
   500 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN  
         ns=mju(2)-mju(1)    
         nb=mju(1)-n 
       ELSEIF(mju(1).NE.0) THEN  
         ns=n+nr-mju(1)  
         nb=mju(1)-n 
       ELSEIF(mju(2).NE.0) THEN  
         ns=mju(2)-n 
         nb=1    
       ELSEIF(iabs(k(n+1,2)).NE.21) THEN 
         ns=nr-1 
         nb=1    
       ELSE  
         ns=nr+1 
         w2sum=0.    
         DO 510 is=1,nr  
         p(n+nr+is,1)=0.5*four(n+is,n+is+1-nr*(is/nr))   
   510   w2sum=w2sum+p(n+nr+is,1)    
         w2ran=rlu(0)*w2sum  
         nb=0    
   520   nb=nb+1 
         w2sum=w2sum-p(n+nr+nb,1)    
         IF(w2sum.GT.w2ran.AND.nb.LT.nr) GOTO 520    
       ENDIF 
     
 C...Find longitudinal string directions (i.e. lightlike four-vectors).  
       DO 540 is=1,ns    
       is1=n+is+nb-1-nr*((is+nb-2)/nr)   
       is2=n+is+nb-nr*((is+nb-1)/nr) 
       DO 530 j=1,5  
       dp(1,j)=p(is1,j)  
       IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5*dp(1,j)  
       IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)   
       dp(2,j)=p(is2,j)  
       IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5*dp(2,j)  
   530 IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)   
       dp(3,5)=dfour(1,1)    
       dp(4,5)=dfour(2,2)    
       dhkc=dfour(1,2)   
       IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN    
         dp(3,5)=dp(1,5)**2  
         dp(4,5)=dp(2,5)**2  
         dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)   
         dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)   
         dhkc=dfour(1,2) 
       ENDIF 
       dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))    
       dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.) 
       dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.) 
       in1=n+nr+4*is-3   
       p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))    
       DO 540 j=1,4  
       p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)   
   540 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j) 
     
 C...Begin initialization: sum up energy, set starting position. 
       isav=i    
   550 ntry=ntry+1   
       IF(ntry.GT.100.AND.ntryr.LE.4) THEN   
         paru12=4.*paru12    
         paru13=2.*paru13    
         GOTO 130    
       ELSEIF(ntry.GT.100) THEN  
         CALL luerrm(14,'(LUSTRF:) caught in infinite loop') 
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       i=isav    
       DO 560 j=1,4  
       p(n+nrs,j)=0. 
       DO 560 is=1,nr    
   560 p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)   
       DO 570 jt=1,2 
       irank(jt)=0   
       IF(mju(jt).NE.0) irank(jt)=njs(jt)    
       IF(ns.GT.nr) irank(jt)=1  
       ie(jt)=k(n+1+(jt/2)*(np-1),3) 
       in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1) 
       in(3*jt+2)=in(3*jt+1)+1   
       in(3*jt+3)=n+nr+4*ns+2*jt-1   
       DO 570 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4 
       p(in1,1)=2-jt 
       p(in1,2)=jt-1 
   570 p(in1,3)=1.   
     
 C...Initialize flavour and pT variables for open string.    
       IF(ns.LT.nr) THEN 
         px(1)=0.    
         py(1)=0.    
         IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL luptdi(0,px(1),py(1))   
         px(2)=-px(1)    
         py(2)=-py(1)    
         DO 580 jt=1,2   
         kfl(jt)=k(ie(jt),2) 
         IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)   
         mstj(93)=1  
         pmq(jt)=ulmass(kfl(jt)) 
   580   gam(jt)=0.  
     
 C...Closed string: random initial breakup flavour, pT and vertex.   
       ELSE  
         kfl(3)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)    
         CALL lukfdi(kfl(3),0,kfl(1),kdump)  
         kfl(2)=-kfl(1)  
         IF(iabs(kfl(1)).GT.10.AND.rlu(0).GT.0.5) THEN   
           kfl(2)=-(kfl(1)+isign(10000,kfl(1)))  
         ELSEIF(iabs(kfl(1)).GT.10) THEN 
           kfl(1)=-(kfl(2)+isign(10000,kfl(2)))  
         ENDIF   
         CALL luptdi(kfl(1),px(1),py(1)) 
         px(2)=-px(1)    
         py(2)=-py(1)    
         pr3=min(25.,0.1*p(n+nr+1,5)**2) 
   590   CALL luzdis(kfl(1),kfl(2),pr3,z)    
         zr=pr3/(z*p(n+nr+1,5)**2)   
         IF(zr.GE.1.) GOTO 590   
         DO 600 jt=1,2   
         mstj(93)=1  
         pmq(jt)=ulmass(kfl(jt)) 
         gam(jt)=pr3*(1.-z)/z    
         in1=n+nr+3+4*(jt/2)*(ns-1)  
         p(in1,jt)=1.-z  
         p(in1,3-jt)=jt-1    
         p(in1,3)=(2-jt)*(1.-z)+(jt-1)*z 
         p(in1+1,jt)=zr  
         p(in1+1,3-jt)=2-jt  
   600   p(in1+1,3)=(2-jt)*(1.-zr)+(jt-1)*zr 
       ENDIF 
     
 C...Find initial transverse directions (i.e. spacelike four-vectors).   
       DO 640 jt=1,2 
       IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN    
         in1=in(3*jt+1)  
         in3=in(3*jt+3)  
         DO 610 j=1,4    
         dp(1,j)=p(in1,j)    
         dp(2,j)=p(in1+1,j)  
         dp(3,j)=0.  
   610   dp(4,j)=0.  
         dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
         dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
         dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4) 
         dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4) 
         dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4) 
         IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.  
         IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.  
         IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.  
         IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.  
         dhc12=dfour(1,2)    
         dhcx1=dfour(3,1)/dhc12  
         dhcx2=dfour(3,2)/dhc12  
         dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)   
         dhcy1=dfour(4,1)/dhc12  
         dhcy2=dfour(4,2)/dhc12  
         dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12 
         dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)  
         DO 620 j=1,4    
         dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j)) 
         p(in3,j)=dp(3,j)    
   620   p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-  
      &  dhcyx*dp(3,j))  
       ELSE  
         DO 630 j=1,4    
         p(in3+2,j)=p(in3,j) 
   630   p(in3+3,j)=p(in3+1,j)   
       ENDIF 
   640 CONTINUE  
     
 C...Remove energy used up in junction string fragmentation. 
       IF(mju(1)+mju(2).GT.0) THEN   
         DO 660 jt=1,2   
         IF(njs(jt).EQ.0) GOTO 660   
         DO 650 j=1,4    
   650   p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)   
   660   CONTINUE    
       ENDIF 
     
 C...Produce new particle: side, origin. 
   670 i=i+1 
       IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN   
         CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       jt=1.5+rlu(0) 
       IF(iabs(kfl(3-jt)).GT.10) jt=3-jt 
       jr=3-jt   
       js=3-2*jt 
       irank(jt)=irank(jt)+1 
       k(i,1)=1  
       k(i,3)=ie(jt) 
       k(i,4)=0  
       k(i,5)=0  
     
 C...Generate flavour, hadron and pT.    
   680 CALL lukfdi(kfl(jt),0,kfl(3),k(i,2))  
       IF(k(i,2).EQ.0) GOTO 550  
       IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.  
      &iabs(kfl(3)).GT.10) THEN  
         IF(rlu(0).GT.parj(19)) GOTO 680 
       ENDIF 
       p(i,5)=ulmass(k(i,2)) 
       CALL luptdi(kfl(jt),px(3),py(3))  
       pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2  
     
 C...Final hadrons for small invariant mass. 
       mstj(93)=1    
       pmq(3)=ulmass(kfl(3)) 
       wmin=parj(32+mstj(11))+pmq(1)+pmq(2)+parj(36)*pmq(3)  
       IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=  
      &wmin-0.5*parj(36)*pmq(3)  
       wrem2=four(n+nrs,n+nrs)   
       IF(wrem2.LT.0.10) GOTO 550    
       IF(wrem2.LT.max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),    
      &parj(32)+pmq(1)+pmq(2))**2) GOTO 810  
     
 C...Choose z, which gives Gamma. Shift z for heavy flavours.    
       CALL luzdis(kfl(jt),kfl(3),pr(jt),z)  
       kfl1a=iabs(kfl(1))    
       kfl2a=iabs(kfl(2))    
       IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),    
      &mod(kfl2a/1000,10)).GE.4) THEN    
         pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2  
         pw12=sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))    
         z=(wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)   
         pr(jr)=(pmq(jr)+parj(32+mstj(11)))**2+(px(jr)-px(3))**2+    
      &  (py(jr)-py(3))**2   
         IF((1.-z)*(wrem2-pr(jt)/z).LT.pr(jr)) GOTO 810  
       ENDIF 
       gam(3)=(1.-z)*(gam(jt)+pr(jt)/z)  
       DO 690 j=1,3  
   690 in(j)=in(3*jt+j)  
     
 C...Stepping within or from 'low' string region easy.   
       IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*  
      &p(in(1),5)**2.GE.pr(jt)) THEN 
         p(in(jt)+2,4)=z*p(in(jt)+2,3)   
         p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)  
         DO 700 j=1,4    
   700   p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)    
         GOTO 770    
       ELSEIF(in(1)+1.EQ.in(2)) THEN 
         p(in(jr)+2,4)=p(in(jr)+2,3) 
         p(in(jr)+2,jt)=1.   
         in(jr)=in(jr)+4*js  
         IF(js*in(jr).GT.js*in(4*jr)) GOTO 550   
         IF(four(in(1),in(2)).LE.1e-2) THEN  
           p(in(jt)+2,4)=p(in(jt)+2,3)   
           p(in(jt)+2,jt)=0. 
           in(jt)=in(jt)+4*js    
         ENDIF   
       ENDIF 
     
 C...Find new transverse directions (i.e. spacelike string vectors). 
   710 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR. 
      &in(1).GT.in(2)) GOTO 550  
       IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN   
         DO 720 j=1,4    
         dp(1,j)=p(in(1),j)  
         dp(2,j)=p(in(2),j)  
         dp(3,j)=0.  
   720   dp(4,j)=0.  
         dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)  
         dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)  
         dhc12=dfour(1,2)    
         IF(dhc12.LE.1e-2) THEN  
           p(in(jt)+2,4)=p(in(jt)+2,3)   
           p(in(jt)+2,jt)=0. 
           in(jt)=in(jt)+4*js    
           GOTO 710  
         ENDIF   
         in(3)=n+nr+4*ns+5   
         dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4) 
         dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4) 
         dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4) 
         IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.  
         IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.  
         IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.  
         IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.  
         dhcx1=dfour(3,1)/dhc12  
         dhcx2=dfour(3,2)/dhc12  
         dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)   
         dhcy1=dfour(4,1)/dhc12  
         dhcy2=dfour(4,2)/dhc12  
         dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12 
         dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)  
         DO 730 j=1,4    
         dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j)) 
         p(in(3),j)=dp(3,j)  
   730   p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-    
      &  dhcyx*dp(3,j))  
 C...Express pT with respect to new axes, if sensible.   
         pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*   
      &  four(in(3*jt+3)+1,in(3)))   
         pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)* 
      &  four(in(3*jt+3)+1,in(3)+1)) 
         IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN   
           px(3)=pxp 
           py(3)=pyp 
         ENDIF   
       ENDIF 
     
 C...Sum up known four-momentum. Gives coefficients for m2 expression.   
       DO 750 j=1,4  
       dhg(j)=0. 
       p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+   
      &px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)   
       DO 740 in1=in(3*jt+1),in(1)-4*js,4*js 
   740 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j) 
       DO 750 in2=in(3*jt+2),in(2)-4*js,4*js 
   750 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j) 
       dhm(1)=four(i,i)  
       dhm(2)=2.*four(i,in(1))   
       dhm(3)=2.*four(i,in(2))   
       dhm(4)=2.*four(in(1),in(2))   
     
 C...Find coefficients for Gamma expression. 
       DO 760 in2=in(1)+1,in(2),4    
       DO 760 in1=in(1),in2-1,4  
       dhc=2.*four(in1,in2)  
       dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc 
       IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc 
       IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc 
   760 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc   
     
 C...Solve (m2, Gamma) equation system for energies taken.   
       dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)    
       IF(abs(dhs1).LT.1e-4) GOTO 550    
       dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*   
      &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)    
       dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))   
       p(in(jr)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)- 
      &dhs2/dhs1)    
       IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0.) GOTO 550 
       p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/ 
      &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))  
     
 C...Step to new region if necessary.    
       IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN   
         p(in(jr)+2,4)=p(in(jr)+2,3) 
         p(in(jr)+2,jt)=1.   
         in(jr)=in(jr)+4*js  
         IF(js*in(jr).GT.js*in(4*jr)) GOTO 550   
         IF(four(in(1),in(2)).LE.1e-2) THEN  
           p(in(jt)+2,4)=p(in(jt)+2,3)   
           p(in(jt)+2,jt)=0. 
           in(jt)=in(jt)+4*js    
         ENDIF   
         GOTO 710    
       ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN   
         p(in(jt)+2,4)=p(in(jt)+2,3) 
         p(in(jt)+2,jt)=0.   
         in(jt)=in(jt)+4*js  
         GOTO 710    
       ENDIF 
     
 C...Four-momentum of particle. Remaining quantities. Loop back. 
   770 DO 780 j=1,4  
       p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j) 
   780 p(n+nrs,j)=p(n+nrs,j)-p(i,j)  
       IF(p(i,4).LE.0.) GOTO 550 
       kfl(jt)=-kfl(3)   
       pmq(jt)=pmq(3)    
       px(jt)=-px(3) 
       py(jt)=-py(3) 
       gam(jt)=gam(3)    
       IF(in(3).NE.in(3*jt+3)) THEN  
         DO 790 j=1,4    
         p(in(3*jt+3),j)=p(in(3),j)  
   790   p(in(3*jt+3)+1,j)=p(in(3)+1,j)  
       ENDIF 
       DO 800 jq=1,2 
       in(3*jt+jq)=in(jq)    
       p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4) 
   800 p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)   
       GOTO 670  
     
 C...Final hadron: side, flavour, hadron, mass.  
   810 i=i+1 
       k(i,1)=1  
       k(i,3)=ie(jr) 
       k(i,4)=0  
       k(i,5)=0  
       CALL lukfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))    
       IF(k(i,2).EQ.0) GOTO 550  
       p(i,5)=ulmass(k(i,2)) 
       pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2  
     
 C...Final two hadrons: find common setup of four-vectors.   
       jq=1  
       IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)* 
      &p(in(8),3)*four(in(7),in(8))) jq=2    
       dhc12=four(in(3*jq+1),in(3*jq+2)) 
       dhr1=four(n+nrs,in(3*jq+2))/dhc12 
       dhr2=four(n+nrs,in(3*jq+1))/dhc12 
       IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN 
         px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq) 
         py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)   
         pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*    
      &  px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2   
       ENDIF 
     
 C...Solve kinematics for final two hadrons, if possible.    
       wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2 
       fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)  
       IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1.) GOTO 180  
       IF(fd.GE.1.) GOTO 550 
       fa=wrem2+pr(jt)-pr(jr)    
       IF(mstj(11).EQ.2) prev=0.5*fd**parj(37+mstj(11))  
       IF(mstj(11).NE.2) prev=0.5*exp(max(-100.,log(fd)* 
      &parj(37+mstj(11))*(pr(1)+pr(2))**2))  
       fb=sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))),js*(rlu(0)-prev)) 
       kfl1a=iabs(kfl(1))    
       kfl2a=iabs(kfl(2))    
       IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),    
      &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0.,fa**2-  
      &4.*wrem2*pr(jt))),float(js))  
       DO 820 j=1,4  
       p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*   
      &p(in(3*jq+3)+1,j)+0.5*(dhr1*(fa+fb)*p(in(3*jq+1),j)+  
      &dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2   
   820 p(i,j)=p(n+nrs,j)-p(i-1,j)    
     
 C...Mark jets as fragmented and give daughter pointers. 
       n=i-nrs+1 
       DO 830 i=nsav+1,nsav+np   
       im=k(i,3) 
       k(im,1)=k(im,1)+10    
       IF(mstu(16).NE.2) THEN    
         k(im,4)=nsav+1  
         k(im,5)=nsav+1  
       ELSE  
         k(im,4)=nsav+2  
         k(im,5)=n   
       ENDIF 
   830 CONTINUE  
     
 C...Document string system. Move up particles.  
       nsav=nsav+1   
       k(nsav,1)=11  
       k(nsav,2)=92  
       k(nsav,3)=ip  
       k(nsav,4)=nsav+1  
       k(nsav,5)=n   
       DO 840 j=1,4  
       p(nsav,j)=dps(j)  
   840 v(nsav,j)=v(ip,j) 
       p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))  
       v(nsav,5)=0.  
       DO 850 i=nsav+1,n 
       DO 850 j=1,5  
       k(i,j)=k(i+nrs-1,j)   
       p(i,j)=p(i+nrs-1,j)   
   850 v(i,j)=0. 
     
 C...Order particles in rank along the chain. Update mother pointer. 
       DO 860 i=nsav+1,n 
       DO 860 j=1,5  
       k(i-nsav+n,j)=k(i,j)  
   860 p(i-nsav+n,j)=p(i,j)  
       i1=nsav   
       DO 880 i=n+1,2*n-nsav 
       IF(k(i,3).NE.ie(1)) GOTO 880  
       i1=i1+1   
       DO 870 j=1,5  
       k(i1,j)=k(i,j)    
   870 p(i1,j)=p(i,j)    
       IF(mstu(16).NE.2) k(i1,3)=nsav    
   880 CONTINUE  
       DO 900 i=2*n-nsav,n+1,-1  
       IF(k(i,3).EQ.ie(1)) GOTO 900  
       i1=i1+1   
       DO 890 j=1,5  
       k(i1,j)=k(i,j)    
   890 p(i1,j)=p(i,j)    
       IF(mstu(16).NE.2) k(i1,3)=nsav    
   900 CONTINUE  
     
 C...Boost back particle system. Set production vertices.    
       CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),dps(2)/dps(4),   
      &dps(3)/dps(4))    
       DO 910 i=nsav+1,n 
       DO 910 j=1,4  
   910 v(i,j)=v(ip,j)    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lutabu()

subroutine lutabu ( MTABU )

Definition at line 7395 of file hipyset1.35.f.

     
 C...Purpose: to evaluate various properties of an event, with   
 C...statistics accumulated during the course of the run and 
 C...printed at the end. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),   
      &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),    
      &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),    
      &kfdm(8),kfdc(200,0:8),npdc(200)   
       SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs, 
      &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,    
      &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc 
       CHARACTER chau*16,chis(2)*12,chdc(8)*12   
       DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,   
      &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0./,fm2fm/120*0./,   
      &nevee/0/,fe1ec/50*0./,fe2ec/50*0./,fe1ea/25*0./,fe2ea/25*0./, 
      &nevdc/0/,nkfdc/0/,nredc/0/    
     
 C...Reset statistics on initial parton state.   
       IF(mtabu.EQ.10) THEN  
         nevis=0 
         nkfis=0 
     
 C...Identify and order flavour content of initial state.    
       ELSEIF(mtabu.EQ.11) THEN  
         nevis=nevis+1   
         kfm1=2*iabs(mstu(161))  
         IF(mstu(161).GT.0) kfm1=kfm1-1  
         kfm2=2*iabs(mstu(162))  
         IF(mstu(162).GT.0) kfm2=kfm2-1  
         kfmn=min(kfm1,kfm2) 
         kfmx=max(kfm1,kfm2) 
         DO 100 i=1,nkfis    
         IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN    
           ikfis=-i  
           GOTO 110  
         ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND. 
      &  kfmx.LT.kfis(i,2))) THEN    
           ikfis=i   
           GOTO 110  
         ENDIF   
   100   CONTINUE    
         ikfis=nkfis+1   
   110   IF(ikfis.LT.0) THEN 
           ikfis=-ikfis  
         ELSE    
           IF(nkfis.GE.100) RETURN   
           DO 120 i=nkfis,ikfis,-1   
           kfis(i+1,1)=kfis(i,1) 
           kfis(i+1,2)=kfis(i,2) 
           DO 120 j=0,10 
   120     npis(i+1,j)=npis(i,j) 
           nkfis=nkfis+1 
           kfis(ikfis,1)=kfmn    
           kfis(ikfis,2)=kfmx    
           DO 130 j=0,10 
   130     npis(ikfis,j)=0   
         ENDIF   
         npis(ikfis,0)=npis(ikfis,0)+1   
     
 C...Count number of partons in initial state.   
         np=0    
         DO 150 i=1,n    
         IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN    
         ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN 
         ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)    
      &  THEN    
         ELSE    
           im=i  
   140     im=k(im,3)    
           IF(im.LE.0.OR.im.GT.n) THEN   
             np=np+1 
           ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN    
             np=np+1 
           ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN 
           ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10).NE.0)    
      &    THEN  
           ELSE  
             GOTO 140    
           ENDIF 
         ENDIF   
   150   CONTINUE    
         npco=max(np,1)  
         IF(np.GE.6) npco=6  
         IF(np.GE.8) npco=7  
         IF(np.GE.11) npco=8 
         IF(np.GE.16) npco=9 
         IF(np.GE.26) npco=10    
         npis(ikfis,npco)=npis(ikfis,npco)+1 
         mstu(62)=np 
     
 C...Write statistics on initial parton state.   
       ELSEIF(mtabu.EQ.12) THEN  
         fac=1./max(1,nevis) 
         WRITE(mstu(11),1000) nevis  
         DO 160 i=1,nkfis    
         kfmn=kfis(i,1)  
         IF(kfmn.EQ.0) kfmn=kfis(i,2)    
         kfm1=(kfmn+1)/2 
         IF(2*kfm1.EQ.kfmn) kfm1=-kfm1   
         CALL luname(kfm1,chau)  
         chis(1)=chau(1:12)  
         IF(chau(13:13).NE.' ') chis(1)(12:12)='?'   
         kfmx=kfis(i,2)  
         IF(kfis(i,1).EQ.0) kfmx=0   
         kfm2=(kfmx+1)/2 
         IF(2*kfm2.EQ.kfmx) kfm2=-kfm2   
         CALL luname(kfm2,chau)  
         chis(2)=chau(1:12)  
         IF(chau(13:13).NE.' ') chis(2)(12:12)='?'   
   160   WRITE(mstu(11),1100) chis(1),chis(2),fac*npis(i,0), 
      &  (npis(i,j)/float(npis(i,0)),j=1,10) 
     
 C...Copy statistics on initial parton state into /LUJETS/.  
       ELSEIF(mtabu.EQ.13) THEN  
         fac=1./max(1,nevis) 
         DO 170 i=1,nkfis    
         kfmn=kfis(i,1)  
         IF(kfmn.EQ.0) kfmn=kfis(i,2)    
         kfm1=(kfmn+1)/2 
         IF(2*kfm1.EQ.kfmn) kfm1=-kfm1   
         kfmx=kfis(i,2)  
         IF(kfis(i,1).EQ.0) kfmx=0   
         kfm2=(kfmx+1)/2 
         IF(2*kfm2.EQ.kfmx) kfm2=-kfm2   
         k(i,1)=32   
         k(i,2)=99   
         k(i,3)=kfm1 
         k(i,4)=kfm2 
         k(i,5)=npis(i,0)    
         DO 170 j=1,5    
         p(i,j)=fac*npis(i,j)    
   170   v(i,j)=fac*npis(i,j+5)  
         n=nkfis 
         DO 180 j=1,5    
         k(n+1,j)=0  
         p(n+1,j)=0. 
   180   v(n+1,j)=0. 
         k(n+1,1)=32 
         k(n+1,2)=99 
         k(n+1,5)=nevis  
         mstu(3)=1   
     
 C...Reset statistics on number of particles/partons.    
       ELSEIF(mtabu.EQ.20) THEN  
         nevfs=0 
         nprfs=0 
         nfifs=0 
         nchfs=0 
         nkffs=0 
     
 C...Identify whether particle/parton is primary or not. 
       ELSEIF(mtabu.EQ.21) THEN  
         nevfs=nevfs+1   
         mstu(62)=0  
         DO 230 i=1,n    
         IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) GOTO 230    
         mstu(62)=mstu(62)+1 
         kc=lucomp(k(i,2))   
         mpri=0  
         IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN 
           mpri=1    
         ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN  
           mpri=1    
         ELSEIF(kc.EQ.0) THEN    
         ELSEIF(k(k(i,3),1).EQ.13) THEN  
           im=k(k(i,3),3)    
           IF(im.LE.0.OR.im.GT.n) THEN   
             mpri=1  
           ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN    
             mpri=1  
           ENDIF 
         ELSEIF(kchg(kc,2).EQ.0) THEN    
           kcm=lucomp(k(k(i,3),2))   
           IF(kcm.NE.0) THEN 
             IF(kchg(kcm,2).NE.0) mpri=1 
           ENDIF 
         ENDIF   
         IF(kc.NE.0.AND.mpri.EQ.1) THEN  
           IF(kchg(kc,2).EQ.0) nprfs=nprfs+1 
         ENDIF   
         IF(k(i,1).LE.10) THEN   
           nfifs=nfifs+1 
           IF(luchge(k(i,2)).NE.0) nchfs=nchfs+1 
         ENDIF   
     
 C...Fill statistics on number of particles/partons in event.    
         kfa=iabs(k(i,2))    
         kfs=3-isign(1,k(i,2))-mpri  
         DO 190 ip=1,nkffs   
         IF(kfa.EQ.kffs(ip)) THEN    
           ikffs=-ip 
           GOTO 200  
         ELSEIF(kfa.LT.kffs(ip)) THEN    
           ikffs=ip  
           GOTO 200  
         ENDIF   
   190   CONTINUE    
         ikffs=nkffs+1   
   200   IF(ikffs.LT.0) THEN 
           ikffs=-ikffs  
         ELSE    
           IF(nkffs.GE.400) RETURN   
           DO 210 ip=nkffs,ikffs,-1  
           kffs(ip+1)=kffs(ip)   
           DO 210 j=1,4  
   210     npfs(ip+1,j)=npfs(ip,j)   
           nkffs=nkffs+1 
           kffs(ikffs)=kfa   
           DO 220 j=1,4  
   220     npfs(ikffs,j)=0   
         ENDIF   
         npfs(ikffs,kfs)=npfs(ikffs,kfs)+1   
   230   CONTINUE    
     
 C...Write statistics on particle/parton composition of events.  
       ELSEIF(mtabu.EQ.22) THEN  
         fac=1./max(1,nevfs) 
         WRITE(mstu(11),1200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs    
         DO 240 i=1,nkffs    
         CALL luname(kffs(i),chau)   
         kc=lucomp(kffs(i))  
         mdcyf=0 
         IF(kc.NE.0) mdcyf=mdcy(kc,1)    
   240   WRITE(mstu(11),1300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),  
      &  fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))   
     
 C...Copy particle/parton composition information into /LUJETS/. 
       ELSEIF(mtabu.EQ.23) THEN  
         fac=1./max(1,nevfs) 
         DO 260 i=1,nkffs    
         k(i,1)=32   
         k(i,2)=99   
         k(i,3)=kffs(i)  
         k(i,4)=0    
         k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)  
         DO 250 j=1,4    
         p(i,j)=fac*npfs(i,j)    
   250   v(i,j)=0.   
         p(i,5)=fac*k(i,5)   
   260   v(i,5)=0.   
         n=nkffs 
         DO 270 j=1,5    
         k(n+1,j)=0  
         p(n+1,j)=0. 
   270   v(n+1,j)=0. 
         k(n+1,1)=32 
         k(n+1,2)=99 
         k(n+1,5)=nevfs  
         p(n+1,1)=fac*nprfs  
         p(n+1,2)=fac*nfifs  
         p(n+1,3)=fac*nchfs  
         mstu(3)=1   
     
 C...Reset factorial moments statistics. 
       ELSEIF(mtabu.EQ.30) THEN  
         nevfm=0 
         nmufm=0 
         DO 280 im=1,3   
         DO 280 ib=1,10  
         DO 280 ip=1,4   
         fm1fm(im,ib,ip)=0.  
   280   fm2fm(im,ib,ip)=0.  
     
 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.  
       ELSEIF(mtabu.EQ.31) THEN  
         nevfm=nevfm+1   
         nlow=n+mstu(3)  
         nupp=nlow   
         DO 360 i=1,n    
         IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 360    
         IF(mstu(41).GE.2) THEN  
           kc=lucomp(k(i,2)) 
           IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
      &    kc.EQ.18) GOTO 360    
           IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
      &    GOTO 360  
         ENDIF   
         pmr=0.  
         IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)  
         IF(mstu(42).GE.2) pmr=p(i,5)    
         pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)    
         yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),    
      &  1e20)),p(i,3))  
         IF(abs(yeta).GT.paru(57)) GOTO 360  
         phi=ulangl(p(i,1),p(i,2))   
         iyeta=512.*(yeta+paru(57))/(2.*paru(57))    
         iyeta=max(0,min(511,iyeta)) 
         iphi=512.*(phi+paru(1))/paru(2) 
         iphi=max(0,min(511,iphi))   
         iyep=0  
         DO 290 ib=0,9   
   290   iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))    
     
 C...Order particles in (pseudo)rapidity and/or azimuth. 
         IF(nupp.GT.mstu(4)-5-mstu(32)) THEN 
           CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS') 
           RETURN    
         ENDIF   
         nupp=nupp+1 
         IF(nupp.EQ.nlow+1) THEN 
           k(nupp,1)=iyeta   
           k(nupp,2)=iphi    
           k(nupp,3)=iyep    
         ELSE    
           DO 300 i1=nupp-1,nlow+1,-1    
           IF(iyeta.GE.k(i1,1)) GOTO 310 
   300     k(i1+1,1)=k(i1,1) 
   310     k(i1+1,1)=iyeta   
           DO 320 i1=nupp-1,nlow+1,-1    
           IF(iphi.GE.k(i1,2)) GOTO 330  
   320     k(i1+1,2)=k(i1,2) 
   330     k(i1+1,2)=iphi    
           DO 340 i1=nupp-1,nlow+1,-1    
           IF(iyep.GE.k(i1,3)) GOTO 350  
   340     k(i1+1,3)=k(i1,3) 
   350     k(i1+1,3)=iyep    
         ENDIF   
   360   CONTINUE    
         k(nupp+1,1)=2**10   
         k(nupp+1,2)=2**10   
         k(nupp+1,3)=4**10   
     
 C...Calculate sum of factorial moments in event.    
         DO 400 im=1,3   
         DO 370 ib=1,10  
         DO 370 ip=1,4   
   370   fevfm(ib,ip)=0. 
         DO 380 ib=1,10  
         IF(im.LE.2) ibin=2**(10-ib) 
         IF(im.EQ.3) ibin=4**(10-ib) 
         iagr=k(nlow+1,im)/ibin  
         nagr=1  
         DO 380 i=nlow+2,nupp+1  
         icut=k(i,im)/ibin   
         IF(icut.EQ.iagr) THEN   
           nagr=nagr+1   
         ELSE    
           IF(nagr.EQ.1) THEN    
           ELSEIF(nagr.EQ.2) THEN    
             fevfm(ib,1)=fevfm(ib,1)+2.  
           ELSEIF(nagr.EQ.3) THEN    
             fevfm(ib,1)=fevfm(ib,1)+6.  
             fevfm(ib,2)=fevfm(ib,2)+6.  
           ELSEIF(nagr.EQ.4) THEN    
             fevfm(ib,1)=fevfm(ib,1)+12. 
             fevfm(ib,2)=fevfm(ib,2)+24. 
             fevfm(ib,3)=fevfm(ib,3)+24. 
           ELSE  
             fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1.)  
             fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1.)*(nagr-2.)    
             fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)  
             fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)* 
      &      (nagr-4.)   
           ENDIF 
           iagr=icut 
           nagr=1    
         ENDIF   
   380   CONTINUE    
     
 C...Add results to total statistics.    
         DO 390 ib=10,1,-1   
         DO 390 ip=1,4   
         IF(fevfm(1,ip).LT.0.5) THEN 
           fevfm(ib,ip)=0.   
         ELSEIF(im.LE.2) THEN    
           fevfm(ib,ip)=2**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)  
         ELSE    
           fevfm(ib,ip)=4**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)  
         ENDIF   
         fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)    
   390   fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2 
   400   CONTINUE    
         nmufm=nmufm+(nupp-nlow) 
         mstu(62)=nupp-nlow  
     
 C...Write accumulated statistics on factorial moments.  
       ELSEIF(mtabu.EQ.32) THEN  
         fac=1./max(1,nevfm) 
         IF(mstu(42).LE.0) WRITE(mstu(11),1400) nevfm,'eta'  
         IF(mstu(42).EQ.1) WRITE(mstu(11),1400) nevfm,'ypi'  
         IF(mstu(42).GE.2) WRITE(mstu(11),1400) nevfm,'y  '  
         DO 420 im=1,3   
         WRITE(mstu(11),1500)    
         DO 420 ib=1,10  
         byeta=2.*paru(57)   
         IF(im.NE.2) byeta=byeta/2**(ib-1)   
         bphi=paru(2)    
         IF(im.NE.1) bphi=bphi/2**(ib-1) 
         IF(im.LE.2) bnave=fac*nmufm/float(2**(ib-1))    
         IF(im.EQ.3) bnave=fac*nmufm/float(4**(ib-1))    
         DO 410 ip=1,4   
         fmoma(ip)=fac*fm1fm(im,ib,ip)   
   410   fmoms(ip)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-fmoma(ip)**2)))  
   420   WRITE(mstu(11),1600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip), 
      &  ip=1,4) 
     
 C...Copy statistics on factorial moments into /LUJETS/. 
       ELSEIF(mtabu.EQ.33) THEN  
         fac=1./max(1,nevfm) 
         DO 430 im=1,3   
         DO 430 ib=1,10  
         i=10*(im-1)+ib  
         k(i,1)=32   
         k(i,2)=99   
         k(i,3)=1    
         IF(im.NE.2) k(i,3)=2**(ib-1)    
         k(i,4)=1    
         IF(im.NE.1) k(i,4)=2**(ib-1)    
         k(i,5)=0    
         p(i,1)=2.*paru(57)/k(i,3)   
         v(i,1)=paru(2)/k(i,4)   
         DO 430 ip=1,4   
         p(i,ip+1)=fac*fm1fm(im,ib,ip)   
   430   v(i,ip+1)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-p(i,ip+1)**2)))  
         n=30    
         DO 440 j=1,5    
         k(n+1,j)=0  
         p(n+1,j)=0. 
   440   v(n+1,j)=0. 
         k(n+1,1)=32 
         k(n+1,2)=99 
         k(n+1,5)=nevfm  
         mstu(3)=1   
     
 C...Reset statistics on Energy-Energy Correlation.  
       ELSEIF(mtabu.EQ.40) THEN  
         nevee=0 
         DO 450 j=1,25   
         fe1ec(j)=0. 
         fe2ec(j)=0. 
         fe1ec(51-j)=0.  
         fe2ec(51-j)=0.  
         fe1ea(j)=0. 
   450   fe2ea(j)=0. 
     
 C...Find particles to include, with proper assumed mass.    
       ELSEIF(mtabu.EQ.41) THEN  
         nevee=nevee+1   
         nlow=n+mstu(3)  
         nupp=nlow   
         ecm=0.  
         DO 460 i=1,n    
         IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 460    
         IF(mstu(41).GE.2) THEN  
           kc=lucomp(k(i,2)) 
           IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.    
      &    kc.EQ.18) GOTO 460    
           IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) 
      &    GOTO 460  
         ENDIF   
         pmr=0.  
         IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)  
         IF(mstu(42).GE.2) pmr=p(i,5)    
         IF(nupp.GT.mstu(4)-5-mstu(32)) THEN 
           CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS') 
           RETURN    
         ENDIF   
         nupp=nupp+1 
         p(nupp,1)=p(i,1)    
         p(nupp,2)=p(i,2)    
         p(nupp,3)=p(i,3)    
         p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)    
         p(nupp,5)=max(1e-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))    
         ecm=ecm+p(nupp,4)   
   460   CONTINUE    
         IF(nupp.EQ.nlow) RETURN 
     
 C...Analyze Energy-Energy Correlation in event. 
         fac=(2./ecm**2)*50./paru(1) 
         DO 470 j=1,50   
   470   fevee(j)=0. 
         DO 480 i1=nlow+2,nupp   
         DO 480 i2=nlow+1,i1-1   
         cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/ 
      &  (p(i1,5)*p(i2,5))   
         the=acos(max(-1.,min(1.,cthe))) 
         ithe=max(1,min(50,1+int(50.*the/paru(1))))  
   480   fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4) 
         DO 490 j=1,25   
         fe1ec(j)=fe1ec(j)+fevee(j)  
         fe2ec(j)=fe2ec(j)+fevee(j)**2   
         fe1ec(51-j)=fe1ec(51-j)+fevee(51-j) 
         fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2  
         fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))    
   490   fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2 
         mstu(62)=nupp-nlow  
     
 C...Write statistics on Energy-Energy Correlation.  
       ELSEIF(mtabu.EQ.42) THEN  
         fac=1./max(1,nevee) 
         WRITE(mstu(11),1700) nevee  
         DO 500 j=1,25   
         feec1=fac*fe1ec(j)  
         fees1=sqrt(max(0.,fac*(fac*fe2ec(j)-feec1**2))) 
         feec2=fac*fe1ec(51-j)   
         fees2=sqrt(max(0.,fac*(fac*fe2ec(51-j)-feec2**2)))  
         feeca=fac*fe1ea(j)  
         feesa=sqrt(max(0.,fac*(fac*fe2ea(j)-feeca**2))) 
   500   WRITE(mstu(11),1800) 3.6*(j-1),3.6*j,feec1,fees1,feec2,fees2,   
      &  feeca,feesa 
     
 C...Copy statistics on Energy-Energy Correlation into /LUJETS/. 
       ELSEIF(mtabu.EQ.43) THEN  
         fac=1./max(1,nevee) 
         DO 510 i=1,25   
         k(i,1)=32   
         k(i,2)=99   
         k(i,3)=0    
         k(i,4)=0    
         k(i,5)=0    
         p(i,1)=fac*fe1ec(i) 
         v(i,1)=sqrt(max(0.,fac*(fac*fe2ec(i)-p(i,1)**2)))   
         p(i,2)=fac*fe1ec(51-i)  
         v(i,2)=sqrt(max(0.,fac*(fac*fe2ec(51-i)-p(i,2)**2)))    
         p(i,3)=fac*fe1ea(i) 
         v(i,3)=sqrt(max(0.,fac*(fac*fe2ea(i)-p(i,3)**2)))   
         p(i,4)=paru(1)*(i-1)/50.    
         p(i,5)=paru(1)*i/50.    
         v(i,4)=3.6*(i-1)    
   510   v(i,5)=3.6*i    
         n=25    
         DO 520 j=1,5    
         k(n+1,j)=0  
         p(n+1,j)=0. 
   520   v(n+1,j)=0. 
         k(n+1,1)=32 
         k(n+1,2)=99 
         k(n+1,5)=nevee  
         mstu(3)=1   
     
 C...Reset statistics on decay channels. 
       ELSEIF(mtabu.EQ.50) THEN  
         nevdc=0 
         nkfdc=0 
         nredc=0 
     
 C...Identify and order flavour content of final state.  
       ELSEIF(mtabu.EQ.51) THEN  
         nevdc=nevdc+1   
         nds=0   
         DO 550 i=1,n    
         IF(k(i,1).LE.0.OR.k(i,1).GE.6) GOTO 550 
         nds=nds+1   
         IF(nds.GT.8) THEN   
           nredc=nredc+1 
           RETURN    
         ENDIF   
         kfm=2*iabs(k(i,2))  
         IF(k(i,2).LT.0) kfm=kfm-1   
         DO 530 ids=nds-1,1,-1   
         iin=ids+1   
         IF(kfm.LT.kfdm(ids)) GOTO 540   
   530   kfdm(ids+1)=kfdm(ids)   
         iin=1   
   540   kfdm(iin)=kfm   
   550   CONTINUE    
     
 C...Find whether old or new final state.    
         DO 570 idc=1,nkfdc  
         IF(nds.LT.kfdc(idc,0)) THEN 
           ikfdc=idc 
           GOTO 580  
         ELSEIF(nds.EQ.kfdc(idc,0)) THEN 
           DO 560 i=1,nds    
           IF(kfdm(i).LT.kfdc(idc,i)) THEN   
             ikfdc=idc   
             GOTO 580    
           ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN   
             GOTO 570    
           ENDIF 
   560     CONTINUE  
           ikfdc=-idc    
           GOTO 580  
         ENDIF   
   570   CONTINUE    
         ikfdc=nkfdc+1   
   580   IF(ikfdc.LT.0) THEN 
           ikfdc=-ikfdc  
         ELSEIF(nkfdc.GE.200) THEN   
           nredc=nredc+1 
           RETURN    
         ELSE    
           DO 590 idc=nkfdc,ikfdc,-1 
           npdc(idc+1)=npdc(idc) 
           DO 590 i=0,8  
   590     kfdc(idc+1,i)=kfdc(idc,i) 
           nkfdc=nkfdc+1 
           kfdc(ikfdc,0)=nds 
           DO 600 i=1,nds    
   600     kfdc(ikfdc,i)=kfdm(i) 
           npdc(ikfdc)=0 
         ENDIF   
         npdc(ikfdc)=npdc(ikfdc)+1   
     
 C...Write statistics on decay channels. 
       ELSEIF(mtabu.EQ.52) THEN  
         fac=1./max(1,nevdc) 
         WRITE(mstu(11),1900) nevdc  
         DO 620 idc=1,nkfdc  
         DO 610 i=1,kfdc(idc,0)  
         kfm=kfdc(idc,i) 
         kf=(kfm+1)/2    
         IF(2*kf.NE.kfm) kf=-kf  
         CALL luname(kf,chau)    
         chdc(i)=chau(1:12)  
   610   IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'   
   620   WRITE(mstu(11),2000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))    
         IF(nredc.NE.0) WRITE(mstu(11),2100) fac*nredc   
     
 C...Copy statistics on decay channels into /LUJETS/.    
       ELSEIF(mtabu.EQ.53) THEN  
         fac=1./max(1,nevdc) 
         DO 650 idc=1,nkfdc  
         k(idc,1)=32 
         k(idc,2)=99 
         k(idc,3)=0  
         k(idc,4)=0  
         k(idc,5)=kfdc(idc,0)    
         DO 630 j=1,5    
         p(idc,j)=0. 
   630   v(idc,j)=0. 
         DO 640 i=1,kfdc(idc,0)  
         kfm=kfdc(idc,i) 
         kf=(kfm+1)/2    
         IF(2*kf.NE.kfm) kf=-kf  
         IF(i.LE.5) p(idc,i)=kf  
   640   IF(i.GE.6) v(idc,i-5)=kf    
   650   v(idc,5)=fac*npdc(idc)  
         n=nkfdc 
         DO 660 j=1,5    
         k(n+1,j)=0  
         p(n+1,j)=0. 
   660   v(n+1,j)=0. 
         k(n+1,1)=32 
         k(n+1,2)=99 
         k(n+1,5)=nevdc  
         v(n+1,5)=fac*nredc  
         mstu(3)=1   
       ENDIF 
     
 C...Format statements for output on unit MSTU(11) (default 6).  
  1000 FORMAT(///20x,'Event statistics - initial state'/ 
      &20x,'based on an analysis of ',i6,' events'// 
      &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',    
      &'according to fragmenting system multiplicity'/   
      &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',    
      &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)   
  1100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4) 
  1200 FORMAT(///20x,'Event statistics - final state'/   
      &20x,'based on an analysis of ',i6,' events'// 
      &5x,'Mean primary multiplicity =',f8.3/    
      &5x,'Mean final   multiplicity =',f8.3/    
      &5x,'Mean charged multiplicity =',f8.3//   
      &5x,'Number of particles produced per event (directly and via ',   
      &'decays/branchings)'/ 
      &5x,'KF    Particle/jet  MDCY',8x,'Particles',9x,'Antiparticles',  
      &5x,'Total'/34x,'prim      seco      prim      seco'/) 
  1300 FORMAT(1x,i6,4x,a16,i2,5(1x,f9.4))    
  1400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/   
      &20x,'based on an analysis of ',i6,' events'// 
      &3x,'delta-',a3,' delta-phi     <n>/bin',10x,'<F2>',18x,'<F3>',    
      &18x,'<F4>',18x,'<F5>'/35x,4('     value     error  '))    
  1500 FORMAT(10x)   
  1600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))    
  1700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/  
      &20x,'based on an analysis of ',i6,' events'// 
      &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,  
      &'EECA(theta)'/2x,'in degrees ',3('      value    error')/)    
  1800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))  
  1900 FORMAT(///20x,'Decay channel analysis - final state'/ 
      &20x,'based on an analysis of ',i6,' events'// 
      &2x,'Probability',10x,'Complete final state'/) 
  2000 FORMAT(2x,f9.5,5x,8(a12,1x))  
  2100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',  
      &'or table overflow)') 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lutest()

subroutine lutest ( MTEST )

Definition at line 9469 of file hipyset1.35.f.

     
 C...Purpose: to provide a simple program (disguised as subroutine) to   
 C...run at installation as a check that the program works as intended.  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension psum(5),pini(6),pfin(6) 
     
 C...Loop over events to be generated.   
       IF(mtest.GE.1) CALL lutabu(20)    
       nerr=0    
       DO 170 iev=1,600  
     
 C...Reset parameter values. Switch on some nonstandard features.    
       mstj(1)=1 
       mstj(3)=0 
       mstj(11)=1    
       mstj(42)=2    
       mstj(43)=4    
       mstj(44)=2    
       parj(17)=0.1  
       parj(22)=1.5  
       parj(43)=1.   
       parj(54)=-0.05    
       mstj(101)=5   
       mstj(104)=5   
       mstj(105)=0   
       mstj(107)=1   
       IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3    
     
 C...Ten events each for some single jets configurations.    
       IF(iev.LE.50) THEN    
         ity=(iev+9)/10  
         mstj(3)=-1  
         IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2 
         IF(ity.EQ.1) CALL lu1ent(1,1,15.,0.,0.) 
         IF(ity.EQ.2) CALL lu1ent(1,3101,15.,0.,0.)  
         IF(ity.EQ.3) CALL lu1ent(1,-2203,15.,0.,0.) 
         IF(ity.EQ.4) CALL lu1ent(1,-4,30.,0.,0.)    
         IF(ity.EQ.5) CALL lu1ent(1,21,15.,0.,0.)    
     
 C...Ten events each for some simple jet systems; string fragmentation.  
       ELSEIF(iev.LE.130) THEN   
         ity=(iev-41)/10 
         IF(ity.EQ.1) CALL lu2ent(1,1,-1,40.)    
         IF(ity.EQ.2) CALL lu2ent(1,4,-4,30.)    
         IF(ity.EQ.3) CALL lu2ent(1,2,2103,100.) 
         IF(ity.EQ.4) CALL lu2ent(1,21,21,40.)   
         IF(ity.EQ.5) CALL lu3ent(1,2101,21,-3203,30.,0.6,0.8)   
         IF(ity.EQ.6) CALL lu3ent(1,5,21,-5,40.,0.9,0.8) 
         IF(ity.EQ.7) CALL lu3ent(1,21,21,21,60.,0.7,0.5)    
         IF(ity.EQ.8) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)    
     
 C...Seventy events with independent fragmentation and momentum cons.    
       ELSEIF(iev.LE.200) THEN   
         ity=1+(iev-131)/16  
         mstj(2)=1+mod(iev-131,4)    
         mstj(3)=1+mod((iev-131)/4,4)    
         IF(ity.EQ.1) CALL lu2ent(1,4,-5,40.)    
         IF(ity.EQ.2) CALL lu3ent(1,3,21,-3,40.,0.9,0.4) 
         IF(ity.EQ.3) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)    
         IF(ity.GE.4) CALL lu4ent(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2) 
     
 C...A hundred events with random jets (check invariant mass).   
       ELSEIF(iev.LE.300) THEN   
   100   DO 110 j=1,5    
   110   psum(j)=0.  
         njet=2.+6.*rlu(0)   
         DO 120 i=1,njet 
         kfl=21  
         IF(i.EQ.1) kfl=int(1.+4.*rlu(0))    
         IF(i.EQ.njet) kfl=-int(1.+4.*rlu(0))    
         ejet=5.+20.*rlu(0)  
         theta=acos(2.*rlu(0)-1.)    
         phi=6.2832*rlu(0)   
         IF(i.LT.njet) CALL lu1ent(-i,kfl,ejet,theta,phi)    
         IF(i.EQ.njet) CALL lu1ent(i,kfl,ejet,theta,phi) 
         IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+ulmass(kfl) 
         DO 120 j=1,4    
   120   psum(j)=psum(j)+p(i,j)  
         IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.  
      &  (psum(5)+parj(32))**2) GOTO 100 
     
 C...Fifty e+e- continuum events with matrix elements.   
       ELSEIF(iev.LE.350) THEN   
         mstj(101)=2 
         CALL lueevt(0,40.)  
     
 C...Fifty e+e- continuum event with varying shower options. 
       ELSEIF(iev.LE.400) THEN   
         mstj(42)=1+mod(iev,2)   
         mstj(43)=1+mod(iev/2,4) 
         mstj(44)=mod(iev/8,3)   
         CALL lueevt(0,90.)  
     
 C...Fifty e+e- continuum events with coherent shower, including top.    
       ELSEIF(iev.LE.450) THEN   
         mstj(104)=6 
         CALL lueevt(0,500.) 
     
 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.    
       ELSEIF(iev.LE.500) THEN   
         CALL luonia(5,9.46) 
     
 C...One decay each for some heavy mesons.   
       ELSEIF(iev.LE.560) THEN   
         ity=iev-501 
         kfls=2*(ity/20)+1   
         kflb=8-mod(ity/5,4) 
         kflc=kflb-mod(ity,5)    
         CALL lu1ent(1,100*kflb+10*kflc+kfls,0.,0.,0.)   
     
 C...One decay each for some heavy baryons.  
       ELSEIF(iev.LE.600) THEN   
         ity=iev-561 
         kfls=2*(ity/20)+2   
         kfla=8-mod(ity/5,4) 
         kflb=kfla-mod(ity,5)    
         kflc=max(1,kflb-1)  
         CALL lu1ent(1,1000*kfla+100*kflb+10*kflc+kfls,0.,0.,0.) 
       ENDIF 
     
 C...Generate event. Find total momentum, energy and charge. 
       DO 130 j=1,4  
   130 pini(j)=plu(0,j)  
       pini(6)=plu(0,6)  
       CALL luexec   
       DO 140 j=1,4  
   140 pfin(j)=plu(0,j)  
       pfin(6)=plu(0,6)  
     
 C...Check conservation of energy, momentum and charge;  
 C...usually exact, but only approximate for single jets.    
       merr=0    
       IF(iev.LE.50) THEN    
         IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4.) merr=merr+1 
         epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)  
         IF(epzrem.LT.0..OR.epzrem.GT.2.*parj(31)) merr=merr+1   
         IF(abs(pfin(6)-pini(6)).GT.2.1) merr=merr+1 
       ELSE  
         DO 150 j=1,4    
   150   IF(abs(pfin(j)-pini(j)).GT.0001*pini(4)) merr=merr+1    
         IF(abs(pfin(6)-pini(6)).GT.0.1) merr=merr+1 
       ENDIF 
       IF(merr.NE.0) WRITE(mstu(11),1000) (pini(j),j=1,4),pini(6),   
      &(pfin(j),j=1,4),pfin(6)   
     
 C...Check that all KF codes are known ones, and that partons/particles  
 C...satisfy energy-momentum-mass relation. Store particle statistics.   
       DO 160 i=1,n  
       IF(k(i,1).GT.20) GOTO 160 
       IF(lucomp(k(i,2)).EQ.0) THEN  
         WRITE(mstu(11),1100) i  
         merr=merr+1 
       ENDIF 
       pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2  
       IF(abs(pd).GT.max(0.1,0.001*p(i,4)**2).OR.p(i,4).LT.0.) THEN  
         WRITE(mstu(11),1200) i  
         merr=merr+1 
       ENDIF 
   160 CONTINUE  
       IF(mtest.GE.1) CALL lutabu(21)    
     
 C...List all erroneous events and some normal ones. 
       IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN  
         CALL lulist(2)  
       ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN   
         CALL lulist(1)  
       ENDIF 
     
 C...Stop execution if too many errors. Endresult of run.    
       IF(merr.NE.0) nerr=nerr+1 
       IF(nerr.GE.10) THEN   
         WRITE(mstu(11),1300) iev    
         stop    
       ENDIF 
   170 CONTINUE  
       IF(mtest.GE.1) CALL lutabu(22)    
       WRITE(mstu(11),1400) nerr 
     
 C...Reset commonblock variables changed during run. 
       mstj(2)=3 
       parj(17)=0.   
       parj(22)=1.   
       parj(43)=0.5  
       parj(54)=0.   
       mstj(105)=1   
       mstj(107)=0   
     
 C...Format statements for output.   
  1000 FORMAT(/' Momentum, energy and/or charge were not conserved ',    
      &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x, 
      &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x, 
      &4(1x,f12.5),1x,f8.2)  
  1100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')   
  1200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',  
      &'kinematics') 
  1300 FORMAT(/5x,'Ten errors experienced by event ',i3/ 
      &5x,'Something is seriously wrong! Execution stopped now!')    
  1400 FORMAT(/5x,'Number of erroneous or suspect events in run:',i3/    
      &5x,'(0 fine, 1 acceptable if a single jet, ', 
      &'>=2 something is wrong)')    
     
       RETURN    

Here is the call graph for this function:

◆ luthru()

subroutine luthru	(	THR,
		OBL
	)

Definition at line 6505 of file hipyset1.35.f.

     
 C...Purpose: to perform thrust analysis to give thrust, oblateness  
 C...and the related event axes. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension tdi(3),tpr(3)   
     
 C...Take copy of particles that are to be considered in thrust analysis.    
       np=0  
       ps=0. 
       DO 100 i=1,n  
       IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100  
       IF(mstu(41).GE.2) THEN    
         kc=lucomp(k(i,2))   
         IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.  
      &  kc.EQ.18) GOTO 100  
         IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)   
      &  GOTO 100    
       ENDIF 
       IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN   
         CALL luerrm(11,'(LUTHRU:) no more memory left in LUJETS')   
         thr=-2. 
         obl=-2. 
         RETURN  
       ENDIF 
       np=np+1   
       k(n+np,1)=23  
       p(n+np,1)=p(i,1)  
       p(n+np,2)=p(i,2)  
       p(n+np,3)=p(i,3)  
       p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2) 
       p(n+np,5)=1.  
       IF(abs(paru(42)-1.).GT.0.001) p(n+np,5)=p(n+np,4)**(paru(42)-1.)  
       ps=ps+p(n+np,4)*p(n+np,5) 
   100 CONTINUE  
     
 C...Very low multiplicities (0 or 1) not considered.    
       IF(np.LE.1) THEN  
         CALL luerrm(8,'(LUTHRU:) too few particles for analysis')   
         thr=-1. 
         obl=-1. 
         RETURN  
       ENDIF 
     
 C...Loop over thrust and major. T axis along z direction in latter case.    
       DO 280 ild=1,2    
       IF(ild.EQ.2) THEN 
         k(n+np+1,1)=31  
         phi=ulangl(p(n+np+1,1),p(n+np+1,2)) 
         CALL ludbrb(n+1,n+np+1,0.,-phi,0d0,0d0,0d0) 
         the=ulangl(p(n+np+1,3),p(n+np+1,1)) 
         CALL ludbrb(n+1,n+np+1,-the,0.,0d0,0d0,0d0) 
       ENDIF 
     
 C...Find and order particles with highest p (pT for major). 
       DO 110 ilf=n+np+4,n+np+mstu(44)+4 
   110 p(ilf,4)=0.   
       DO 150 i=n+1,n+np 
       IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2) 
       DO 120 ilf=n+np+mstu(44)+3,n+np+4,-1  
       IF(p(i,4).LE.p(ilf,4)) GOTO 130   
       DO 120 j=1,5  
   120 p(ilf+1,j)=p(ilf,j)   
       ilf=n+np+3    
   130 DO 140 j=1,5  
   140 p(ilf+1,j)=p(i,j) 
   150 CONTINUE  
     
 C...Find and order initial axes with highest thrust (major).    
       DO 160 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15   
   160 p(ilg,4)=0.   
       nc=2**(min(mstu(44),np)-1)    
       DO 220 ilc=1,nc   
       DO 170 j=1,3  
   170 tdi(j)=0. 
       DO 180 ilf=1,min(mstu(44),np) 
       sgn=p(n+np+ilf+3,5)   
       IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn    
       DO 180 j=1,4-ild  
   180 tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j) 
       tds=tdi(1)**2+tdi(2)**2+tdi(3)**2 
       DO 190 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1 
       IF(tds.LE.p(ilg,4)) GOTO 200  
       DO 190 j=1,4  
   190 p(ilg+1,j)=p(ilg,j)   
       ilg=n+np+mstu(44)+4   
   200 DO 210 j=1,3  
   210 p(ilg+1,j)=tdi(j) 
       p(ilg+1,4)=tds    
   220 CONTINUE  
     
 C...Iterate direction of axis until stable maximum. 
       p(n+np+ild,4)=0.  
       ilg=0 
   230 ilg=ilg+1 
       thp=0.    
   240 thps=thp  
       DO 250 j=1,3  
       IF(thp.LE.1e-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)  
       IF(thp.GT.1e-10) tdi(j)=tpr(j)    
   250 tpr(j)=0. 
       DO 260 i=n+1,n+np 
       sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))    
       DO 260 j=1,4-ild  
   260 tpr(j)=tpr(j)+sgn*p(i,j)  
       thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps    
       IF(thp.GE.thps+paru(48)) GOTO 240 
     
 C...Save good axis. Try new initial axis until a number of tries agree. 
       IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) GOTO 230  
       IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN    
         iagr=0  
         sgn=(-1.)**int(rlu(0)+0.5)  
         DO 270 j=1,3    
   270   p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)   
         p(n+np+ild,4)=thp   
         p(n+np+ild,5)=0.    
       ENDIF 
       iagr=iagr+1   
   280 IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) GOTO 230   
     
 C...Find minor axis and value by orthogonality. 
       sgn=(-1.)**int(rlu(0)+0.5)    
       p(n+np+3,1)=-sgn*p(n+np+2,2)  
       p(n+np+3,2)=sgn*p(n+np+2,1)   
       p(n+np+3,3)=0.    
       thp=0.    
       DO 290 i=n+1,n+np 
   290 thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2)) 
       p(n+np+3,4)=thp/ps    
       p(n+np+3,5)=0.    
     
 C...Fill axis information. Rotate back to original coordinate system.   
       DO 300 ild=1,3    
       k(n+ild,1)=31 
       k(n+ild,2)=96 
       k(n+ild,3)=ild    
       k(n+ild,4)=0  
       k(n+ild,5)=0  
       DO 300 j=1,5  
       p(n+ild,j)=p(n+np+ild,j)  
   300 v(n+ild,j)=0. 
       CALL ludbrb(n+1,n+3,the,phi,0d0,0d0,0d0)  
     
 C...Select storing option. Calculate thurst and oblateness. 
       mstu(61)=n+1  
       mstu(62)=np   
       IF(mstu(43).LE.1) mstu(3)=3   
       IF(mstu(43).GE.2) n=n+3   
       thr=p(n+1,4)  
       obl=p(n+2,4)-p(n+3,4) 
     
       RETURN    

Here is the call graph for this function:

◆ luupda()

subroutine luupda	(	MUPDA,
		LFN
	)

Definition at line 5950 of file hipyset1.35.f.

     
 C...Purpose: to facilitate the updating of particle and decay data. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/ludat4/chaf(500)   
       CHARACTER chaf*8  
       SAVE /ludat4/ 
       CHARACTER chinl*80,chkc*4,chvar(19)*9,chlin*72,   
      &chblk(20)*72,chold*12,chtmp*12,chnew*12,chcom*12  
       DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',  
      &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',  
      &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ','KFDP(I,1)',  
      &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I)  '/  
     
 C...Write information on file for editing.  
       IF(mstu(12).GE.1) CALL lulist(0)  
       IF(mupda.EQ.1) THEN   
         DO 110 kc=1,mstu(6) 
         WRITE(lfn,1000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),   
      &  (pmas(kc,j2),j2=1,4),mdcy(kc,1) 
         DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1   
   100   WRITE(lfn,1100) mdme(idc,1),mdme(idc,2),brat(idc),  
      &  (kfdp(idc,j),j=1,5) 
   110   CONTINUE    
     
 C...Reset variables and read information from edited file.  
       ELSEIF(mupda.EQ.2) THEN   
         DO 120 i=1,mstu(7)  
         mdme(i,1)=1 
         mdme(i,2)=0 
         brat(i)=0.  
         DO 120 j=1,5    
   120   kfdp(i,j)=0 
         kc=0    
         idc=0   
         ndc=0   
   130   READ(lfn,1200,end=140) chinl    
         IF(chinl(2:5).NE.'    ') THEN   
           chkc=chinl(2:5)   
           IF(kc.NE.0) THEN  
             mdcy(kc,2)=0    
             IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc   
             mdcy(kc,3)=ndc  
           ENDIF 
           READ(chkc,1300) kc    
           IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,  
      &    '(LUUPDA:) Read KC code illegal, KC ='//chkc) 
           READ(chinl,1000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),   
      &    (pmas(kc,j2),j2=1,4),mdcy(kc,1)   
           ndc=0 
         ELSE    
           idc=idc+1 
           ndc=ndc+1 
           IF(idc.GE.mstu(7)) CALL luerrm(27,    
      &    '(LUUPDA:) Decay data arrays full by KC ='//chkc) 
           READ(chinl,1100) mdme(idc,1),mdme(idc,2),brat(idc),   
      &    (kfdp(idc,j),j=1,5)   
         ENDIF   
         GOTO 130    
   140   mdcy(kc,2)=0    
         IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc   
         mdcy(kc,3)=ndc  
     
 C...Perform possible tests that new information is consistent.  
         mstj24=mstj(24) 
         mstj(24)=0  
         DO 170 kc=1,mstu(6) 
         WRITE(chkc,1300) kc 
         IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),  
      &  pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,   
      &  '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)  
         brsum=0.    
         DO 160 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1   
         IF(mdme(idc,2).GT.80) GOTO 160  
         kq=kchg(kc,1)   
         pms=pmas(kc,1)-pmas(kc,3)-parj(64)  
         merr=0  
         DO 150 j=1,5    
         kp=kfdp(idc,j)  
         IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN  
         ELSEIF(lucomp(kp).EQ.0) THEN    
           merr=3    
         ELSE    
           kq=kq-luchge(kp)  
           pms=pms-ulmass(kp)    
         ENDIF   
   150   CONTINUE    
         IF(kq.NE.0) merr=max(2,merr)    
         IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND. 
      &  (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.  
      &  mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)   
         IF(merr.EQ.3) CALL luerrm(17,   
      &  '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)   
         IF(merr.EQ.2) CALL luerrm(17,   
      &  '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)    
         IF(merr.EQ.1) CALL luerrm(7,    
      &  '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)    
         brsum=brsum+brat(idc)   
   160   CONTINUE    
         WRITE(chtmp,1500) brsum 
         IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL   
      &  luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)// 
      &  ' for KC ='//chkc)  
   170   CONTINUE    
         mstj(24)=mstj24 
     
 C...Initialize writing of DATA statements for inclusion in program. 
       ELSEIF(mupda.EQ.3) THEN   
         DO 240 ivar=1,19    
         ndim=mstu(6)    
         IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)  
         nlin=1  
         chlin=' '   
         chlin(7:35)='DATA ('//chvar(ivar)//',I=   1,    )/' 
         llin=35 
         chold='START'   
     
 C...Loop through variables for conversion to characters.    
         DO 220 idim=1,ndim  
         IF(ivar.EQ.1) WRITE(chtmp,1400) kchg(idim,1)    
         IF(ivar.EQ.2) WRITE(chtmp,1400) kchg(idim,2)    
         IF(ivar.EQ.3) WRITE(chtmp,1400) kchg(idim,3)    
         IF(ivar.EQ.4) WRITE(chtmp,1500) pmas(idim,1)    
         IF(ivar.EQ.5) WRITE(chtmp,1500) pmas(idim,2)    
         IF(ivar.EQ.6) WRITE(chtmp,1500) pmas(idim,3)    
         IF(ivar.EQ.7) WRITE(chtmp,1500) pmas(idim,4)    
         IF(ivar.EQ.8) WRITE(chtmp,1400) mdcy(idim,1)    
         IF(ivar.EQ.9) WRITE(chtmp,1400) mdcy(idim,2)    
         IF(ivar.EQ.10) WRITE(chtmp,1400) mdcy(idim,3)   
         IF(ivar.EQ.11) WRITE(chtmp,1400) mdme(idim,1)   
         IF(ivar.EQ.12) WRITE(chtmp,1400) mdme(idim,2)   
         IF(ivar.EQ.13) WRITE(chtmp,1500) brat(idim) 
         IF(ivar.EQ.14) WRITE(chtmp,1400) kfdp(idim,1)   
         IF(ivar.EQ.15) WRITE(chtmp,1400) kfdp(idim,2)   
         IF(ivar.EQ.16) WRITE(chtmp,1400) kfdp(idim,3)   
         IF(ivar.EQ.17) WRITE(chtmp,1400) kfdp(idim,4)   
         IF(ivar.EQ.18) WRITE(chtmp,1400) kfdp(idim,5)   
         IF(ivar.EQ.19) chtmp=chaf(idim) 
     
 C...Length of variable, trailing decimal zeros, quotation marks.    
         llow=1  
         lhig=1  
         DO 180 ll=1,12  
         IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll    
   180   IF(chtmp(ll:ll).NE.' ') lhig=ll 
         chnew=chtmp(llow:lhig)//' ' 
         lnew=1+lhig-llow    
         IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN    
           lnew=lnew+1   
   190     lnew=lnew-1   
           IF(chnew(lnew:lnew).EQ.'0') GOTO 190  
           IF(lnew.EQ.1) chnew(1:2)='0.' 
           IF(lnew.EQ.1) lnew=2  
         ELSEIF(ivar.EQ.19) THEN 
           DO 200 ll=lnew,1,-1   
           IF(chnew(ll:ll).EQ.'''') THEN 
             chtmp=chnew 
             chnew=chtmp(1:ll)//''''//chtmp(ll+1:11) 
             lnew=lnew+1 
           ENDIF 
   200     CONTINUE  
           chtmp=chnew   
           chnew(1:lnew+2)=''''//chtmp(1:lnew)//'''' 
           lnew=lnew+2   
         ENDIF   
     
 C...Form composite character string, often including repetition counter.    
         IF(chnew.NE.chold) THEN 
           nrpt=1    
           chold=chnew   
           chcom=chnew   
           lcom=lnew 
         ELSE    
           lrpt=lnew+1   
           IF(nrpt.GE.2) lrpt=lnew+3 
           IF(nrpt.GE.10) lrpt=lnew+4    
           IF(nrpt.GE.100) lrpt=lnew+5   
           IF(nrpt.GE.1000) lrpt=lnew+6  
           llin=llin-lrpt    
           nrpt=nrpt+1   
           WRITE(chtmp,1400) nrpt    
           lrpt=1    
           IF(nrpt.GE.10) lrpt=2 
           IF(nrpt.GE.100) lrpt=3    
           IF(nrpt.GE.1000) lrpt=4   
           chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)    
           lcom=lrpt+1+lnew  
         ENDIF   
     
 C...Add characters to end of line, to new line (after storing old line),    
 C...or to new block of lines (after writing old block). 
         IF(llin+lcom.LE.70) THEN    
           chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','  
           llin=llin+lcom+1  
         ELSEIF(nlin.LE.19) THEN 
           chlin(llin+1:72)=' '  
           chblk(nlin)=chlin 
           nlin=nlin+1   
           chlin(6:6+lcom+1)='&'//chcom(1:lcom)//',' 
           llin=6+lcom+1 
         ELSE    
           chlin(llin:72)='/'//' '   
           chblk(nlin)=chlin 
           WRITE(chtmp,1400) idim-nrpt   
           chblk(1)(30:33)=chtmp(9:12)   
           DO 210 ilin=1,nlin    
   210     WRITE(lfn,1600) chblk(ilin)   
           nlin=1    
           chlin=' ' 
           chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I=    ,    )/'//  
      &    chcom(1:lcom)//','    
           WRITE(chtmp,1400) idim-nrpt+1 
           chlin(25:28)=chtmp(9:12)  
           llin=35+lcom+1    
         ENDIF   
   220   CONTINUE    
     
 C...Write final block of lines. 
         chlin(llin:72)='/'//' ' 
         chblk(nlin)=chlin   
         WRITE(chtmp,1400) ndim  
         chblk(1)(30:33)=chtmp(9:12) 
         DO 230 ilin=1,nlin  
   230   WRITE(lfn,1600) chblk(ilin) 
   240   CONTINUE    
       ENDIF 
     
 C...Formats for reading and writing particle data.  
  1000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)    
  1100 FORMAT(5x,2i5,f12.5,5i8)  
  1200 FORMAT(a80)   
  1300 FORMAT(i4)    
  1400 FORMAT(i12)   
  1500 FORMAT(f12.5) 
  1600 FORMAT(a72)   
     
       RETURN    

Here is the call graph for this function:

◆ lux3jt()

subroutine lux3jt	(	NJET,
		CUT,
		KFL,
		ECM,
		X1,
		X2
	)

Definition at line 8697 of file hipyset1.35.f.

     
 C...Purpose: to select the kinematical variables of three-jet events.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension zhup(5,12)  
     
 C...Coefficients of Zhu second order parametrization.   
       DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/  
      &    18.29,    89.56,    4.541,   -52.09,   -109.8,    24.90,  
      &    11.63,    3.683,    17.50, 0.002440,   -1.362,  -0.3537,  
      &    11.42,    6.299,   -22.55,   -8.915,    59.25,   -5.855,  
      &   -32.85,   -1.054,   -16.90, 0.006489,  -0.8156,  0.01095,  
      &    7.847,   -3.964,   -35.83,    1.178,    29.39,   0.2806,  
      &    47.82,   -12.36,   -56.72,  0.04054,  -0.4365,   0.6062,  
      &    5.441,   -56.89,   -50.27,    15.13,    114.3,   -18.19,  
      &    97.05,   -1.890,   -139.9,  0.08153,  -0.4984,   0.9439,  
      &   -17.65,    51.44,   -58.32,    70.95,   -255.7,   -78.99,  
      &    476.9,    29.65,   -239.3,   0.4745,   -1.174,    6.081/  
     
 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).  
       dilog(x)=x+x**2/4.+x**3/9.+x**4/16.+x**5/25.+x**6/36.+x**7/49.    
     
 C...Event type. Mass effect factors and other common constants. 
       mstj(120)=2   
       mstj(121)=0   
       pmq=ulmass(kfl)   
       qme=(2.*pmq/ecm)**2   
       IF(mstj(109).NE.1) THEN   
         cutl=log(cut)   
         cutd=log(1./cut-2.) 
         IF(mstj(109).EQ.0) THEN 
           cf=4./3.  
           cn=3. 
           tr=2. 
           wtmx=min(20.,37.-6.*cutd) 
           IF(mstj(110).EQ.2) wtmx=2.*(7.5+80.*cut)  
         ELSE    
           cf=1. 
           cn=0. 
           tr=12.    
           wtmx=0.   
         ENDIF   
     
 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.    
         als2pi=paru(118)/paru(2)    
         wtopt=0.    
         IF(mstj(111).EQ.1) wtopt=(33.-2.*mstu(112))/6.*log(parj(169))*  
      &  als2pi  
         wtmax=max(0.,1.+wtopt+als2pi*wtmx)  
     
 C...Choose three-jet events in allowed region.  
   100   njet=3  
   110   y13l=cutl+cutd*rlu(0)   
         y23l=cutl+cutd*rlu(0)   
         y13=exp(y13l)   
         y23=exp(y23l)   
         y12=1.-y13-y23  
         IF(y12.LE.cut) GOTO 110 
         IF(y13**2+y23**2+2.*y12.LE.2.*rlu(0)) GOTO 110  
     
 C...Second order corrections.   
         IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN  
           y12l=log(y12) 
           y13m=log(1.-y13)  
           y23m=log(1.-y23)  
           y12m=log(1.-y12)  
           IF(y13.LE.0.5) y13i=dilog(y13)    
           IF(y13.GE.0.5) y13i=1.644934-y13l*y13m-dilog(1.-y13)  
           IF(y23.LE.0.5) y23i=dilog(y23)    
           IF(y23.GE.0.5) y23i=1.644934-y23l*y23m-dilog(1.-y23)  
           IF(y12.LE.0.5) y12i=dilog(y12)    
           IF(y12.GE.0.5) y12i=1.644934-y12l*y12m-dilog(1.-y12)  
           wt1=(y13**2+y23**2+2.*y12)/(y13*y23)  
           wt2=cf*(-2.*(cutl-y12l)**2-3.*cutl-1.+3.289868+   
      &    2.*(2.*cutl-y12l)*cut/y12)+   
      &    cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-11.*cutl/6.+ 
      &    67./18.+1.644934-(2.*cutl-y12l)*cut/y12+(2.*cutl-y13l)*   
      &    cut/y13+(2.*cutl-y23l)*cut/y23)+  
      &    tr*(2.*cutl/3.-10./9.)+   
      &    cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+  
      &    y13l*(4.*y12**2+2.*y12*y13+4.*y12*y23+y13*y23)/(y12+y23)**2+  
      &    y23l*(4.*y12**2+2.*y12*y23+4.*y12*y13+y13*y23)/(y12+y13)**2)/ 
      &    wt1+  
      &    cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+   
      &    (cn-2.*cf)*((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*  
      &    y23m+1.644934-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)* 
      &    (y12l*y13l-y12l*y12m-y13l*y13m+1.644934-y12i-y13i)/   
      &    (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-    
      &    2.*y12l*y12**2/(y13+y23)**2-4.*y12l*y12/(y13+y23))/wt1-   
      &    cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934-y13i-y23i) 
           IF(1.+wtopt+als2pi*wt2.LE.0.) mstj(121)=1 
           IF(1.+wtopt+als2pi*wt2.LE.wtmax*rlu(0)) GOTO 110  
           parj(156)=(wtopt+als2pi*wt2)/(1.+wtopt+als2pi*wt2)    
     
         ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN  
 C...Second order corrections; Zhu parametrization of ERT.   
           zx=(y23-y13)**2   
           zy=1.-y12 
           iza=0 
           DO 120 iy=1,5 
   120     IF(abs(cut-0.01*iy).LT.0.0001) iza=iy 
           IF(iza.NE.0) THEN 
             iz=iza  
             wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+  
      &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+ 
      &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+    
      &      zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy  
           ELSE  
             iz=100.*cut 
             wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+  
      &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+ 
      &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+    
      &      zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy  
             iz=iz+1 
             wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+  
      &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+ 
      &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+    
      &      zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy  
             wt2=wtl+(wtu-wtl)*(100.*cut+1.-iz)  
           ENDIF 
           IF(1.+wtopt+2.*als2pi*wt2.LE.0.) mstj(121)=1  
           IF(1.+wtopt+2.*als2pi*wt2.LE.wtmax*rlu(0)) GOTO 110   
           parj(156)=(wtopt+2.*als2pi*wt2)/(1.+wtopt+2.*als2pi*wt2)  
         ENDIF   
     
 C...Impose mass cuts (gives two jets). For fixed jet number new try.    
         x1=1.-y23   
         x2=1.-y13   
         x3=1.-y12   
         IF(4.*y23*y13*y12/x3**2.LE.qme) njet=2  
         IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+   
      &  0.5*qme**2+(0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+  
      &  (1.-x1)/(1.-x2)).GT.(x1**2+x2**2)*rlu(0)) njet=2    
         IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 100  
     
 C...Scalar gluon model (first order only, no mass effects). 
       ELSE  
   130   njet=3  
   140   y12=sqrt(4.*cut**2+rlu(0)*((1.-cut)**2-4.*cut**2))  
         IF(log((y12-cut)/cut).LE.rlu(0)*log((1.-2.*cut)/cut)) GOTO 140  
         yd=sign(2.*cut*((y12-cut)/cut)**rlu(0)-y12,rlu(0)-0.5)  
         x1=1.-0.5*(y12+yd)  
         x2=1.-0.5*(y12-yd)  
         IF(4.*(1.-x1)*(1.-x2)*y12/(1.-y12)**2.LE.qme) njet=2    
         IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 130  
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ lux4jt()

subroutine lux4jt	(	NJET,
		CUT,
		KFL,
		ECM,
		KFLN,
		X1,
		X2,
		X4,
		X12,
		X14
	)

Definition at line 8850 of file hipyset1.35.f.

     
 C...Purpose: to select the kinematical variables of four-jet events.    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)  
     
 C...Common constants. Colour factors for QCD and Abelian gluon theory.  
       pmq=ulmass(kfl)   
       qme=(2.*pmq/ecm)**2   
       ct=log(1./cut-5.) 
       IF(mstj(109).EQ.0) THEN   
         cf=4./3.    
         cn=3.   
         tr=2.   
       ELSE  
         cf=1.   
         cn=0.   
         tr=12.  
       ENDIF 
     
 C...Choice of process (qqbargg or qqbarqqbar).  
   100 njet=4    
       it=1  
       IF(parj(155).GT.rlu(0)) it=2  
       IF(mstj(101).LE.-3) it=-mstj(101)-2   
       IF(it.EQ.1) wtmx=0.7/cut**2   
       IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6/cut**2    
       IF(it.EQ.2) wtmx=0.1125*cf*tr/cut**2  
       id=1  
     
 C...Sample the five kinematical variables (for qqgg preweighted in y34).    
   110 y134=3.*cut+(1.-6.*cut)*rlu(0)    
       y234=3.*cut+(1.-6.*cut)*rlu(0)    
       IF(it.EQ.1) y34=(1.-5.*cut)*exp(-ct*rlu(0))   
       IF(it.EQ.2) y34=cut+(1.-6.*cut)*rlu(0)    
       IF(y34.LE.y134+y234-1..OR.y34.GE.y134*y234) GOTO 110  
       vt=rlu(0) 
       cp=cos(paru(1)*rlu(0))    
       y14=(y134-y34)*vt 
       y13=y134-y14-y34  
       vb=y34*(1.-y134-y234+y34)/((y134-y34)*(y234-y34)) 
       y24=0.5*(y234-y34)*(1.-4.*sqrt(max(0.,vt*(1.-vt)*vb*(1.-vb)))*    
      &cp-(1.-2.*vt)*(1.-2.*vb)) 
       y23=y234-y34-y24  
       y12=1.-y134-y23-y24   
       IF(min(y12,y13,y14,y23,y24).LE.cut) GOTO 110  
       y123=y12+y13+y23  
       y124=y12+y14+y24  
     
 C...Calculate matrix elements for qqgg or qqqq process. 
       ic=0  
       wttot=0.  
   120 ic=ic+1   
       IF(it.EQ.1) THEN  
         wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3.*y12*y23*y34+ 
      &  3.*y12*y14*y34+4.*y12**2*y34-y13*y23*y24+2.*y12*y23*y24-    
      &  y13*y14*y24-2.*y12*y13*y24+2.*y12**2*y24+y14*y23**2+2.*y12* 
      &  y23**2+y14**2*y23+4.*y12*y14*y23+4.*y12**2*y23+2.*y12*y14**2+   
      &  2.*y12*y13*y14+4.*y12**2*y14+2.*y12**2*y13+2.*y12**3)/(2.*y13*  
      &  y134*y234*y24)+(y24*y34+y12*y34+y13*y24-y14*y23+y12*y13)/(y13*  
      &  y134**2)+2.*y23*(1.-y13)/(y13*y134*y24)+y34/(2.*y13*y24)    
         wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2.*y12* 
      &  y14*y24)/(y13*y134*y23*y14)+y12*(1.+y34)*y124/(y134*y234*y14*   
      &  y24)-(2.*y13*y24+y14**2+y13*y23+2.*y12*y13)/(y13*y134*y14)+ 
      &  y12*y123*y124/(2.*y13*y14*y23*y24)  
         wtc(ic)=-(5.*y12*y34**2+2.*y12*y24*y34+2.*y12*y23*y34+2.*y12*   
      &  y14*y34+2.*y12*y13*y34+4.*y12**2*y34-y13*y24**2+y14*y23*y24+    
      &  y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-3.*y12*y13*y24-  
      &  y14*y23**2-y14**2*y23+y13*y14*y23-3.*y12*y14*y23-y12*y13*y23)/  
      &  (4.*y134*y234*y34**2)+(3.*y12*y34**2-3.*y13*y24*y34+3.*y12*y24* 
      &  y34+3.*y14*y23*y34-y13*y24**2-y12*y23*y34+6.*y12*y14*y34+2.*y12*    
      &  y13*y34-2.*y12**2*y34+y14*y23*y24-3.*y13*y23*y24-2.*y13*y14*    
      &  y24+4.*y12*y14*y24+2.*y12*y13*y24+3.*y14*y23**2+2.*y14**2*y23+  
      &  2.*y14**2*y12+2.*y12**2*y14+6.*y12*y14*y23-2.*y12*y13**2-   
      &  2.*y12**2*y13)/(4.*y13*y134*y234*y34)   
         wtc(ic)=wtc(ic)+(2.*y12*y34**2-2.*y13*y24*y34+y12*y24*y34+  
      &  4.*y13*y23*y34+4.*y12*y14*y34+2.*y12*y13*y34+2.*y12**2*y34- 
      &  y13*y24**2+3.*y14*y23*y24+4.*y13*y23*y24-2.*y13*y14*y24+    
      &  4.*y12*y14*y24+2.*y12*y13*y24+2.*y14*y23**2+4.*y13*y23**2+  
      &  2.*y13*y14*y23+2.*y12*y14*y23+4.*y12*y13*y23+2.*y12*y14**2+4.*  
      &  y12**2*y13+4.*y12*y13*y14+2.*y12**2*y14)/(4.*y13*y134*y24*y34)- 
      &  (y12*y34**2-2.*y14*y24*y34-2.*y13*y24*y34-y14*y23*y34+y13*y23*  
      &  y34+y12*y14*y34+2.*y12*y13*y34-2.*y14**2*y24-4.*y13*y14*y24-    
      &  4.*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-y12*y13**2)/    
      &  (2.*y13*y34*y134**2)+(y12*y34**2-4.*y14*y24*y34-2.*y13*y24*y34- 
      &  2.*y14*y23*y34-4.*y13*y23*y34-4.*y12*y14*y34-4.*y12*y13*y34-    
      &  2.*y13*y14*y24+2.*y13**2*y24+2.*y14**2*y23-2.*y13*y14*y23-  
      &  y12*y14**2-6.*y12*y13*y14-y12*y13**2)/(4.*y34**2*y134**2)   
         wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5*cn)*wtb(ic)+cn*wtc(ic))/ 
      &  8.  
       ELSE  
         wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2.*y12* 
      &  y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*    
      &  y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*   
      &  y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*  
      &  y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+ 
      &  y13*y14*y24+2.*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+  
      &  y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*  
      &  y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24- 
      &  y13**2*y24+y23*y14**2)/(y13**2*y134*y123)   
         wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*  
      &  y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23* 
      &  y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*  
      &  y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+   
      &  (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+  
      &  y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*    
      &  y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*   
      &  y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)    
         wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5*cn)*wte(ic))/16. 
       ENDIF 
     
 C...Permutations of momenta in matrix element. Weighting.   
   130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN 
         ysav=y13    
         y13=y14 
         y14=ysav    
         ysav=y23    
         y23=y24 
         y24=ysav    
         ysav=y123   
         y123=y124   
         y124=ysav   
       ENDIF 
       IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN 
         ysav=y13    
         y13=y23 
         y23=ysav    
         ysav=y14    
         y14=y24 
         y24=ysav    
         ysav=y134   
         y134=y234   
         y234=ysav   
       ENDIF 
       IF(ic.LE.3) GOTO 120  
       IF(id.EQ.1.AND.wttot.LT.rlu(0)*wtmx) GOTO 110 
       ic=5  
     
 C...qqgg events: string configuration and event type.   
       IF(it.EQ.1) THEN  
         IF(mstj(109).EQ.0.AND.id.EQ.1) THEN 
           parj(156)=y34*(2.*(wta(1)+wta(2)+wta(3)+wta(4))+4.*(wtc(1)+   
      &    wtc(2)+wtc(3)+wtc(4)))/(9.*wttot) 
           IF(wta(2)+wta(4)+2.*(wtc(2)+wtc(4)).GT.rlu(0)*(wta(1)+wta(2)+ 
      &    wta(3)+wta(4)+2.*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2 
           IF(id.EQ.2) GOTO 130  
         ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN 
           parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8.*wttot)    
           IF(wta(2)+wta(4).GT.rlu(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2    
           IF(id.EQ.2) GOTO 130  
         ENDIF   
         mstj(120)=3 
         IF(mstj(109).EQ.0.AND.0.5*y34*(wtc(1)+wtc(2)+wtc(3)+wtc(4)).GT. 
      &  rlu(0)*wttot) mstj(120)=4   
         kfln=21 
     
 C...Mass cuts. Kinematical variables out.   
         IF(y12.LE.cut+qme) njet=2   
         IF(njet.EQ.2) GOTO 150  
         q12=0.5*(1.-sqrt(1.-qme/y12))   
         x1=1.-(1.-q12)*y234-q12*y134    
         x4=1.-(1.-q12)*y134-q12*y234    
         x2=1.-y124  
         x12=(1.-q12)*y13+q12*y23    
         x14=y12-0.5*qme 
         IF(y134*y234/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2    
     
 C...qqbarqqbar events: string configuration, choose new flavour.    
       ELSE  
         IF(id.EQ.1) THEN    
           wtr=rlu(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))  
           IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2  
           IF(wtr.LT.wtd(3)+wtd(4)) id=3 
           IF(wtr.LT.wtd(4)) id=4    
           IF(id.GE.2) GOTO 130  
         ENDIF   
         mstj(120)=5 
         parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16.*wttot)   
   140   kfln=1+int(5.*rlu(0))   
         IF(kfln.NE.kfl.AND.0.2*parj(156).LE.rlu(0)) GOTO 140    
         IF(kfln.EQ.kfl.AND.1.-0.8*parj(156).LE.rlu(0)) GOTO 140 
         IF(kfln.GT.mstj(104)) njet=2    
         pmqn=ulmass(kfln)   
         qmen=(2.*pmqn/ecm)**2   
     
 C...Mass cuts. Kinematical variables out.   
         IF(y24.LE.cut+qme.OR.y13.LE.1.1*qmen) njet=2    
         IF(njet.EQ.2) GOTO 150  
         q24=0.5*(1.-sqrt(1.-qme/y24))   
         q13=0.5*(1.-sqrt(1.-qmen/y13))  
         x1=1.-(1.-q24)*y123-q24*y134    
         x4=1.-(1.-q24)*y134-q24*y123    
         x2=1.-(1.-q13)*y234-q13*y124    
         x12=(1.-q24)*((1.-q13)*y14+q13*y34)+q24*((1.-q13)*y12+q13*y23)  
         x14=y24-0.5*qme 
         x34=(1.-q24)*((1.-q13)*y23+q13*y12)+q24*((1.-q13)*y34+q13*y14)  
         IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.   
      &  (parj(127)+pmq+pmqn)**2) njet=2 
         IF(y123*y134/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2    
       ENDIF 
   150 IF(mstj(101).LE.-2.AND.njet.EQ.2) GOTO 100    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luxdif()

subroutine luxdif	(	NC,
		NJET,
		KFL,
		ECM,
		CHI,
		THE,
		PHI
	)

Definition at line 9058 of file hipyset1.35.f.

     
 C...Purpose: to give the angular orientation of events. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Charge. Factors depending on polarization for QED case. 
       qf=kchg(kfl,1)/3. 
       poll=1.-parj(131)*parj(132)   
       pold=parj(132)-parj(131)  
       IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN 
         hf1=poll    
         hf2=0.  
         hf3=parj(133)**2    
         hf4=0.  
     
 C...Factors depending on flavour, energy and polarization for QFD case. 
       ELSE  
         sff=1./(16.*paru(102)*(1.-paru(102)))   
         sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)  
         sfi=sfw*(1.-(parj(123)/ecm)**2) 
         ae=-1.  
         ve=4.*paru(102)-1.  
         af=sign(1.,qf)  
         vf=af-4.*qf*paru(102)   
         hf1=qf**2*poll-2.*qf*vf*sfi*sff*(ve*poll-ae*pold)+  
      &  (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2.*ve*ae*pold) 
         hf2=-2.*qf*af*sfi*sff*(ae*poll-ve*pold)+2.*vf*af*sfw*sff**2*    
      &  (2.*ve*ae*poll-(ve**2+ae**2)*pold)  
         hf3=parj(133)**2*(qf**2-2.*qf*vf*sfi*sff*ve+(vf**2+af**2)*  
      &  sfw*sff**2*(ve**2-ae**2))   
         hf4=-parj(133)**2*2.*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*    
      &  sff*ae  
       ENDIF 
     
 C...Mass factor. Differential cross-sections for two-jet events.    
       sq2=sqrt(2.)  
       qme=0.    
       IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.    
      &mstj(109).NE.1) qme=(2.*ulmass(kfl)/ecm)**2   
       IF(njet.EQ.2) THEN    
         sigu=4.*sqrt(1.-qme)    
         sigl=2.*qme*sqrt(1.-qme)    
         sigt=0. 
         sigi=0. 
         siga=0. 
         sigp=4. 
     
 C...Kinematical variables. Reduce four-jet event to three-jet one.  
       ELSE  
         IF(njet.EQ.3) THEN  
           x1=2.*p(nc+1,4)/ecm   
           x2=2.*p(nc+3,4)/ecm   
         ELSE    
           ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+   
      &    (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)    
           x1=2.*p(nc+1,4)/ecmr  
           x2=2.*p(nc+4,4)/ecmr  
         ENDIF   
     
 C...Differential cross-sections for three-jet (or reduced four-jet).    
         xq=(1.-x1)/(1.-x2)  
         ct12=(x1*x2-2.*x1-2.*x2+2.+qme)/sqrt((x1**2-qme)*(x2**2-qme))   
         st12=sqrt(1.-ct12**2)   
         IF(mstj(109).NE.1) THEN 
           sigu=2.*x1**2+x2**2*(1.+ct12**2)-qme*(3.+ct12**2-x1-x2)-  
      &    qme*x1/xq+0.5*qme*((x2**2-qme)*st12**2-2.*x2)*xq  
           sigl=(x2*st12)**2-qme*(3.-ct12**2-2.5*(x1+x2)+x1*x2+qme)+ 
      &    0.5*qme*(x1**2-x1-qme)/xq+0.5*qme*((x2**2-qme)*ct12**2-x2)*xq 
           sigt=0.5*(x2**2-qme-0.5*qme*(x2**2-qme)/xq)*st12**2   
           sigi=((1.-0.5*qme*xq)*(x2**2-qme)*st12*ct12+qme*(1.-x1-x2+    
      &    0.5*x1*x2+0.5*qme)*st12/ct12)/sq2 
           siga=x2**2*st12/sq2   
           sigp=2.*(x1**2-x2**2*ct12)    
     
 C...Differential cross-sect for scalar gluons (no mass or QFD effects). 
         ELSE    
           sigu=2.*(2.-x1-x2)**2-(x2*st12)**2    
           sigl=(x2*st12)**2 
           sigt=0.5*sigl 
           sigi=-(2.-x1-x2)*x2*st12/sq2  
           siga=0.   
           sigp=0.   
         ENDIF   
       ENDIF 
     
 C...Upper bounds for differential cross-section.    
       hf1a=abs(hf1) 
       hf2a=abs(hf2) 
       hf3a=abs(hf3) 
       hf4a=abs(hf4) 
       sigmax=(2.*hf1a+hf3a+hf4a)*abs(sigu)+2.*(hf1a+hf3a+hf4a)* 
      &abs(sigl)+2.*(hf1a+2.*hf3a+2.*hf4a)*abs(sigt)+2.*sq2* 
      &(hf1a+2.*hf3a+2.*hf4a)*abs(sigi)+4.*sq2*hf2a*abs(siga)+   
      &2.*hf2a*abs(sigp) 
     
 C...Generate angular orientation according to differential cross-sect.  
   100 chi=paru(2)*rlu(0)    
       cthe=2.*rlu(0)-1. 
       phi=paru(2)*rlu(0)    
       cchi=cos(chi) 
       schi=sin(chi) 
       c2chi=cos(2.*chi) 
       s2chi=sin(2.*chi) 
       the=acos(cthe)    
       sthe=sin(the) 
       c2phi=cos(2.*(phi-parj(134))) 
       s2phi=sin(2.*(phi-parj(134))) 
       sig=((1.+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+    
      &2.*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+  
      &2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*c2chi*c2phi-2.*cthe*s2chi*    
      &s2phi)*hf3-((1.+cthe**2)*c2chi*s2phi+2.*cthe*s2chi*c2phi)*hf4)*   
      &sigt-2.*sq2*(2.*sthe*cthe*cchi*hf1-2.*sthe*(cthe*cchi*c2phi-  
      &schi*s2phi)*hf3+2.*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+   
      &4.*sq2*sthe*cchi*hf2*siga+2.*cthe*hf2*sigp    
       IF(sig.LT.sigmax*rlu(0)) GOTO 100 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luxjet()

subroutine luxjet	(	ECM,
		NJET,
		CUT
	)

Definition at line 8525 of file hipyset1.35.f.

     
 C...Purpose: to select number of jets in matrix element approach.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension zhut(5) 
     
 C...Relative three-jet rate in Zhu second order parametrization.    
       DATA zhut/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/ 
     
 C...Trivial result for two-jets only, including parton shower.  
       IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN 
         cut=0.  
     
 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.    
       ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN 
         cf=4./3.    
         IF(mstj(109).EQ.2) cf=1.    
         IF(mstj(111).EQ.0) THEN 
           q2=ecm**2 
           q2r=ecm**2    
         ELSEIF(mstu(111).EQ.0) THEN 
           parj(169)=min(1.,parj(129))   
           q2=parj(169)*ecm**2   
           parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/  
      &    ((33.-2.*mstu(112))*paru(111))))) 
           q2r=parj(168)*ecm**2  
         ELSE    
           parj(169)=min(1.,max(parj(129),(2.*paru(112)/ecm)**2))    
           q2=parj(169)*ecm**2   
           parj(168)=min(1.,max(parj(128),paru(112)/ecm, 
      &    (2.*paru(112)/ecm)**2))   
           q2r=parj(168)*ecm**2  
         ENDIF   
     
 C...alpha_strong for R and R itself.    
         alspi=(3./4.)*cf*ulalps(q2r)/paru(1)    
         IF(iabs(mstj(101)).EQ.1) THEN   
           rqcd=1.+alspi 
         ELSEIF(mstj(109).EQ.0) THEN 
           rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2    
           IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*   
      &    log(parj(168))*alspi**2)  
         ELSE    
           rqcd=1.+alspi-(3./32.+0.519*mstu(118))*(4.*alspi/3.)**2   
         ENDIF   
     
 C...alpha_strong for jet rate. Initial value for y cut. 
         alspi=(3./4.)*cf*ulalps(q2)/paru(1) 
         cut=max(0.001,parj(125),(parj(126)/ecm)**2) 
         IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0)) 
      &  cut=max(cut,exp(-sqrt(0.75/alspi))/2.)  
         IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))  
     
 C...Parametrization of first order three-jet cross-section. 
   100   IF(mstj(101).EQ.0.OR.cut.GE.0.25) THEN  
           parj(152)=0.  
         ELSE    
           parj(152)=(2.*alspi/3.)*((3.-6.*cut+2.*log(cut))* 
      &    log(cut/(1.-2.*cut))+(2.5+1.5*cut-6.571)*(1.-3.*cut)+ 
      &    5.833*(1.-3.*cut)**2-3.894*(1.-3.*cut)**3+    
      &    1.342*(1.-3.*cut)**4)/rqcd    
           IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))    
      &    parj(152)=0.  
         ENDIF   
     
 C...Parametrization of second order three-jet cross-section.    
         IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR. 
      &  cut.GE.0.25) THEN   
           parj(153)=0.  
         ELSEIF(mstj(110).LE.1) THEN 
           ct=log(1./cut-2.) 
           parj(153)=alspi**2*ct**2*(2.419+0.5989*ct+0.6782*ct**2-   
      &    0.2661*ct**3+0.01159*ct**4)/rqcd  
     
 C...Interpolation in second/first order ratio for Zhu parametrization.  
         ELSEIF(mstj(110).EQ.2) THEN 
           iza=0 
           DO 110 iy=1,5 
   110     IF(abs(cut-0.01*iy).LT.0.0001) iza=iy 
           IF(iza.NE.0) THEN 
             zhurat=zhut(iza)    
           ELSE  
             iz=100.*cut 
             zhurat=zhut(iz)+(100.*cut-iz)*(zhut(iz+1)-zhut(iz)) 
           ENDIF 
           parj(153)=alspi*parj(152)*zhurat  
         ENDIF   
     
 C...Shift in second order three-jet cross-section with optimized Q^2.   
         IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3.  
      &  and.cut.LT.0.25) parj(153)=parj(153)+(33.-2.*mstu(112))/12.*    
      &  log(parj(169))*alspi*parj(152)  
     
 C...Parametrization of second order four-jet cross-section. 
         IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125) THEN   
           parj(154)=0.  
         ELSE    
           ct=log(1./cut-5.) 
           IF(cut.LE.0.018) THEN 
             xqqgg=6.349-4.330*ct+0.8304*ct**2   
             IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(3.035-2.091*ct+    
      &      0.4059*ct**2)   
             xqqqq=1.25*(-0.1080+0.01486*ct+0.009364*ct**2)  
             IF(mstj(109).EQ.2) xqqqq=8.*xqqqq   
           ELSE  
             xqqgg=-0.09773+0.2959*ct-0.2764*ct**2+0.08832*ct**3 
             IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(-0.04079+0.1340*ct-    
      &      0.1326*ct**2+0.04365*ct**3) 
             xqqqq=1.25*(0.003661-0.004888*ct-0.001081*ct**2+0.002093*   
      &      ct**3)  
             IF(mstj(109).EQ.2) xqqqq=8.*xqqqq   
           ENDIF 
           parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd   
           parj(155)=xqqqq/(xqqgg+xqqqq) 
         ENDIF   
     
 C...If negative three-jet rate, change y' optimization parameter.   
         IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0..AND.    
      &  parj(169).LT.0.99) THEN 
           parj(169)=min(1.,1.2*parj(169))   
           q2=parj(169)*ecm**2   
           alspi=(3./4.)*cf*ulalps(q2)/paru(1)   
           GOTO 100  
         ENDIF   
     
 C...If too high cross-section, use harder cuts, or fail.    
         IF(parj(152)+parj(153)+parj(154).GE.1) THEN 
           IF(mstj(110).EQ.2.AND.cut.GT.0.0499.AND.mstj(111).EQ.1.AND.   
      &    parj(169).LT.0.99) THEN   
             parj(169)=min(1.,1.2*parj(169)) 
             q2=parj(169)*ecm**2 
             alspi=(3./4.)*cf*ulalps(q2)/paru(1) 
             GOTO 100    
           ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499) THEN 
             CALL luerrm(26, 
      &      '(LUXJET:) no allowed y cut value for Zhu parametrization') 
           ENDIF 
           cut=0.26*(4.*cut)**(parj(152)+parj(153)+parj(154))**(-1./3.)  
           IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))    
           GOTO 100  
         ENDIF   
     
 C...Scalar gluon (first order only).    
       ELSE  
         alspi=ulalps(ecm**2)/paru(1)    
         cut=max(0.001,parj(125),(parj(126)/ecm)**2,exp(-3./alspi))  
         parj(152)=0.    
         IF(cut.LT.0.25) parj(152)=(alspi/3.)*((1.-2.*cut)*  
      &  log((1.-2.*cut)/cut)+0.5*(9.*cut**2-1.))    
         parj(153)=0.    
         parj(154)=0.    
       ENDIF 
     
 C...Select number of jets.  
       parj(150)=cut 
       IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN 
         njet=2  
       ELSEIF(mstj(101).LE.0) THEN   
         njet=min(4,2-mstj(101)) 
       ELSE  
         rnj=rlu(0)  
         njet=2  
         IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3 
         IF(parj(154).GT.rnj) njet=4 
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luxkfl()

subroutine luxkfl	(	KFL,
		ECM,
		ECMC,
		KFLC
	)

Definition at line 8459 of file hipyset1.35.f.

     
 C...Purpose: to select flavour for produced qqbar pair. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Calculate maximum weight in QED or QFD case.    
       IF(mstj(102).LE.1) THEN   
         rfmax=4./9. 
       ELSE  
         poll=1.-parj(131)*parj(132) 
         sff=1./(16.*paru(102)*(1.-paru(102)))   
         sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)    
         sfi=sfw*(1.-(parj(123)/ecmc)**2)    
         ve=4.*paru(102)-1.  
         hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))  
         hf1w=sfw*sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))   
         rfmax=max(4./9.*poll-4./3.*(1.-8.*paru(102)/3.)*hf1i+   
      &  ((1.-8.*paru(102)/3.)**2+1.)*hf1w,1./9.*poll+2./3.* 
      &  (-1.+4.*paru(102)/3.)*hf1i+((-1.+4.*paru(102)/3.)**2+1.)*hf1w)  
       ENDIF 
     
 C...Choose flavour. Gives charge and velocity.  
       ntry=0    
   100 ntry=ntry+1   
       IF(ntry.GT.100) THEN  
         CALL luerrm(14,'(LUXKFL:) caught in an infinite loop')  
         kflc=0  
         RETURN  
       ENDIF 
       kflc=kfl  
       IF(kfl.LE.0) kflc=1+int(mstj(104)*rlu(0)) 
       mstj(93)=1    
       pmq=ulmass(kflc)  
       IF(ecm.LT.2.*pmq+parj(127)) GOTO 100  
       qf=kchg(kflc,1)/3.    
       vq=1. 
       IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*pmq/ecmc)**2))    
     
 C...Calculate weight in QED or QFD case.    
       IF(mstj(102).LE.1) THEN   
         rf=qf**2    
         rfv=0.5*vq*(3.-vq**2)*qf**2 
       ELSE  
         vf=sign(1.,qf)-4.*qf*paru(102)  
         rf=qf**2*poll-2.*qf*vf*hf1i+(vf**2+1.)*hf1w 
         rfv=0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+vf**2*hf1w)+    
      &  vq**3*hf1w  
       ENDIF 
     
 C...Weighting or new event (radiative photon). Cross-section update.    
       IF(kfl.LE.0.AND.rf.LT.rlu(0)*rfmax) GOTO 100  
       parj(158)=parj(158)+1.    
       IF(ecmc.LT.2.*pmq+parj(127).OR.rfv.LT.rlu(0)*rf) kflc=0   
       IF(mstj(107).LE.0.AND.kflc.EQ.0) GOTO 100 
       IF(kflc.NE.0) parj(159)=parj(159)+1.  
       parj(144)=parj(157)*parj(159)/parj(158)   
       parj(148)=parj(144)*86.8/ecm**2   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luxtot()

subroutine luxtot	(	KFL,
		ECM,
		XTOT
	)

Definition at line 8233 of file hipyset1.35.f.

     
 C...Purpose: to calculate total cross-section, including initial    
 C...state radiation effects.    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Status, (optimized) Q^2 scale, alpha_strong.    
       parj(151)=ecm 
       mstj(119)=10*mstj(102)+kfl    
       IF(mstj(111).EQ.0) THEN   
         q2r=ecm**2  
       ELSEIF(mstu(111).EQ.0) THEN   
         parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/    
      &  ((33.-2.*mstu(112))*paru(111)))))   
         q2r=parj(168)*ecm**2    
       ELSE  
         parj(168)=min(1.,max(parj(128),paru(112)/ecm,   
      &  (2.*paru(112)/ecm)**2)) 
         q2r=parj(168)*ecm**2    
       ENDIF 
       alspi=ulalps(q2r)/paru(1) 
     
 C...QCD corrections factor in R.    
       IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN 
         rqcd=1. 
       ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN  
         rqcd=1.+alspi   
       ELSEIF(mstj(109).EQ.0) THEN   
         rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2  
         IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.* 
      &  log(parj(168))*alspi**2)    
       ELSEIF(iabs(mstj(101)).EQ.1) THEN 
         rqcd=1.+(3./4.)*alspi   
       ELSE  
         rqcd=1.+(3./4.)*alspi-(3./32.+0.519*mstu(118))*alspi**2 
       ENDIF 
     
 C...Calculate Z0 width if default value not acceptable. 
       IF(mstj(102).GE.3) THEN   
         rva=3.*(3.+(4.*paru(102)-1.)**2)+6.*rqcd*(2.+(1.-8.*paru(102)/  
      &  3.)**2+(4.*paru(102)/3.-1.)**2) 
         DO 100 kflc=5,6 
         vq=1.   
         IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*ulmass(kflc)/   
      &  ecm)**2))   
         IF(kflc.EQ.5) vf=4.*paru(102)/3.-1. 
         IF(kflc.EQ.6) vf=1.-8.*paru(102)/3. 
   100   rva=rva+3.*rqcd*(0.5*vq*(3.-vq**2)*vf**2+vq**3) 
         parj(124)=paru(101)*parj(123)*rva/(48.*paru(102)*(1.-paru(102)))    
       ENDIF 
     
 C...Calculate propagator and related constants for QFD case.    
       poll=1.-parj(131)*parj(132)   
       IF(mstj(102).GE.2) THEN   
         sff=1./(16.*paru(102)*(1.-paru(102)))   
         sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)  
         sfi=sfw*(1.-(parj(123)/ecm)**2) 
         ve=4.*paru(102)-1.  
         sf1i=sff*(ve*poll+parj(132)-parj(131))  
         sf1w=sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))   
         hf1i=sfi*sf1i   
         hf1w=sfw*sf1w   
       ENDIF 
     
 C...Loop over different flavours: charge, velocity. 
       rtot=0.   
       rqq=0.    
       rqv=0.    
       rva=0.    
       DO 110 kflc=1,max(mstj(104),kfl)  
       IF(kfl.GT.0.AND.kflc.NE.kfl) GOTO 110 
       mstj(93)=1    
       pmq=ulmass(kflc)  
       IF(ecm.LT.2.*pmq+parj(127)) GOTO 110  
       qf=kchg(kflc,1)/3.    
       vq=1. 
       IF(mod(mstj(103),2).EQ.1) vq=sqrt(1.-(2.*pmq/ecm)**2) 
     
 C...Calculate R and sum of charges for QED or QFD case. 
       rqq=rqq+3.*qf**2*poll 
       IF(mstj(102).LE.1) THEN   
         rtot=rtot+3.*0.5*vq*(3.-vq**2)*qf**2*poll   
       ELSE  
         vf=sign(1.,qf)-4.*qf*paru(102)  
         rqv=rqv-6.*qf*vf*sf1i   
         rva=rva+3.*(vf**2+1.)*sf1w  
         rtot=rtot+3.*(0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+  
      &  vf**2*hf1w)+vq**3*hf1w) 
       ENDIF 
   110 CONTINUE  
       rsum=rqq  
       IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva   
     
 C...Calculate cross-section, including QCD corrections. 
       parj(141)=rqq 
       parj(142)=rtot    
       parj(143)=rtot*rqcd   
       parj(144)=parj(143)   
       parj(145)=parj(141)*86.8/ecm**2   
       parj(146)=parj(142)*86.8/ecm**2   
       parj(147)=parj(143)*86.8/ecm**2   
       parj(148)=parj(147)   
       parj(157)=rsum*rqcd   
       parj(158)=0.  
       parj(159)=0.  
       xtot=parj(147)    
       IF(mstj(107).LE.0) RETURN 
     
 C...Virtual cross-section.  
       xkl=parj(135) 
       xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)   
       ale=2.*log(ecm/ulmass(11))-1. 
       sigv=ale/3.+2.*log(ecm**2/(ulmass(13)*ulmass(15)))/3.-4./3.+  
      &1.526*log(ecm**2/0.932)   
     
 C...Soft and hard radiative cross-section in QED case.  
       IF(mstj(102).LE.1) THEN   
         sigv=1.5*ale-0.5+paru(1)**2/3.+2.*sigv  
         sigs=ale*(2.*log(xkl)-log(1.-xkl)-xkl)  
         sigh=ale*(2.*log(xku/xkl)-log((1.-xku)/(1.-xkl))-(xku-xkl)) 
     
 C...Soft and hard radiative cross-section in QFD case.  
       ELSE  
         szm=1.-(parj(123)/ecm)**2   
         szw=parj(123)*parj(124)/ecm**2  
         parj(161)=-rqq/rsum 
         parj(162)=-(rqq+rqv+rva)/rsum   
         parj(163)=(rqv*(1.-0.5*szm-sfi)+rva*(1.5-szm-sfw))/rsum 
         parj(164)=(rqv*szw**2*(1.-2.*sfw)+rva*(2.*sfi+szw**2-4.+3.*szm- 
      &  szm**2))/(szw*rsum) 
         sigv=1.5*ale-0.5+paru(1)**2/3.+((2.*rqq+sfi*rqv)/rsum)*sigv+    
      &  (szw*sfw*rqv/rsum)*paru(1)*20./9.   
         sigs=ale*(2.*log(xkl)+parj(161)*log(1.-xkl)+parj(162)*xkl+  
      &  parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+   
      &  parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw))) 
         sigh=ale*(2.*log(xku/xkl)+parj(161)*log((1.-xku)/(1.-xkl))+ 
      &  parj(162)*(xku-xkl)+parj(163)*log(((xku-szm)**2+szw**2)/    
      &  ((xkl-szm)**2+szw**2))+parj(164)*(atan((xku-szm)/szw)-  
      &  atan((xkl-szm)/szw)))   
       ENDIF 
     
 C...Total cross-section and fraction of hard photon events. 
       parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh) 
       parj(157)=rsum*(1.+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd 
       parj(144)=parj(157)   
       parj(148)=parj(144)*86.8/ecm**2   
       xtot=parj(148)    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ luzdis()

subroutine luzdis	(	KFL1,
		KFL2,
		PR,
		Z
	)

Definition at line 3594 of file hipyset1.35.f.

     
 C...Purpose: to generate the longitudinal splitting variable z. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
     
 C...Check if heavy flavour fragmentation.   
       kfla=iabs(kfl1)   
       kflb=iabs(kfl2)   
       kflh=kfla 
       IF(kfla.GE.10) kflh=mod(kfla/1000,10) 
     
 C...Lund symmetric scaling function: determine parameters of shape. 
       IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3)) THEN   
         fa=parj(41) 
         IF(mstj(91).EQ.1) fa=parj(43)   
         IF(kflb.GE.10) fa=fa+parj(45)   
         fb=parj(42)*pr  
         IF(mstj(91).EQ.1) fb=parj(44)*pr    
         fc=1.   
         IF(kfla.GE.10) fc=fc-parj(45)   
         IF(kflb.GE.10) fc=fc+parj(45)   
         mc=1    
         IF(abs(fc-1.).GT.0.01) mc=2 
     
 C...Determine position of maximum. Special cases for a = 0 or a = c.    
         IF(fa.LT.0.02) THEN 
           ma=1  
           zmax=1.   
           IF(fc.GT.fb) zmax=fb/fc   
         ELSEIF(abs(fc-fa).LT.0.01) THEN 
           ma=2  
           zmax=fb/(fb+fc)   
         ELSE    
           ma=3  
           zmax=0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)    
           IF(zmax.GT.0.99.AND.fb.GT.100.) zmax=1.-fa/fb 
         ENDIF   
     
 C...Subdivide z range if distribution very peaked near endpoint.    
         mmax=2  
         IF(zmax.LT.0.1) THEN    
           mmax=1    
           zdiv=2.75*zmax    
           IF(mc.EQ.1) THEN  
             fint=1.-log(zdiv)   
           ELSE  
             zdivc=zdiv**(1.-fc) 
             fint=1.+(1.-1./zdivc)/(fc-1.)   
           ENDIF 
         ELSEIF(zmax.GT.0.85.AND.fb.GT.1.) THEN  
           mmax=3    
           fscb=sqrt(4.+(fc/fb)**2)  
           zdiv=fscb-1./zmax-(fc/fb)*log(zmax*0.5*(fscb+fc/fb))  
           IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1.-zmax)    
           zdiv=min(zmax,max(0.,zdiv))   
           fint=1.+fb*(1.-zdiv)  
         ENDIF   
     
 C...Choice of z, preweighted for peaks at low or high z.    
   100   z=rlu(0)    
         fpre=1. 
         IF(mmax.EQ.1) THEN  
           IF(fint*rlu(0).LE.1.) THEN    
             z=zdiv*z    
           ELSEIF(mc.EQ.1) THEN  
             z=zdiv**z   
             fpre=zdiv/z 
           ELSE  
             z=1./(zdivc+z*(1.-zdivc))**(1./(1.-fc)) 
             fpre=(zdiv/z)**fc   
           ENDIF 
         ELSEIF(mmax.EQ.3) THEN  
           IF(fint*rlu(0).LE.1.) THEN    
             z=zdiv+log(z)/fb    
             fpre=exp(fb*(z-zdiv))   
           ELSE  
             z=zdiv+z*(1.-zdiv)  
           ENDIF 
         ENDIF   
     
 C...Weighting according to correct formula. 
         IF(z.LE.fb/(50.+fb).OR.z.GE.1.) GOTO 100    
         fval=(zmax/z)**fc*exp(fb*(1./zmax-1./z))    
         IF(ma.GE.2) fval=((1.-z)/(1.-zmax))**fa*fval    
         IF(fval.LT.rlu(0)*fpre) GOTO 100    
     
 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.  
       ELSE  
         fc=parj(50+max(1,kflh)) 
         IF(mstj(91).EQ.1) fc=parj(59)   
   110   z=rlu(0)    
         IF(fc.GE.0..AND.fc.LE.1.) THEN  
           IF(fc.GT.rlu(0)) z=1.-z**(1./3.)  
         ELSEIF(fc.GT.-1.) THEN  
           IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) GOTO 110 
         ELSE    
           IF(fc.GT.0.) z=1.-z**(1./fc)  
           IF(fc.LT.0.) z=z**(-1./fc)    
         ENDIF   
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ plu()

function plu	(	I,
		J
	)

Definition at line 6306 of file hipyset1.35.f.

     
 C...Purpose: to provide various real-valued event related data. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       dimension psum(4) 
     
 C...Set default value. For I = 0 sum of momenta or charges, 
 C...or invariant mass of system.    
       plu=0.    
       IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN 
       ELSEIF(i.EQ.0.AND.j.LE.4) THEN    
         DO 100 i1=1,n   
   100   IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+p(i1,j)  
       ELSEIF(i.EQ.0.AND.j.EQ.5) THEN    
         DO 110 j1=1,4   
         psum(j1)=0. 
         DO 110 i1=1,n   
   110   IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+p(i1,j1)   
         plu=sqrt(max(0.,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))   
       ELSEIF(i.EQ.0.AND.j.EQ.6) THEN    
         DO 120 i1=1,n   
   120   IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+luchge(k(i1,2))/3.   
       ELSEIF(i.EQ.0) THEN   
     
 C...Direct readout of P matrix. 
       ELSEIF(j.LE.5) THEN   
         plu=p(i,j)  
     
 C...Charge, total momentum, transverse momentum, transverse mass.   
       ELSEIF(j.LE.12) THEN  
         IF(j.EQ.6) plu=luchge(k(i,2))/3.    
         IF(j.EQ.7.OR.j.EQ.8) plu=p(i,1)**2+p(i,2)**2+p(i,3)**2  
         IF(j.EQ.9.OR.j.EQ.10) plu=p(i,1)**2+p(i,2)**2   
         IF(j.EQ.11.OR.j.EQ.12) plu=p(i,5)**2+p(i,1)**2+p(i,2)**2    
         IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) plu=sqrt(plu)  
     
 C...Theta and phi angle in radians or degrees.  
       ELSEIF(j.LE.16) THEN  
         IF(j.LE.14) plu=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))    
         IF(j.GE.15) plu=ulangl(p(i,1),p(i,2))   
         IF(j.EQ.14.OR.j.EQ.16) plu=plu*180./paru(1) 
     
 C...True rapidity, rapidity with pion mass, pseudorapidity. 
       ELSEIF(j.LE.19) THEN  
         pmr=0.  
         IF(j.EQ.17) pmr=p(i,5)  
         IF(j.EQ.18) pmr=ulmass(211) 
         pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)    
         plu=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr), 
      &  1e20)),p(i,3))  
     
 C...Energy and momentum fractions (only to be used in CM frame).    
       ELSEIF(j.LE.25) THEN  
         IF(j.EQ.20) plu=2.*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21) 
         IF(j.EQ.21) plu=2.*p(i,3)/paru(21)  
         IF(j.EQ.22) plu=2.*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)   
         IF(j.EQ.23) plu=2.*p(i,4)/paru(21)  
         IF(j.EQ.24) plu=(p(i,4)+p(i,3))/paru(21)    
         IF(j.EQ.25) plu=(p(i,4)-p(i,3))/paru(21)    
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pydiff()

subroutine pydiff ( )

Definition at line 14948 of file hipyset1.35.f.

     
 C...Handles diffractive and elastic scattering. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
     
 C...Reset K, P and V vectors. Store incoming particles. 
       DO 100 jt=1,mstp(126)+10  
       i=mint(83)+jt 
       DO 100 j=1,5  
       k(i,j)=0  
       p(i,j)=0. 
   100 v(i,j)=0. 
       n=mint(84)    
       mint(3)=0 
       mint(21)=0    
       mint(22)=0    
       mint(23)=0    
       mint(24)=0    
       mint(4)=4 
       DO 110 jt=1,2 
       i=mint(83)+jt 
       k(i,1)=21 
       k(i,2)=mint(10+jt)    
       p(i,5)=vint(2+jt) 
       p(i,3)=vint(5)*(-1)**(jt+1)   
   110 p(i,4)=sqrt(p(i,3)**2+p(i,5)**2)  
       mint(6)=2 
     
 C...Subprocess; kinematics. 
       isub=mint(1)  
       sqlam=(vint(2)-vint(63)-vint(64))**2-4.*vint(63)*vint(64) 
       pz=sqrt(sqlam)/(2.*vint(1))   
       DO 150 jt=1,2 
       i=mint(83)+jt 
       pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2.*vint(1)) 
     
 C...Elastically scattered particle. 
       IF(mint(16+jt).LE.0) THEN 
         n=n+1   
         k(n,1)=1    
         k(n,2)=k(i,2)   
         k(n,3)=i+2  
         p(n,3)=pz*(-1)**(jt+1)  
         p(n,4)=pe   
         p(n,5)=p(i,5)   
     
 C...Diffracted particle: valence quark kicked out.  
       ELSEIF(mstp(101).EQ.1) THEN   
         n=n+2   
         k(n-1,1)=2  
         k(n,1)=1    
         k(n-1,3)=i+2    
         k(n,3)=i+2  
         CALL pyspli(k(i,2),21,k(n,2),k(n-1,2))  
         p(n-1,5)=ulmass(k(n-1,2))   
         p(n,5)=ulmass(k(n,2))   
         sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-   
      &  4.*p(n-1,5)**2*p(n,5)**2    
         p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-   
      &  p(n,5)**2))/(2.*vint(62+jt))*(-1)**(jt+1)   
         p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)  
         p(n,3)=pz*(-1)**(jt+1)-p(n-1,3) 
         p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)    
     
 C...Diffracted particle: gluon kicked out.  
       ELSE  
         n=n+3   
         k(n-2,1)=2  
         k(n-1,1)=2  
         k(n,1)=1    
         k(n-2,3)=i+2    
         k(n-1,3)=i+2    
         k(n,3)=i+2  
         CALL pyspli(k(i,2),21,k(n,2),k(n-2,2))  
         k(n-1,2)=21 
         p(n-2,5)=ulmass(k(n-2,2))   
         p(n-1,5)=0. 
         p(n,5)=ulmass(k(n,2))   
 C...Energy distribution for particle into two jets. 
   120   imb=1   
         IF(mod(k(i,2)/1000,10).NE.0) imb=2  
         chik=parp(92+2*imb) 
         IF(mstp(92).LE.1) THEN  
           IF(imb.EQ.1) chi=rlu(0)   
           IF(imb.EQ.2) chi=1.-sqrt(rlu(0))  
         ELSEIF(mstp(92).EQ.2) THEN  
           chi=1.-rlu(0)**(1./(1.+chik)) 
         ELSEIF(mstp(92).EQ.3) THEN  
           cut=2.*0.3/vint(1)    
   130     chi=rlu(0)**2 
           IF((chi**2/(chi**2+cut**2))**0.25*(1.-chi)**chik.LT.  
      &    rlu(0)) GOTO 130  
         ELSE    
           cut=2.*0.3/vint(1)    
           cutr=(1.+sqrt(1.+cut**2))/cut 
   140     chir=cut*cutr**rlu(0) 
           chi=(chir**2-cut**2)/(2.*chir)    
           IF((1.-chi)**chik.LT.rlu(0)) GOTO 140 
         ENDIF   
         IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1.-p(n-2,5)**2/   
      &  vint(62+jt)) GOTO 120   
         sqm=p(n-2,5)**2/(1.-chi)+p(n,5)**2/chi  
         IF((sqrt(sqm)+parj(32))**2.GE.vint(62+jt)) GOTO 120 
         pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/    
      &  (2.*vint(62+jt))    
         pei=sqrt(pzi**2+sqm)    
         pqqp=(1.-chi)*(pei+pzi) 
         p(n-2,3)=0.5*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)   
         p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)  
         p(n-1,3)=(pz-pzi)*(-1)**(jt+1)  
         p(n-1,4)=abs(p(n-1,3))  
         p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)    
         p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)    
       ENDIF 
     
 C...Documentation lines.    
       k(i+2,1)=21   
       IF(mint(16+jt).EQ.0) k(i+2,2)=mint(10+jt) 
       IF(mint(16+jt).NE.0) k(i+2,2)=10*(mint(10+jt)/10) 
       k(i+2,3)=i    
       p(i+2,3)=pz*(-1)**(jt+1)  
       p(i+2,4)=pe   
       p(i+2,5)=sqrt(vint(62+jt))    
   150 CONTINUE  
     
 C...Rotate outgoing partons/particles using cos(theta). 
       CALL ludbrb(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0) 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyfram()

subroutine pyfram ( IFRAME )

Definition at line 15088 of file hipyset1.35.f.

     
 C...Performs transformations between different coordinate frames.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
     
       IF(iframe.LT.1.OR.iframe.GT.2) THEN   
         WRITE(mstu(11),1000) iframe,mint(6) 
         RETURN  
       ENDIF 
       IF(iframe.EQ.mint(6)) RETURN  
     
       IF(mint(6).EQ.1) THEN 
 C...Transform from fixed target or user specified frame to  
 C...CM-frame of incoming particles. 
         CALL lurobo(0.,0.,-vint(8),-vint(9),-vint(10))  
         CALL lurobo(0.,-vint(7),0.,0.,0.)   
         CALL lurobo(-vint(6),0.,0.,0.,0.)   
         mint(6)=2   
     
       ELSE  
 C...Transform from particle CM-frame to fixed target or user specified  
 C...frame.  
         CALL lurobo(vint(6),vint(7),vint(8),vint(9),vint(10))   
         mint(6)=1   
       ENDIF 
       msti(6)=mint(6)   
     
  1000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,   
      &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =', 
      &1x,i5)    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pygamm()

function pygamm ( X )

Definition at line 18812 of file hipyset1.35.f.

     
 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;    
 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions 
 C...(Dover, 1965) 6.1.36.   
       dimension b(8)    
       DATA b/-0.577191652,0.988205891,-0.897056937,0.918206857, 
      &-0.756704078,0.482199394,-0.193527818,0.035868343/    
     
       nx=int(x) 
       dx=x-nx   
     
       pygamm=1. 
       DO 100 i=1,8  
   100 pygamm=pygamm+b(i)*dx**i  
       IF(x.LT.1.) THEN  
         pygamm=pygamm/x 
       ELSE  
         DO 110 ix=1,nx-1    
   110   pygamm=(x-ix)*pygamm    
       ENDIF 
     
       RETURN    

Here is the caller graph for this function:

◆ pyi3au()

function pyi3au	(	BE,
		EPS,
		IREIM
	)

Definition at line 18899 of file hipyset1.35.f.

     
 C...Calculates real and imaginary parts of the auxiliary function I3;   
 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
     
       IF(eps.LT.1.) ga=0.5*(1.+sqrt(1.-eps))    
     
       IF(eps.LT.0.) THEN    
         f3re=pyspen((ga-1.)/(ga+be-1.),0.,1)-pyspen(ga/(ga+be-1.),0.,1)+    
      &  pyspen((be-ga)/be,0.,1)-pyspen((be-ga)/(be-1.),0.,1)+   
      &  (log(be)**2-log(be-1.)**2)/2.+log(ga)*log((ga+be-1.)/be)+   
      &  log(ga-1.)*log((be-1.)/(ga+be-1.))  
         f3im=0. 
       ELSEIF(eps.LT.1.) THEN    
         f3re=pyspen((ga-1.)/(ga+be-1.),0.,1)-pyspen(ga/(ga+be-1.),0.,1)+    
      &  pyspen(ga/(ga-be),0.,1)-pyspen((ga-1.)/(ga-be),0.,1)+   
      &  log(ga/(1.-ga))*log((ga+be-1.)/(be-ga)) 
         f3im=-paru(1)*log((ga+be-1.)/(be-ga))   
       ELSE  
         rsq=eps/(eps-1.+(2.*be-1.)**2)  
         rcthe=rsq*(1.-2.*be/eps)    
         rsthe=sqrt(rsq-rcthe**2)    
         rcphi=rsq*(1.+2.*(be-1.)/eps)   
         rsphi=sqrt(rsq-rcphi**2)    
         r=sqrt(rsq) 
         the=acos(rcthe/r)   
         phi=acos(rcphi/r)   
         f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-  
      &  pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+   
      &  (phi-the)*(phi+the-paru(1)) 
         f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-  
      &  pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)    
       ENDIF 
     
       IF(ireim.EQ.1) pyi3au=2./(2.*be-1.)*f3re  
       IF(ireim.EQ.2) pyi3au=2./(2.*be-1.)*f3im  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyinit()

subroutine pyinit	(	character()	FRAME,
		character()	BEAM,
		character()	TARGET,
			WIN
	)

Definition at line 10076 of file hipyset1.35.f.

     
 C...Initializes the generation procedure; finds maxima of the   
 C...differential cross-sections to be used for weighting.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/ludat4/chaf(500)   
       CHARACTER chaf*8  
       SAVE /ludat4/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
       CHARACTER*(*) frame,beam,TARGET   
       CHARACTER chfram*8,chbeam*8,chtarg*8,chmo(12)*3,chlh(2)*6 
       DATA chmo/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',  
      &'Oct','Nov','Dec'/, chlh/'lepton','hadron'/   
     
 C...Write headers.  
 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),  
 C     &MSTP(185),CHMO(MSTP(184)),MSTP(183)   
       CALL lulist(0)
 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)  
     
 C...Identify beam and target particles and initialize kinematics.   
       chfram=frame//' ' 
       chbeam=beam//' '  
       chtarg=TARGET//' '    
       CALL pyinki(chfram,chbeam,chtarg,win) 
     
 C...Select partonic subprocesses to be included in the simulation.  
       IF(msel.NE.0) THEN    
         DO 100 i=1,200  
   100   msub(i)=0   
       ENDIF 
       IF(mint(43).EQ.1.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN   
 C...Lepton+lepton -> gamma/Z0 or W. 
         IF(mint(11)+mint(12).EQ.0) msub(1)=1    
         IF(mint(11)+mint(12).NE.0) msub(2)=1    
       ELSEIF(msel.EQ.1) THEN    
 C...High-pT QCD processes:  
         msub(11)=1  
         msub(12)=1  
         msub(13)=1  
         msub(28)=1  
         msub(53)=1  
         msub(68)=1  
         IF(mstp(82).LE.1.AND.ckin(3).LT.parp(81)) msub(95)=1    
         IF(mstp(82).GE.2.AND.ckin(3).LT.parp(82)) msub(95)=1    
       ELSEIF(msel.EQ.2) THEN    
 C...All QCD processes:  
         msub(11)=1  
         msub(12)=1  
         msub(13)=1  
         msub(28)=1  
         msub(53)=1  
         msub(68)=1  
         msub(91)=1  
         msub(92)=1  
         msub(93)=1  
         msub(95)=1  
       ELSEIF(msel.GE.4.AND.msel.LE.8) THEN  
 C...Heavy quark production. 
         msub(81)=1  
         msub(82)=1  
         DO 110 j=1,min(8,mdcy(21,3))    
   110   mdme(mdcy(21,2)+j-1,1)=0    
         mdme(mdcy(21,2)+msel-1,1)=1 
       ELSEIF(msel.EQ.10) THEN   
 C...Prompt photon production:   
         msub(14)=1  
         msub(18)=1  
         msub(29)=1  
       ELSEIF(msel.EQ.11) THEN   
 C...Z0/gamma* production:   
         msub(1)=1   
       ELSEIF(msel.EQ.12) THEN   
 C...W+/- production:    
         msub(2)=1   
       ELSEIF(msel.EQ.13) THEN   
 C...Z0 + jet:   
         msub(15)=1  
         msub(30)=1  
       ELSEIF(msel.EQ.14) THEN   
 C...W+/- + jet: 
         msub(16)=1  
         msub(31)=1  
       ELSEIF(msel.EQ.15) THEN   
 C...Z0 & W+/- pair production:  
         msub(19)=1  
         msub(20)=1  
         msub(22)=1  
         msub(23)=1  
         msub(25)=1  
       ELSEIF(msel.EQ.16) THEN   
 C...H0 production:  
         msub(3)=1   
         msub(5)=1   
         msub(8)=1   
         msub(102)=1 
       ELSEIF(msel.EQ.17) THEN   
 C...H0 & Z0 or W+/- pair production:    
         msub(24)=1  
         msub(26)=1  
       ELSEIF(msel.EQ.21) THEN   
 C...Z'0 production: 
         msub(141)=1 
       ELSEIF(msel.EQ.22) THEN   
 C...H+/- production:    
         msub(142)=1 
       ELSEIF(msel.EQ.23) THEN   
 C...R production:   
         msub(143)=1 
       ENDIF 
     
 C...Count number of subprocesses on.    
       mint(44)=0    
       DO 120 isub=1,200 
       IF(mint(43).LT.4.AND.isub.GE.91.AND.isub.LE.96.AND.   
      &msub(isub).EQ.1) THEN 
         WRITE(mstu(11),1200) isub,chlh(mint(41)),chlh(mint(42)) 
         stop    
       ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN 
         WRITE(mstu(11),1300) isub   
         stop    
       ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN 
         WRITE(mstu(11),1400) isub   
         stop    
       ELSEIF(msub(isub).EQ.1) THEN  
         mint(44)=mint(44)+1 
       ENDIF 
   120 CONTINUE  
       IF(mint(44).EQ.0) THEN    
         WRITE(mstu(11),1500)    
         stop    
       ENDIF 
       mint(45)=mint(44)-msub(91)-msub(92)-msub(93)-msub(94) 
     
 C...Maximum 4 generations; set maximum number of allowed flavours.  
       mstp(1)=min(4,mstp(1))    
       mstu(114)=min(mstu(114),2*mstp(1))    
       mstp(54)=min(mstp(54),2*mstp(1))  
     
 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. 
       DO 140 i=-20,20   
       vint(180+i)=0.    
       ia=iabs(i)    
       IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN  
         DO 130 j=1,mstp(1)  
         ib=2*j-1+mod(ia,2)  
         ipm=(5-isign(1,i))/2    
         idc=j+mdcy(ia,2)+2  
   130   IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)= 
      &  vint(180+i)+vckm((ia+1)/2,(ib+1)/2) 
       ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN  
         vint(180+i)=1.  
       ENDIF 
   140 CONTINUE  
     
 C...Choose Lambda value to use in alpha-strong. 
       mstu(111)=mstp(2) 
       IF(mstp(3).GE.1) THEN 
         alam=parp(1)    
         IF(mstp(51).EQ.1) alam=0.2  
         IF(mstp(51).EQ.2) alam=0.29 
         IF(mstp(51).EQ.3) alam=0.2  
         IF(mstp(51).EQ.4) alam=0.4  
         IF(mstp(51).EQ.11) alam=0.16    
         IF(mstp(51).EQ.12) alam=0.26    
         IF(mstp(51).EQ.13) alam=0.36    
         parp(1)=alam    
         parp(61)=alam   
         paru(112)=alam  
         parj(81)=alam   
       ENDIF 
     
 C...Initialize widths and partial widths for resonances.    
       CALL pyinre   
     
 C...Reset variables for cross-section calculation.  
       DO 150 i=0,200    
       DO 150 j=1,3  
       ngen(i,j)=0   
   150 xsec(i,j)=0.  
       vint(108)=0.  
     
 C...Find parametrized total cross-sections. 
       IF(mint(43).EQ.4) CALL pyxtot 
     
 C...Maxima of differential cross-sections.  
       IF(mstp(121).LE.0) CALL pymaxi    
     
 C...Initialize possibility of overlayed events. 
       IF(mstp(131).NE.0) CALL pyovly(1) 
     
 C...Initialize multiple interactions with variable impact parameter.    
       IF(mint(43).EQ.4.AND.(mint(45).NE.0.OR.mstp(131).NE.0).AND.   
      &mstp(82).GE.2) CALL pymult(1) 
 C      IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)  
     
 C...Formats for initialization information. 
  1000 FORMAT(///20x,'The Lund Monte Carlo - PYTHIA version ',i1,'.',i1/ 
      &20x,'**  Last date of change:  ',i2,1x,a3,1x,i4,'  **'/)  
  1100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',    
      &'routines',1x,17('*'))    
  1200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,  
      &'-',a6,' interactions.'/1x,'Execution stopped!')  
  1300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/   
      &1x,'Execution stopped!')  
  1400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/  
      &1x,'Execution stopped!')  
  1500 FORMAT(1x,'Error: no subprocess switched on.'/    
      &1x,'Execution stopped.')  
  1600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,  
      &22('*'))  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyinki()

subroutine pyinki	(	character	CHFRAM,
		character	CHBEAM,
		character	CHTARG,
			WIN
	)

Definition at line 10824 of file hipyset1.35.f.

     
 C...Identifies the two incoming particles and sets up kinematics,   
 C...including rotations and boosts to/from CM frame.    
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       CHARACTER chfram*8,chbeam*8,chtarg*8,chcom(3)*8,chalp(2)*26,  
      &chidnt(3)*8,chtemp*8,chcde(18)*8,chinit*76    
       dimension len(3),kcde(18) 
       DATA chalp/'abcdefghijklmnopqrstuvwxyz',  
      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 
       DATA chcde/'e-      ','e+      ','nue     ','nue~    ',   
      &'mu-     ','mu+     ','numu    ','numu~   ','tau-    ',   
      &'tau+    ','nutau   ','nutau~  ','pi+     ','pi-     ',   
      &'n       ','n~      ','p       ','p~      '/  
       DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,  
      &211,-211,2112,-2112,2212,-2212/   
     
 C...Convert character variables to lowercase and find their length. 
       chcom(1)=chfram   
       chcom(2)=chbeam   
       chcom(3)=chtarg   
       DO 120 i=1,3  
       len(i)=8  
       DO 100 ll=8,1,-1  
       IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1   
       DO 100 la=1,26    
   100 IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=   
      &chalp(1)(la:la)   
       chidnt(i)=chcom(i)    
       DO 110 ll=1,6 
       IF(chidnt(i)(ll:ll+2).EQ.'bar') THEN  
         chtemp=chidnt(i)    
         chidnt(i)=chtemp(1:ll-1)//'~'//chtemp(ll+3:8)//'  ' 
       ENDIF 
   110 CONTINUE  
       DO 120 ll=1,8 
       IF(chidnt(i)(ll:ll).EQ.'_') THEN  
         chtemp=chidnt(i)    
         chidnt(i)=chtemp(1:ll-1)//chtemp(ll+1:8)//' '   
       ENDIF 
   120 CONTINUE  
     
 C...Set initial state. Error for unknown codes. Reset variables.    
       n=2   
       DO 140 i=1,2  
       k(i,2)=0  
       DO 130 j=1,18 
   130 IF(chidnt(i+1).EQ.chcde(j)) k(i,2)=kcde(j)    
       p(i,5)=ulmass(k(i,2)) 
       mint(40+i)=1  
       IF(iabs(k(i,2)).GT.100) mint(40+i)=2  
       DO 140 j=1,5  
   140 v(i,j)=0. 
       IF(k(1,2).EQ.0) WRITE(mstu(11),1000) chbeam(1:len(2)) 
       IF(k(2,2).EQ.0) WRITE(mstu(11),1100) chtarg(1:len(3)) 
       IF(k(1,2).EQ.0.OR.k(2,2).EQ.0) stop   
       DO 150 j=6,10 
   150 vint(j)=0.    
       chinit=' '    
     
 C...Set up kinematics for events defined in CM frame.   
       IF(chcom(1)(1:2).EQ.'cm') THEN    
         IF(chcom(2)(1:1).NE.'e') THEN   
           loffs=(34-(len(2)+len(3)))/2  
           chinit(loffs+1:76)='PYTHIA will be initialized for a '//  
      &    chcom(2)(1:len(2))//'-'//chcom(3)(1:len(3))//' collider'//' ' 
         ELSE    
           loffs=(33-(len(2)+len(3)))/2  
           chinit(loffs+1:76)='PYTHIA will be initialized for an '// 
      &    chcom(2)(1:len(2))//'-'//chcom(3)(1:len(3))//' collider'//' ' 
         ENDIF   
 C        WRITE(MSTU(11),1200) CHINIT 
 C        WRITE(MSTU(11),1300) WIN    
         s=win**2    
         p(1,1)=0.   
         p(1,2)=0.   
         p(2,1)=0.   
         p(2,2)=0.   
         p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2.*p(1,5)*p(2,5))**2)/ 
      &  (4.*s)) 
         p(2,3)=-p(1,3)  
         p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)    
         p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)    
     
 C...Set up kinematics for fixed target events.  
       ELSEIF(chcom(1)(1:3).EQ.'fix') THEN   
         loffs=(29-(len(2)+len(3)))/2    
         chinit(loffs+1:76)='PYTHIA will be initialized for '//  
      &  chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//    
      &  ' fixed target'//' '    
 C        WRITE(MSTU(11),1200) CHINIT 
 C        WRITE(MSTU(11),1400) WIN    
         p(1,1)=0.   
         p(1,2)=0.   
         p(2,1)=0.   
         p(2,2)=0.   
         p(1,3)=win  
         p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)    
         p(2,3)=0.   
         p(2,4)=p(2,5)   
         s=p(1,5)**2+p(2,5)**2+2.*p(2,4)*p(1,4)  
         vint(10)=p(1,3)/(p(1,4)+p(2,4)) 
         CALL lurobo(0.,0.,0.,0.,-vint(10))  
 C        WRITE(MSTU(11),1500) SQRT(S)    
     
 C...Set up kinematics for events in user-defined frame. 
       ELSEIF(chcom(1)(1:3).EQ.'use') THEN   
         loffs=(13-(len(1)+len(2)))/2    
         chinit(loffs+1:76)='PYTHIA will be initialized for '//  
      &  chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//    
      &  'user-specified configuration'//' ' 
 C        WRITE(MSTU(11),1200) CHINIT 
 C        WRITE(MSTU(11),1600)    
 C        WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)  
 C        WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)  
         p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)    
         p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)    
         DO 160 j=1,3    
   160   vint(7+j)=(dble(p(1,j))+dble(p(2,j)))/dble(p(1,4)+p(2,4))   
         CALL lurobo(0.,0.,-vint(8),-vint(9),-vint(10))  
         vint(7)=ulangl(p(1,1),p(1,2))   
         CALL lurobo(0.,-vint(7),0.,0.,0.)   
         vint(6)=ulangl(p(1,3),p(1,1))   
         CALL lurobo(-vint(6),0.,0.,0.,0.)   
         s=p(1,5)**2+p(2,5)**2+2.*(p(1,4)*p(2,4)-p(1,3)*p(2,3))  
 C        WRITE(MSTU(11),1500) SQRT(S)    
     
 C...Unknown frame. Error for too low CM energy. 
       ELSE  
         WRITE(mstu(11),1800) chfram(1:len(1))   
         stop    
       ENDIF 
       IF(s.LT.parp(2)**2) THEN  
         WRITE(mstu(11),1900) sqrt(s)    
         stop    
       ENDIF 
     
 C...Save information on incoming particles. 
       mint(11)=k(1,2)   
       mint(12)=k(2,2)   
       mint(43)=2*mint(41)+mint(42)-2    
       vint(1)=sqrt(s)   
       vint(2)=s 
       vint(3)=p(1,5)    
       vint(4)=p(2,5)    
       vint(5)=p(1,3)    
     
 C...Store constants to be used in generation.   
       IF(mstp(82).LE.1) vint(149)=4.*parp(81)**2/s  
       IF(mstp(82).GE.2) vint(149)=4.*parp(82)**2/s  
     
 C...Formats for initialization and error information.   
  1000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''.'/ 
      &1x,'Execution stopped!')  
  1100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''.'/   
      &1x,'Execution stopped!')  
  1200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I') 
  1300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',   
      &19x,'I'/1x,'I',76x,'I'/1x,78('='))    
  1400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')  
  1500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,  
      &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))    
  1600 FORMAT(1x,'I',76x,'I'/1x,'I',24x,'px (GeV/c)',3x,'py (GeV/c)',3x, 
      &'pz (GeV/c)',16x,'I') 
  1700 FORMAT(1x,'I',15x,a8,3(2x,f10.3,1x),15x,'I')  
  1800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''.'/  
      &1x,'Execution stopped!')  
  1900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ', 
      &'generation.'/1x,'Execution stopped!')    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyinre()

subroutine pyinre ( )

Definition at line 11008 of file hipyset1.35.f.

     
 C...Calculates full and effective widths of guage bosons, stores masses 
 C...and widths, rescales coefficients to be used for resonance  
 C...production generation.  
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       common/pyint6/proc(0:200) 
       CHARACTER proc*28 
       SAVE /pyint6/ 
       dimension wdtp(0:40),wdte(0:40,0:5)   
     
 C...Calculate full and effective widths of gauge bosons.    
       aem=paru(101) 
       xw=paru(102)  
       DO 100 i=21,40    
       DO 100 j=0,40 
       widp(i,j)=0.  
   100 wide(i,j)=0.  
     
 C...W+/-:   
       wmas=pmas(24,1)   
       wfac=aem/(24.*xw)*wmas    
       CALL pywidt(24,wmas,wdtp,wdte)    
       wids(24,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+  
      &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+  
      &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
       wids(24,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
       wids(24,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)    
       DO 110 i=0,40 
       widp(24,i)=wfac*wdtp(i)   
   110 wide(24,i)=wfac*wdte(i,0) 
     
 C...H+/-:   
       hcmas=pmas(37,1)  
       hcfac=aem/(8.*xw)*(hcmas/wmas)**2*hcmas   
       CALL pywidt(37,hcmas,wdtp,wdte)   
       wids(37,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+  
      &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+  
      &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
       wids(37,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
       wids(37,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)    
       DO 120 i=0,40 
       widp(37,i)=hcfac*wdtp(i)  
   120 wide(37,i)=hcfac*wdte(i,0)    
     
 C...Z0: 
       zmas=pmas(23,1)   
       zfac=aem/(48.*xw*(1.-xw))*zmas    
       CALL pywidt(23,zmas,wdtp,wdte)    
       wids(23,1)=((wdte(0,1)+wdte(0,2))**2+ 
      &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+   
      &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
       wids(23,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
       wids(23,3)=0. 
       DO 130 i=0,40 
       widp(23,i)=zfac*wdtp(i)   
   130 wide(23,i)=zfac*wdte(i,0) 
     
 C...H0: 
       hmas=pmas(25,1)   
       hfac=aem/(8.*xw)*(hmas/wmas)**2*hmas  
       CALL pywidt(25,hmas,wdtp,wdte)    
       wids(25,1)=((wdte(0,1)+wdte(0,2))**2+ 
      &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+   
      &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
       wids(25,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
       wids(25,3)=0. 
       DO 140 i=0,40 
       widp(25,i)=hfac*wdtp(i)   
   140 wide(25,i)=hfac*wdte(i,0) 
     
 C...Z'0:    
       zpmas=pmas(32,1)  
       zpfac=aem/(48.*xw*(1.-xw))*zpmas  
       CALL pywidt(32,zpmas,wdtp,wdte)   
       wids(32,1)=((wdte(0,1)+wdte(0,2)+wdte(0,3))**2+   
      &2.*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+   
      &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
       wids(32,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
       wids(32,3)=0. 
       DO 150 i=0,40 
       widp(32,i)=zpfac*wdtp(i)  
   150 wide(32,i)=zpfac*wdte(i,0)    
     
 C...R:  
       rmas=pmas(40,1)   
       rfac=0.08*rmas/((mstp(1)-1)*(1.+6.*(1.+ulalps(rmas**2)/paru(1)))) 
       CALL pywidt(40,rmas,wdtp,wdte)    
       wids(40,1)=((wdte(0,1)+wdte(0,2))*(wdte(0,1)+wdte(0,3))+  
      &(wdte(0,1)+wdte(0,2)+wdte(0,1)+wdte(0,3))*(wdte(0,4)+wdte(0,5))+  
      &2.*wdte(0,4)*wdte(0,5))/wdtp(0)**2    
       wids(40,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)    
       wids(40,3)=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)    
       DO 160 i=0,40 
       widp(40,i)=wfac*wdtp(i)   
   160 wide(40,i)=wfac*wdte(i,0) 
     
 C...Q:  
       kflqm=1   
       DO 170 i=1,min(8,mdcy(21,3))  
       idc=i+mdcy(21,2)-1    
       IF(mdme(idc,1).LE.0) GOTO 170 
       kflqm=i   
   170 CONTINUE  
       mint(46)=kflqm    
       kfpr(81,1)=kflqm  
       kfpr(81,2)=kflqm  
       kfpr(82,1)=kflqm  
       kfpr(82,2)=kflqm  
     
 C...Set resonance widths and branching ratios in JETSET.    
       DO 180 i=1,6  
       IF(i.LE.3) kc=i+22    
       IF(i.EQ.4) kc=32  
       IF(i.EQ.5) kc=37  
       IF(i.EQ.6) kc=40  
       pmas(kc,2)=widp(kc,0) 
       pmas(kc,3)=min(0.9*pmas(kc,1),10.*pmas(kc,2)) 
       DO 180 j=1,mdcy(kc,3) 
       idc=j+mdcy(kc,2)-1    
       brat(idc)=wide(kc,j)/wide(kc,0)   
   180 CONTINUE  
     
 C...Special cases in treatment of gamma*/Z0: redefine process name. 
       IF(mstp(43).EQ.1) THEN    
         proc(1)='f + fb -> gamma*'  
       ELSEIF(mstp(43).EQ.2) THEN    
         proc(1)='f + fb -> Z0'  
       ELSEIF(mstp(43).EQ.3) THEN    
         proc(1)='f + fb -> gamma*/Z0'   
       ENDIF 
     
 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. 
       IF(mstp(44).EQ.1) THEN    
         proc(141)='f + fb -> gamma*'    
       ELSEIF(mstp(44).EQ.2) THEN    
         proc(141)='f + fb -> Z0'    
       ELSEIF(mstp(44).EQ.3) THEN    
         proc(141)='f + fb -> Z''0'  
       ELSEIF(mstp(44).EQ.4) THEN    
         proc(141)='f + fb -> gamma*/Z0' 
       ELSEIF(mstp(44).EQ.5) THEN    
         proc(141)='f + fb -> gamma*/Z''0'   
       ELSEIF(mstp(44).EQ.6) THEN    
         proc(141)='f + fb -> Z0/Z''0'   
       ELSEIF(mstp(44).EQ.7) THEN    
         proc(141)='f + fb -> gamma*/Z0/Z''0'    
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pykcut()

subroutine pykcut ( MCUT )

Definition at line 19486 of file hipyset1.35.f.

     
 C...Dummy routine, which the user can replace in order to make cuts on  
 C...the kinematics on the parton level before the matrix elements are   
 C...evaluated and the event is generated. The cross-section estimates   
 C...will automatically take these cuts into account, so the given   
 C...values are for the allowed phase space region only. MCUT=0 means    
 C...that the event has passed the cuts, MCUT=1 that it has failed.  
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
     
       mcut=0    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyklim()

subroutine pyklim ( ILIM )

Definition at line 15735 of file hipyset1.35.f.

     
 C...Checks generated variables against pre-set kinematical limits;  
 C...also calculates limits on variables used in generation. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
     
 C...Common kinematical expressions. 
       isub=mint(1)  
       IF(isub.EQ.96) GOTO 110   
       sqm3=vint(63) 
       sqm4=vint(64) 
       IF(ilim.NE.1) THEN    
         tau=vint(21)    
         rm3=sqm3/(tau*vint(2))  
         rm4=sqm4/(tau*vint(2))  
         be34=sqrt((1.-rm3-rm4)**2-4.*rm3*rm4)   
       ENDIF 
       pthmin=ckin(3)    
       IF(min(sqm3,sqm4).LT.ckin(6)**2) pthmin=max(ckin(3),ckin(5))  
     
       IF(ilim.EQ.0) THEN    
 C...Check generated values of tau, y*, cos(theta-hat), and tau' against 
 C...pre-set kinematical limits. 
         yst=vint(22)    
         cth=vint(23)    
         taup=vint(26)   
         IF(iset(isub).LE.2) THEN    
           x1=sqrt(tau)*exp(yst) 
           x2=sqrt(tau)*exp(-yst)    
         ELSE    
           x1=sqrt(taup)*exp(yst)    
           x2=sqrt(taup)*exp(-yst)   
         ENDIF   
         xf=x1-x2    
         IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1    
         IF(ckin(2).GE.0..AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1  
         IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1 
         IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1 
         IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1 
         IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1 
         IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN 
           pth=0.5*be34*sqrt(tau*vint(2)*(1.-cth**2))    
           y3=yst+0.5*log((1.+rm3-rm4+be34*cth)/(1.+rm3-rm4-be34*cth))   
           y4=yst+0.5*log((1.+rm4-rm3-be34*cth)/(1.+rm4-rm3+be34*cth))   
           ylarge=max(y3,y4) 
           ysmall=min(y3,y4) 
           etalar=10.    
           etasma=-10.   
           sth=sqrt(1.-cth**2)   
           IF(sth.LT.1.e-6) GOTO 100 
           expet3=((1.+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+    
      &    sqrt(((1.+rm3-rm4)*cosh(yst)+be34*sinh(yst)*cth)**2-4.*rm3))/ 
      &    (be34*sth)    
           expet4=((1.-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+    
      &    sqrt(((1.-rm3+rm4)*cosh(yst)-be34*sinh(yst)*cth)**2-4.*rm4))/ 
      &    (be34*sth)    
           eta3=log(min(1.e10,max(1.e-10,expet3)))   
           eta4=log(min(1.e10,max(1.e-10,expet4)))   
           etalar=max(eta3,eta4) 
           etasma=min(eta3,eta4) 
   100     cts3=((1.+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/ 
      &    sqrt(((1.+rm3-rm4)*cosh(yst)+be34*sinh(yst)*cth)**2-4.*rm3)   
           cts4=((1.-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/ 
      &    sqrt(((1.-rm3+rm4)*cosh(yst)-be34*sinh(yst)*cth)**2-4.*rm4)   
           ctslar=max(cts3,cts4) 
           ctssma=min(cts3,cts4) 
           IF(pth.LT.pthmin) mint(51)=1  
           IF(ckin(4).GE.0..AND.pth.GT.ckin(4)) mint(51)=1   
           IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1    
           IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1   
           IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1   
           IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1   
           IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1   
           IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1   
           IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1 
         ENDIF   
         IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN 
           IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1    
           IF(ckin(32).GE.0..AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1 
         ENDIF   
     
       ELSEIF(ilim.EQ.1) THEN    
 C...Calculate limits on tau 
 C...0) due to definition    
         taumn0=0.   
         taumx0=1.   
 C...1) due to limits on subsystem mass  
         taumn1=ckin(1)**2/vint(2)   
         taumx1=1.   
         IF(ckin(2).GE.0.) taumx1=ckin(2)**2/vint(2) 
 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) 
         tm3=sqrt(sqm3+pthmin**2)    
         tm4=sqrt(sqm4+pthmin**2)    
         ydcosh=1.   
         IF(ckin(9).GT.ckin(12)) ydcosh=cosh(ckin(9)-ckin(12))   
         taumn2=(tm3**2+2.*tm3*tm4*ydcosh+tm4**2)/vint(2)    
         taumx2=1.   
 C...3) due to limits on pT-hat and cos(theta-hat)   
         cth2mn=min(ckin(27)**2,ckin(28)**2) 
         cth2mx=max(ckin(27)**2,ckin(28)**2) 
         taumn3=0.   
         IF(ckin(27)*ckin(28).GT.0.) taumn3= 
      &  (sqrt(sqm3+pthmin**2/(1.-cth2mn))+  
      &  sqrt(sqm4+pthmin**2/(1.-cth2mn)))**2/vint(2)    
         taumx3=1.   
         IF(ckin(4).GE.0..AND.cth2mx.LT.1.) taumx3=  
      &  (sqrt(sqm3+ckin(4)**2/(1.-cth2mx))+ 
      &  sqrt(sqm4+ckin(4)**2/(1.-cth2mx)))**2/vint(2)   
 C...4) due to limits on x1 and x2   
         taumn4=ckin(21)*ckin(23)    
         taumx4=ckin(22)*ckin(24)    
 C...5) due to limits on xF  
         taumn5=0.   
         taumx5=max(1.-ckin(25),1.+ckin(26)) 
         vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5) 
         vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5) 
         IF(mint(43).EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.2)) THEN 
           vint(11)=0.99999  
           vint(31)=1.00001  
         ENDIF   
         IF(vint(31).LE.vint(11)) mint(51)=1 
     
       ELSEIF(ilim.EQ.2) THEN    
 C...Calculate limits on y*  
         IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) tau=vint(26) 
         taurt=sqrt(tau) 
 C...0) due to kinematics    
         ystmn0=log(taurt)   
         ystmx0=-ystmn0  
 C...1) due to explicit limits   
         ystmn1=ckin(7)  
         ystmx1=ckin(8)  
 C...2) due to limits on x1  
         ystmn2=log(max(tau,ckin(21))/taurt) 
         ystmx2=log(max(tau,ckin(22))/taurt) 
 C...3) due to limits on x2  
         ystmn3=-log(max(tau,ckin(24))/taurt)    
         ystmx3=-log(max(tau,ckin(23))/taurt)    
 C...4) due to limits on xF  
         yepmn4=0.5*abs(ckin(25))/taurt  
         ystmn4=sign(log(sqrt(1.+yepmn4**2)+yepmn4),ckin(25))    
         yepmx4=0.5*abs(ckin(26))/taurt  
         ystmx4=sign(log(sqrt(1.+yepmx4**2)+yepmx4),ckin(26))    
 C...5) due to simultaneous limits on y-large and y-small    
         yepsmn=(rm3-rm4)*sinh(ckin(9)-ckin(11)) 
         yepsmx=(rm3-rm4)*sinh(ckin(10)-ckin(12))    
         ydifmn=abs(log(sqrt(1.+yepsmn**2)-yepsmn))  
         ydifmx=abs(log(sqrt(1.+yepsmx**2)-yepsmx))  
         ystmn5=0.5*(ckin(9)+ckin(11)-ydifmn)    
         ystmx5=0.5*(ckin(10)+ckin(12)+ydifmx)   
 C...6) due to simultaneous limits on cos(theta-hat) and y-large or  
 C...   y-small  
         cthlim=sqrt(1.-4.*pthmin**2/(be34*tau*vint(2))) 
         rzmn=be34*max(ckin(27),-cthlim) 
         rzmx=be34*min(ckin(28),cthlim)  
         yex3mx=(1.+rm3-rm4+rzmx)/max(1e-10,1.+rm3-rm4-rzmx) 
         yex4mx=(1.+rm4-rm3-rzmn)/max(1e-10,1.+rm4-rm3+rzmn) 
         yex3mn=max(1e-10,1.+rm3-rm4+rzmn)/(1.+rm3-rm4-rzmn) 
         yex4mn=max(1e-10,1.+rm4-rm3-rzmx)/(1.+rm4-rm3+rzmx) 
         ystmn6=ckin(9)-0.5*log(max(yex3mx,yex4mx))  
         ystmx6=ckin(12)-0.5*log(min(yex3mn,yex4mn)) 
         vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)  
         vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)  
         IF(mint(43).EQ.1) THEN  
           vint(12)=-0.00001 
           vint(32)=0.00001  
         ELSEIF(mint(43).EQ.2) THEN  
           vint(12)=0.99999*ystmx0   
           vint(32)=1.00001*ystmx0   
         ELSEIF(mint(43).EQ.3) THEN  
           vint(12)=-1.00001*ystmx0  
           vint(32)=-0.99999*ystmx0  
         ENDIF   
         IF(vint(32).LE.vint(12)) mint(51)=1 
     
       ELSEIF(ilim.EQ.3) THEN    
 C...Calculate limits on cos(theta-hat)  
         yst=vint(22)    
 C...0) due to definition    
         ctnmn0=-1.  
         ctnmx0=0.   
         ctpmn0=0.   
         ctpmx0=1.   
 C...1) due to explicit limits   
         ctnmn1=min(0.,ckin(27)) 
         ctnmx1=min(0.,ckin(28)) 
         ctpmn1=max(0.,ckin(27)) 
         ctpmx1=max(0.,ckin(28)) 
 C...2) due to limits on pT-hat  
         ctnmn2=-sqrt(1.-4.*pthmin**2/(be34**2*tau*vint(2))) 
         ctpmx2=-ctnmn2  
         ctnmx2=0.   
         ctpmn2=0.   
         IF(ckin(4).GE.0.) THEN  
           ctnmx2=-sqrt(max(0.,1.-4.*ckin(4)**2/(be34**2*tau*vint(2))))  
           ctpmn2=-ctnmx2    
         ENDIF   
 C...3) due to limits on y-large and y-small 
         ctnmn3=min(0.,max((1.+rm3-rm4)/be34*tanh(ckin(11)-yst), 
      &  -(1.-rm3+rm4)/be34*tanh(ckin(10)-yst))) 
         ctnmx3=min(0.,(1.+rm3-rm4)/be34*tanh(ckin(12)-yst), 
      &  -(1.-rm3+rm4)/be34*tanh(ckin(9)-yst))   
         ctpmn3=max(0.,(1.+rm3-rm4)/be34*tanh(ckin(9)-yst),  
      &  -(1.-rm3+rm4)/be34*tanh(ckin(12)-yst))  
         ctpmx3=max(0.,min((1.+rm3-rm4)/be34*tanh(ckin(10)-yst), 
      &  -(1.-rm3+rm4)/be34*tanh(ckin(11)-yst))) 
         vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3)   
         vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3)   
         vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3)   
         vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3)   
         IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1    
     
       ELSEIF(ilim.EQ.4) THEN    
 C...Calculate limits on tau'    
 C...0) due to kinematics    
         tapmn0=tau  
         tapmx0=1.   
 C...1) due to explicit limits   
         tapmn1=ckin(31)**2/vint(2)  
         tapmx1=1.   
         IF(ckin(32).GE.0.) tapmx1=ckin(32)**2/vint(2)   
         vint(16)=max(tapmn0,tapmn1) 
         vint(36)=min(tapmx0,tapmx1) 
         IF(mint(43).EQ.1) THEN  
           vint(16)=0.99999  
           vint(36)=1.00001  
         ENDIF   
         IF(vint(36).LE.vint(16)) mint(51)=1 
     
       ENDIF 
       RETURN    
     
 C...Special case for low-pT and multiple interactions:  
 C...effective kinematical limits for tau, y*, cos(theta-hat).   
   110 IF(ilim.EQ.0) THEN    
       ELSEIF(ilim.EQ.1) THEN    
         IF(mstp(82).LE.1) vint(11)=4.*parp(81)**2/vint(2)   
         IF(mstp(82).GE.2) vint(11)=parp(82)**2/vint(2)  
         vint(31)=1. 
       ELSEIF(ilim.EQ.2) THEN    
         vint(12)=0.5*log(vint(21))  
         vint(32)=-vint(12)  
       ELSEIF(ilim.EQ.3) THEN    
         IF(mstp(82).LE.1) st2eff=4.*parp(81)**2/(vint(21)*vint(2))  
         IF(mstp(82).GE.2) st2eff=0.01*parp(82)**2/(vint(21)*vint(2))    
         vint(13)=-sqrt(max(0.,1.-st2eff))   
         vint(33)=0. 
         vint(14)=0. 
         vint(34)=-vint(13)  
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pykmap()

subroutine pykmap	(	IVAR,
		MVAR,
		VVAR
	)

Definition at line 16004 of file hipyset1.35.f.

     
 C...Maps a uniform distribution into a distribution of a kinematical    
 C...variable according to one of the possibilities allowed. It is   
 C...assumed that kinematical limits have been set by a PYKLIM call. 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
     
 C...Convert VVAR to tau variable.   
       isub=mint(1)  
       IF(ivar.EQ.1) THEN    
         taumin=vint(11) 
         taumax=vint(31) 
         IF(mvar.EQ.3.OR.mvar.EQ.4) THEN 
           taure=vint(73)    
           gamre=vint(74)    
         ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN 
           taure=vint(75)    
           gamre=vint(76)    
         ENDIF   
         IF(mint(43).EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.2)) THEN 
           tau=1.    
         ELSEIF(mvar.EQ.1) THEN  
           tau=taumin*(taumax/taumin)**vvar  
         ELSEIF(mvar.EQ.2) THEN  
           tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)   
         ELSEIF(mvar.EQ.3.OR.mvar.EQ.5) THEN 
           ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax    
           tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin) 
         ELSE    
           aupp=atan((taumax-taure)/gamre)   
           alow=atan((taumin-taure)/gamre)   
           tau=taure+gamre*tan(alow+(aupp-alow)*vvar)    
         ENDIF   
         vint(21)=min(taumax,max(taumin,tau))    
     
 C...Convert VVAR to y* variable.    
       ELSEIF(ivar.EQ.2) THEN    
         ystmin=vint(12) 
         ystmax=vint(32) 
         IF(mint(43).EQ.1) THEN  
           yst=0.    
         ELSEIF(mint(43).EQ.2) THEN  
           IF(iset(isub).LE.2) yst=-0.5*log(vint(21))    
           IF(iset(isub).GE.3) yst=-0.5*log(vint(26))    
         ELSEIF(mint(43).EQ.3) THEN  
           IF(iset(isub).LE.2) yst=0.5*log(vint(21)) 
           IF(iset(isub).GE.3) yst=0.5*log(vint(26)) 
         ELSEIF(mvar.EQ.1) THEN  
           yst=ystmin+(ystmax-ystmin)*sqrt(vvar) 
         ELSEIF(mvar.EQ.2) THEN  
           yst=ystmax-(ystmax-ystmin)*sqrt(1.-vvar)  
         ELSE    
           aupp=atan(exp(ystmax))    
           alow=atan(exp(ystmin))    
           yst=log(tan(alow+(aupp-alow)*vvar))   
         ENDIF   
         vint(22)=min(ystmax,max(ystmin,yst))    
     
 C...Convert VVAR to cos(theta-hat) variable.    
       ELSEIF(ivar.EQ.3) THEN    
         rm34=2.*vint(63)*vint(64)/(vint(21)*vint(2))**2 
         rsqm=1.+rm34    
         IF(2.*vint(71)**2/(vint(21)*vint(2)).LT.0.0001) rm34=max(rm34,  
      &  2.*vint(71)**2/(vint(21)*vint(2)))  
         ctnmin=vint(13) 
         ctnmax=vint(33) 
         ctpmin=vint(14) 
         ctpmax=vint(34) 
         IF(mvar.EQ.1) THEN  
           aneg=ctnmax-ctnmin    
           apos=ctpmax-ctpmin    
           IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
             vctn=vvar*(aneg+apos)/aneg  
             cth=ctnmin+(ctnmax-ctnmin)*vctn 
           ELSE  
             vctp=(vvar*(aneg+apos)-aneg)/apos   
             cth=ctpmin+(ctpmax-ctpmin)*vctp 
           ENDIF 
         ELSEIF(mvar.EQ.2) THEN  
           rmnmin=max(rm34,rsqm-ctnmin)  
           rmnmax=max(rm34,rsqm-ctnmax)  
           rmpmin=max(rm34,rsqm-ctpmin)  
           rmpmax=max(rm34,rsqm-ctpmax)  
           aneg=log(rmnmin/rmnmax)   
           apos=log(rmpmin/rmpmax)   
           IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
             vctn=vvar*(aneg+apos)/aneg  
             cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn   
           ELSE  
             vctp=(vvar*(aneg+apos)-aneg)/apos   
             cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp   
           ENDIF 
         ELSEIF(mvar.EQ.3) THEN  
           rmnmin=max(rm34,rsqm+ctnmin)  
           rmnmax=max(rm34,rsqm+ctnmax)  
           rmpmin=max(rm34,rsqm+ctpmin)  
           rmpmax=max(rm34,rsqm+ctpmax)  
           aneg=log(rmnmax/rmnmin)   
           apos=log(rmpmax/rmpmin)   
           IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
             vctn=vvar*(aneg+apos)/aneg  
             cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm   
           ELSE  
             vctp=(vvar*(aneg+apos)-aneg)/apos   
             cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm   
           ENDIF 
         ELSEIF(mvar.EQ.4) THEN  
           rmnmin=max(rm34,rsqm-ctnmin)  
           rmnmax=max(rm34,rsqm-ctnmax)  
           rmpmin=max(rm34,rsqm-ctpmin)  
           rmpmax=max(rm34,rsqm-ctpmax)  
           aneg=1./rmnmax-1./rmnmin  
           apos=1./rmpmax-1./rmpmin  
           IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
             vctn=vvar*(aneg+apos)/aneg  
             cth=rsqm-1./(1./rmnmin+aneg*vctn)   
           ELSE  
             vctp=(vvar*(aneg+apos)-aneg)/apos   
             cth=rsqm-1./(1./rmpmin+apos*vctp)   
           ENDIF 
         ELSEIF(mvar.EQ.5) THEN  
           rmnmin=max(rm34,rsqm+ctnmin)  
           rmnmax=max(rm34,rsqm+ctnmax)  
           rmpmin=max(rm34,rsqm+ctpmin)  
           rmpmax=max(rm34,rsqm+ctpmax)  
           aneg=1./rmnmin-1./rmnmax  
           apos=1./rmpmin-1./rmpmax  
           IF(aneg.GT.0..AND.vvar*(aneg+apos).LE.aneg) THEN  
             vctn=vvar*(aneg+apos)/aneg  
             cth=1./(1./rmnmin-aneg*vctn)-rsqm   
           ELSE  
             vctp=(vvar*(aneg+apos)-aneg)/apos   
             cth=1./(1./rmpmin-apos*vctp)-rsqm   
           ENDIF 
         ENDIF   
         IF(cth.LT.0.) cth=min(ctnmax,max(ctnmin,cth))   
         IF(cth.GT.0.) cth=min(ctpmax,max(ctpmin,cth))   
         vint(23)=cth    
     
 C...Convert VVAR to tau' variable.  
       ELSEIF(ivar.EQ.4) THEN    
         tau=vint(11)    
         taupmn=vint(16) 
         taupmx=vint(36) 
         IF(mint(43).EQ.1) THEN  
           taup=1.   
         ELSEIF(mvar.EQ.1) THEN  
           taup=taupmn*(taupmx/taupmn)**vvar 
         ELSE    
           aupp=(1.-tau/taupmx)**4   
           alow=(1.-tau/taupmn)**4   
           taup=tau/(1.-(alow+(aupp-alow)*vvar)**0.25)   
         ENDIF   
         vint(26)=min(taupmx,max(taupmn,taup))   
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pymaxi()

subroutine pymaxi ( )

Definition at line 11280 of file hipyset1.35.f.

     
 C...Finds optimal set of coefficients for kinematical variable selection    
 C...and the maximum of the part of the differential cross-section used  
 C...in the event weighting. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
       SAVE /pyint3/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
       common/pyint6/proc(0:200) 
       CHARACTER proc*28 
       SAVE /pyint6/ 
       CHARACTER cvar(4)*4   
       dimension npts(4),mvarpt(200,4),vintpt(200,30),sigspt(200),   
      &narel(6),wtrel(6),wtmat(6,6),coefu(6),iaccmx(4),sigsmx(4),    
      &sigssm(3) 
       DATA cvar/'tau ','tau''','y*  ','cth '/   
     
 C...Select subprocess to study: skip cases not applicable.  
       vint(143)=1.  
       vint(144)=1.  
       xsec(0,1)=0.  
       DO 350 isub=1,200 
       IF(isub.GE.91.AND.isub.LE.95) THEN    
         xsec(isub,1)=vint(isub+11)  
         IF(msub(isub).NE.1) GOTO 350    
         GOTO 340    
       ELSEIF(isub.EQ.96) THEN   
         IF(mint(43).NE.4) GOTO 350  
         IF(msub(95).NE.1.AND.mstp(81).LE.0.AND.mstp(131).LE.0) GOTO 350 
       ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.   
      &isub.EQ.53.OR.isub.EQ.68) THEN    
         IF(msub(isub).NE.1.OR.msub(95).EQ.1) GOTO 350   
       ELSE  
         IF(msub(isub).NE.1) GOTO 350    
       ENDIF 
       mint(1)=isub  
       istsb=iset(isub)  
       IF(isub.EQ.96) istsb=2    
       IF(mstp(122).GE.2) WRITE(mstu(11),1000) isub  
     
 C...Find resonances (explicit or implicit in cross-section).    
       mint(72)=0    
       kfr1=0    
       IF(istsb.EQ.1.OR.istsb.EQ.3) THEN 
         kfr1=kfpr(isub,1)   
       ELSEIF(isub.GE.71.AND.isub.LE.77) THEN    
         kfr1=25 
       ENDIF 
       IF(kfr1.NE.0) THEN    
         taur1=pmas(kfr1,1)**2/vint(2)   
         gamr1=pmas(kfr1,1)*pmas(kfr1,2)/vint(2) 
         mint(72)=1  
         mint(73)=kfr1   
         vint(73)=taur1  
         vint(74)=gamr1  
       ENDIF 
       IF(isub.EQ.141) THEN  
         kfr2=23 
         taur2=pmas(kfr2,1)**2/vint(2)   
         gamr2=pmas(kfr2,1)*pmas(kfr2,2)/vint(2) 
         mint(72)=2  
         mint(74)=kfr2   
         vint(75)=taur2  
         vint(76)=gamr2  
       ENDIF 
     
 C...Find product masses and minimum pT of process.  
       sqm3=0.   
       sqm4=0.   
       mint(71)=0    
       vint(71)=ckin(3)  
       IF(istsb.EQ.2.OR.istsb.EQ.4) THEN 
         IF(kfpr(isub,1).NE.0) sqm3=pmas(kfpr(isub,1),1)**2  
         IF(kfpr(isub,2).NE.0) sqm4=pmas(kfpr(isub,2),1)**2  
         IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1 
         IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5)) 
         IF(isub.EQ.96.AND.mstp(82).LE.1) vint(71)=parp(81)  
         IF(isub.EQ.96.AND.mstp(82).GE.2) vint(71)=0.08*parp(82) 
       ENDIF 
       vint(63)=sqm3 
       vint(64)=sqm4 
     
 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).  
       npts(1)=2+2*mint(72)  
       IF(mint(43).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) npts(1)=1    
       npts(2)=1 
       IF(mint(43).GE.2.AND.(istsb.EQ.3.OR.istsb.EQ.4)) npts(2)=2    
       npts(3)=1 
       IF(mint(43).EQ.4) npts(3)=3   
       npts(4)=1 
       IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5    
       ntry=npts(1)*npts(2)*npts(3)*npts(4)  
     
 C...Reset coefficients of cross-section weighting.  
       DO 100 j=1,20 
   100 coef(isub,j)=0.   
       coef(isub,1)=1.   
       coef(isub,7)=0.5  
       coef(isub,8)=0.5  
       coef(isub,10)=1.  
       coef(isub,15)=1.  
       mcth=0    
       mtaup=0   
       cth=0.    
       taup=0.   
       sigsam=0. 
     
 C...Find limits and select tau, y*, cos(theta-hat) and tau' values, 
 C...in grid of phase space points.  
       CALL pyklim(1)    
       nacc=0    
       DO 120 itry=1,ntry    
       IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN 
         mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))   
         CALL pykmap(1,mtau,0.5) 
         IF(istsb.EQ.3.OR.istsb.EQ.4) CALL pyklim(4) 
       ENDIF 
       IF((istsb.EQ.3.OR.istsb.EQ.4).AND.mod(itry-1,npts(3)*npts(4)).    
      &eq.0) THEN    
         mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2)) 
         CALL pykmap(4,mtaup,0.5)    
       ENDIF 
       IF(mod(itry-1,npts(3)*npts(4)).EQ.0) CALL pyklim(2)   
       IF(mod(itry-1,npts(4)).EQ.0) THEN 
         myst=1+mod((itry-1)/npts(4),npts(3))    
         CALL pykmap(2,myst,0.5) 
         CALL pyklim(3)  
       ENDIF 
       IF(istsb.EQ.2.OR.istsb.EQ.4) THEN 
         mcth=1+mod(itry-1,npts(4))  
         CALL pykmap(3,mcth,0.5) 
       ENDIF 
       IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2) 
     
 C...Calculate and store cross-section.  
       mint(51)=0    
       CALL pyklim(0)    
       IF(mint(51).EQ.1) GOTO 120    
       nacc=nacc+1   
       mvarpt(nacc,1)=mtau   
       mvarpt(nacc,2)=mtaup  
       mvarpt(nacc,3)=myst   
       mvarpt(nacc,4)=mcth   
       DO 110 j=1,30 
   110 vintpt(nacc,j)=vint(10+j) 
       CALL pysigh(nchn,sigs)    
       sigspt(nacc)=sigs 
       IF(sigs.GT.sigsam) sigsam=sigs    
       IF(mstp(122).GE.2) WRITE(mstu(11),1100) mtau,mtaup,myst,mcth, 
      &vint(21),vint(22),vint(23),vint(26),sigs  
   120 CONTINUE  
       IF(sigsam.EQ.0.) THEN 
         WRITE(mstu(11),1200) isub   
         stop    
       ENDIF 
     
 C...Calculate integrals in tau and y* over maximal phase space limits.  
       taumin=vint(11)   
       taumax=vint(31)   
       atau1=log(taumax/taumin)  
       atau2=(taumax-taumin)/(taumax*taumin) 
       IF(npts(1).GE.3) THEN 
         atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1    
         atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/  
      &  gamr1   
       ENDIF 
       IF(npts(1).GE.5) THEN 
         atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2    
         atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/  
      &  gamr2   
       ENDIF 
       ystmin=0.5*log(taumin)    
       ystmax=-ystmin    
       ayst0=ystmax-ystmin   
       ayst1=0.5*(ystmax-ystmin)**2  
       ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))    
     
 C...Reset. Sum up cross-sections in points calculated.  
       DO 230 ivar=1,4   
       IF(npts(ivar).EQ.1) GOTO 230  
       IF(isub.EQ.96.AND.ivar.EQ.4) GOTO 230 
       nbin=npts(ivar)   
       DO 130 j1=1,nbin  
       narel(j1)=0   
       wtrel(j1)=0.  
       coefu(j1)=0.  
       DO 130 j2=1,nbin  
   130 wtmat(j1,j2)=0.   
       DO 140 iacc=1,nacc    
       ibin=mvarpt(iacc,ivar)    
       narel(ibin)=narel(ibin)+1 
       wtrel(ibin)=wtrel(ibin)+sigspt(iacc)  
     
 C...Sum up tau cross-section pieces in points used. 
       IF(ivar.EQ.1) THEN    
         tau=vintpt(iacc,11) 
         wtmat(ibin,1)=wtmat(ibin,1)+1.  
         wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau   
         IF(nbin.GE.3) THEN  
           wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1) 
           wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/    
      &    ((tau-taur1)**2+gamr1**2) 
         ENDIF   
         IF(nbin.GE.5) THEN  
           wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2) 
           wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/    
      &    ((tau-taur2)**2+gamr2**2) 
         ENDIF   
     
 C...Sum up tau' cross-section pieces in points used.    
       ELSEIF(ivar.EQ.2) THEN    
         tau=vintpt(iacc,11) 
         taup=vintpt(iacc,16)    
         taupmn=vintpt(iacc,6)   
         taupmx=vintpt(iacc,26)  
         ataup1=log(taupmx/taupmn)   
         ataup2=((1.-tau/taupmx)**4-(1.-tau/taupmn)**4)/(4.*tau) 
         wtmat(ibin,1)=wtmat(ibin,1)+1.  
         wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*(1.-tau/taup)**3/   
      &  taup    
     
 C...Sum up y* and cos(theta-hat) cross-section pieces in points used.   
       ELSEIF(ivar.EQ.3) THEN    
         yst=vintpt(iacc,12) 
         wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)  
         wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst1)*(ystmax-yst)  
         wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst) 
       ELSE  
         rm34=2.*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2  
         rsqm=1.+rm34    
         cthmax=sqrt(1.-4.*vint(71)**2/(taumax*vint(2))) 
         cthmin=-cthmax  
         IF(cthmax.GT.0.9999) rm34=max(rm34,2.*vint(71)**2/  
      &  (taumax*vint(2)))   
         acth1=cthmax-cthmin 
         acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))  
         acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))  
         acth4=1./max(rm34,rsqm-cthmax)-1./max(rm34,rsqm-cthmin) 
         acth5=1./max(rm34,rsqm+cthmin)-1./max(rm34,rsqm+cthmax) 
         cth=vintpt(iacc,13) 
         wtmat(ibin,1)=wtmat(ibin,1)+1.  
         wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/max(rm34,rsqm-cth)    
         wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/max(rm34,rsqm+cth)    
         wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/max(rm34,rsqm-cth)**2 
         wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/max(rm34,rsqm+cth)**2 
       ENDIF 
   140 CONTINUE  
     
 C...Check that equation system solvable; else trivial way out.  
       IF(mstp(122).GE.2) WRITE(mstu(11),1300) cvar(ivar)    
       msolv=1   
       DO 150 ibin=1,nbin    
       IF(mstp(122).GE.2) WRITE(mstu(11),1400) (wtmat(ibin,ired),    
      &ired=1,nbin),wtrel(ibin)  
   150 IF(narel(ibin).EQ.0) msolv=0  
       IF(msolv.EQ.0) THEN   
         DO 160 ibin=1,nbin  
   160   coefu(ibin)=1.  
     
 C...Solve to find relative importance of cross-section pieces.  
       ELSE  
         DO 170 ired=1,nbin-1    
         DO 170 ibin=ired+1,nbin 
         rqt=wtmat(ibin,ired)/wtmat(ired,ired)   
         wtrel(ibin)=wtrel(ibin)-rqt*wtrel(ired) 
         DO 170 icoe=ired,nbin   
   170   wtmat(ibin,icoe)=wtmat(ibin,icoe)-rqt*wtmat(ired,icoe)  
         DO 190 ired=nbin,1,-1   
         DO 180 icoe=ired+1,nbin 
   180   wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)    
   190   coefu(ired)=wtrel(ired)/wtmat(ired,ired)    
       ENDIF 
     
 C...Normalize coefficients, with piece shared democratically.   
       coefsu=0. 
       DO 200 ibin=1,nbin    
       coefu(ibin)=max(0.,coefu(ibin))   
   200 coefsu=coefsu+coefu(ibin) 
       IF(ivar.EQ.1) ioff=0  
       IF(ivar.EQ.2) ioff=14 
       IF(ivar.EQ.3) ioff=6  
       IF(ivar.EQ.4) ioff=9  
       IF(coefsu.GT.0.) THEN 
         DO 210 ibin=1,nbin  
   210   coef(isub,ioff+ibin)=parp(121)/nbin+(1.-parp(121))*coefu(ibin)/ 
      &  coefsu  
       ELSE  
         DO 220 ibin=1,nbin  
   220   coef(isub,ioff+ibin)=1./nbin    
       ENDIF 
       IF(mstp(122).GE.2) WRITE(mstu(11),1500) cvar(ivar),   
      &(coef(isub,ioff+ibin),ibin=1,nbin)    
   230 CONTINUE  
     
 C...Find two most promising maxima among points previously determined.  
       DO 240 j=1,4  
       iaccmx(j)=0   
   240 sigsmx(j)=0.  
       nmax=0    
       DO 290 iacc=1,nacc    
       DO 250 j=1,30 
   250 vint(10+j)=vintpt(iacc,j) 
       CALL pysigh(nchn,sigs)    
       ieq=0 
       DO 260 imv=1,nmax 
   260 IF(abs(sigs-sigsmx(imv)).LT.1e-4*(sigs+sigsmx(imv))) ieq=imv  
       IF(ieq.EQ.0) THEN 
         DO 270 imv=nmax,1,-1    
         iin=imv+1   
         IF(sigs.LE.sigsmx(imv)) GOTO 280    
         iaccmx(imv+1)=iaccmx(imv)   
   270   sigsmx(imv+1)=sigsmx(imv)   
         iin=1   
   280   iaccmx(iin)=iacc    
         sigsmx(iin)=sigs    
         IF(nmax.LE.1) nmax=nmax+1   
       ENDIF 
   290 CONTINUE  
     
 C...Read out starting position for search.  
       IF(mstp(122).GE.2) WRITE(mstu(11),1600)   
       sigsam=sigsmx(1)  
       DO 330 imax=1,nmax    
       iacc=iaccmx(imax) 
       mtau=mvarpt(iacc,1)   
       mtaup=mvarpt(iacc,2)  
       myst=mvarpt(iacc,3)   
       mcth=mvarpt(iacc,4)   
       vtau=0.5  
       vyst=0.5  
       vcth=0.5  
       vtaup=0.5 
     
 C...Starting point and step size in parameter space.    
       DO 320 irpt=1,2   
       DO 310 ivar=1,4   
       IF(npts(ivar).EQ.1) GOTO 310  
       IF(ivar.EQ.1) vvar=vtau   
       IF(ivar.EQ.2) vvar=vtaup  
       IF(ivar.EQ.3) vvar=vyst   
       IF(ivar.EQ.4) vvar=vcth   
       IF(ivar.EQ.1) mvar=mtau   
       IF(ivar.EQ.2) mvar=mtaup  
       IF(ivar.EQ.3) mvar=myst   
       IF(ivar.EQ.4) mvar=mcth   
       IF(irpt.EQ.1) vdel=0.1    
       IF(irpt.EQ.2) vdel=max(0.01,min(0.05,vvar-0.02,0.98-vvar))    
       IF(irpt.EQ.1) vmar=0.02   
       IF(irpt.EQ.2) vmar=0.002  
       imov0=1   
       IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0   
       DO 300 imov=imov0,8   
     
 C...Define new point in parameter space.    
       IF(imov.EQ.0) THEN    
         inew=2  
         vnew=vvar   
       ELSEIF(imov.EQ.1) THEN    
         inew=3  
         vnew=vvar+vdel  
       ELSEIF(imov.EQ.2) THEN    
         inew=1  
         vnew=vvar-vdel  
       ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND. 
      &vvar+2.*vdel.LT.1.-vmar) THEN 
         vvar=vvar+vdel  
         sigssm(1)=sigssm(2) 
         sigssm(2)=sigssm(3) 
         inew=3  
         vnew=vvar+vdel  
       ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND. 
      &vvar-2.*vdel.GT.vmar) THEN    
         vvar=vvar-vdel  
         sigssm(3)=sigssm(2) 
         sigssm(2)=sigssm(1) 
         inew=1  
         vnew=vvar-vdel  
       ELSEIF(sigssm(3).GE.sigssm(1)) THEN   
         vdel=0.5*vdel   
         vvar=vvar+vdel  
         sigssm(1)=sigssm(2) 
         inew=2  
         vnew=vvar   
       ELSE  
         vdel=0.5*vdel   
         vvar=vvar-vdel  
         sigssm(3)=sigssm(2) 
         inew=2  
         vnew=vvar   
       ENDIF 
     
 C...Convert to relevant variables and find derived new limits.  
       IF(ivar.EQ.1) THEN    
         vtau=vnew   
         CALL pykmap(1,mtau,vtau)    
         IF(istsb.EQ.3.OR.istsb.EQ.4) CALL pyklim(4) 
       ENDIF 
       IF(ivar.LE.2.AND.(istsb.EQ.3.OR.istsb.EQ.4)) THEN 
         IF(ivar.EQ.2) vtaup=vnew    
         CALL pykmap(4,mtaup,vtaup)  
       ENDIF 
       IF(ivar.LE.2) CALL pyklim(2)  
       IF(ivar.LE.3) THEN    
         IF(ivar.EQ.3) vyst=vnew 
         CALL pykmap(2,myst,vyst)    
         CALL pyklim(3)  
       ENDIF 
       IF(istsb.EQ.2.OR.istsb.EQ.4) THEN 
         IF(ivar.EQ.4) vcth=vnew 
         CALL pykmap(3,mcth,vcth)    
       ENDIF 
       IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2) 
     
 C...Evaluate cross-section. Save new maximum. Final maximum.    
       CALL pysigh(nchn,sigs)    
       sigssm(inew)=sigs 
       IF(sigs.GT.sigsam) sigsam=sigs    
       IF(mstp(122).GE.2) WRITE(mstu(11),1700) imax,ivar,mvar,imov,  
      &vnew,vint(21),vint(22),vint(23),vint(26),sigs 
   300 CONTINUE  
   310 CONTINUE  
   320 CONTINUE  
       IF(imax.EQ.1) sigs11=sigsam   
   330 CONTINUE  
       xsec(isub,1)=1.05*sigsam  
   340 IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)   
   350 CONTINUE  
     
 C...Print summary table.    
       IF(mstp(122).GE.1) THEN   
         WRITE(mstu(11),1800)    
         WRITE(mstu(11),1900)    
         DO 360 isub=1,200   
         IF(msub(isub).NE.1.AND.isub.NE.96) GOTO 360 
         IF(isub.EQ.96.AND.mint(43).NE.4) GOTO 360   
         IF(isub.EQ.96.AND.msub(95).NE.1.AND.mstp(81).LE.0) GOTO 360 
         IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.    
      &  isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) GOTO 360   
         WRITE(mstu(11),2000) isub,proc(isub),xsec(isub,1)   
   360   CONTINUE    
         WRITE(mstu(11),2100)    
       ENDIF 
     
 C...Format statements for maximization results. 
  1000 FORMAT(/1x,'Coefficient optimization and maximum search for ',    
      &'subprocess no',i4/1x,'Coefficient modes     tau',10x,'y*',9x,    
      &'cth',9x,'tau''',7x,'sigma')  
  1100 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,e12.4)   
  1200 FORMAT(1x,'Error: requested subprocess ',i3,' has vanishing ',    
      &'cross-section.'/1x,'Execution stopped!')
  1300 FORMAT(1x,'Coefficients of equation system to be solved for ',a4) 
  1400 FORMAT(1x,1p,7e11.3)  
  1500 FORMAT(1x,'Result for ',a4,':',6f9.4) 
  1600 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',  
      &'MOD MOV   VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma') 
  1700 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,e12.4)   
  1800 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',  
      &'cross-section maximum search',1x,8('*')) 
  1900 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I  ISUB  ',  
      &'Subprocess name',15x,'I  Maximum value  I'/11x,'I',38x,'I',  
      &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')  
  2000 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,e12.4,3x,'I')    
  2100 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pymult()

subroutine pymult ( MMUL )

Definition at line 13657 of file hipyset1.35.f.

     
 C...Initializes treatment of multiple interactions, selects kinematics  
 C...of hardest interaction if low-pT physics included in run, and   
 C...generates all non-hardest interactions. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
       SAVE /pyint3/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
       dimension nmul(20),sigm(20),kstr(500,2)   
       SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm  
     
 C...Initialization of multiple interaction treatment.   
       IF(mmul.EQ.1) THEN    
         IF(mstp(122).GE.1) WRITE(mstu(11),1000) mstp(82)    
         isub=96 
         mint(1)=96  
         vint(63)=0. 
         vint(64)=0. 
         vint(143)=1.    
         vint(144)=1.    
     
 C...Loop over phase space points: xT2 choice in 20 bins.    
   100   sigsum=0.   
         DO 120 ixt2=1,20    
         nmul(ixt2)=mstp(83) 
         sigm(ixt2)=0.   
         DO 110 itry=1,mstp(83)  
         rsca=0.05*((21-ixt2)-rlu(0))    
         xt2=vint(149)*(1.+vint(149))/(vint(149)+rsca)-vint(149) 
         xt2=max(0.01*vint(149),xt2) 
         vint(25)=xt2    
     
 C...Choose tau and y*. Calculate cos(theta-hat).    
         IF(rlu(0).LE.coef(isub,1)) THEN 
           taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)    
           tau=xt2*(1.+taup)**2/(4.*taup)    
         ELSE    
           tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2) 
         ENDIF   
         vint(21)=tau    
         CALL pyklim(2)  
         ryst=rlu(0) 
         myst=1  
         IF(ryst.GT.coef(isub,7)) myst=2 
         IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3    
         CALL pykmap(2,myst,rlu(0))  
         vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0)) 
     
 C...Calculate differential cross-section.   
         vint(71)=0.5*vint(1)*sqrt(xt2)  
         CALL pysigh(nchn,sigs)  
   110   sigm(ixt2)=sigm(ixt2)+sigs  
   120   sigsum=sigsum+sigm(ixt2)    
         sigsum=sigsum/(20.*mstp(83))    
     
 C...Reject result if sigma(parton-parton) is smaller than hadronic one. 
         IF(sigsum.LT.1.1*vint(106)) THEN    
           IF(mstp(122).GE.1) WRITE(mstu(11),1100) parp(82),sigsum   
           parp(82)=0.9*parp(82) 
           vint(149)=4.*parp(82)**2/vint(2)  
           GOTO 100  
         ENDIF   
         IF(mstp(122).GE.1) WRITE(mstu(11),1200) parp(82), sigsum    
     
 C...Start iteration to find k factor.   
         yke=sigsum/vint(106)    
         so=0.5  
         xi=0.   
         yi=0.   
         xk=0.5  
         iit=0   
   130   IF(iit.EQ.0) THEN   
           xk=2.*xk  
         ELSEIF(iit.EQ.1) THEN   
           xk=0.5*xk 
         ELSE    
           xk=xi+(yke-yi)*(xf-xi)/(yf-yi)    
         ENDIF   
     
 C...Evaluate overlap integrals. 
         IF(mstp(82).EQ.2) THEN  
           sp=0.5*paru(1)*(1.-exp(-xk))  
           sop=sp/paru(1)    
         ELSE    
           IF(mstp(82).EQ.3) deltab=0.02 
           IF(mstp(82).EQ.4) deltab=min(0.01,0.05*parp(84))  
           sp=0. 
           sop=0.    
           b=-0.5*deltab 
   140     b=b+deltab    
           IF(mstp(82).EQ.3) THEN    
             ov=exp(-b**2)/paru(2)   
           ELSE  
             cq2=parp(84)**2 
             ov=((1.-parp(83))**2*exp(-min(100.,b**2))+2.*parp(83)*  
      &      (1.-parp(83))*2./(1.+cq2)*exp(-min(100.,b**2*2./(1.+cq2)))+ 
      &      parp(83)**2/cq2*exp(-min(100.,b**2/cq2)))/paru(2)   
           ENDIF 
           pacc=1.-exp(-min(100.,paru(1)*xk*ov)) 
           sp=sp+paru(2)*b*deltab*pacc   
           sop=sop+paru(2)*b*deltab*ov*pacc  
           IF(b.LT.1..OR.b*pacc.GT.1e-6) GOTO 140    
         ENDIF   
         yk=paru(1)*xk*so/sp 
     
 C...Continue iteration until convergence.   
         IF(yk.LT.yke) THEN  
           xi=xk 
           yi=yk 
           IF(iit.EQ.1) iit=2    
         ELSE    
           xf=xk 
           yf=yk 
           IF(iit.EQ.0) iit=1    
         ENDIF   
         IF(abs(yk-yke).GE.1e-5*yke) GOTO 130    
     
 C...Store some results for subsequent use.  
         vint(145)=sigsum    
         vint(146)=sop/so    
         vint(147)=sop/sp    
     
 C...Initialize iteration in xT2 for hardest interaction.    
       ELSEIF(mmul.EQ.2) THEN    
         IF(mstp(82).LE.0) THEN  
         ELSEIF(mstp(82).EQ.1) THEN  
           xt2=1.    
           xt2fac=xsec(96,1)/vint(106)*vint(149)/(1.-vint(149))  
         ELSEIF(mstp(82).EQ.2) THEN  
           xt2=1.    
           xt2fac=vint(146)*xsec(96,1)/vint(106)*vint(149)*(1.+vint(149))    
         ELSE    
           xc2=4.*ckin(3)**2/vint(2) 
           IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0.    
         ENDIF   
     
       ELSEIF(mmul.EQ.3) THEN    
 C...Low-pT or multiple interactions (first semihard interaction):   
 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)    
 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).   
         isub=mint(1)    
         IF(mstp(82).LE.0) THEN  
           xt2=0.    
         ELSEIF(mstp(82).EQ.1) THEN  
           xt2=xt2fac*xt2/(xt2fac-xt2*log(rlu(0)))   
         ELSEIF(mstp(82).EQ.2) THEN  
           IF(xt2.LT.1..AND.exp(-xt2fac*xt2/(vint(149)*(xt2+ 
      &    vint(149)))).GT.rlu(0)) xt2=1.    
           IF(xt2.GE.1.) THEN    
             xt2=(1.+vint(149))*xt2fac/(xt2fac-(1.+vint(149))*log(1.-    
      &      rlu(0)*(1.-exp(-xt2fac/(vint(149)*(1.+vint(149)))))))-  
      &      vint(149)   
           ELSE  
             xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+rlu(0)*    
      &      (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))- 
      &      vint(149)   
           ENDIF 
           xt2=max(0.01*vint(149),xt2)   
         ELSE    
           xt2=(xc2+vint(149))*(1.+vint(149))/(1.+vint(149)- 
      &    rlu(0)*(1.-xc2))-vint(149)    
           xt2=max(0.01*vint(149),xt2)   
         ENDIF   
         vint(25)=xt2    
     
 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.   
         IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN 
           IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-1   
           IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-1 
           isub=95   
           mint(1)=isub  
           vint(21)=0.01*vint(149)   
           vint(22)=0.   
           vint(23)=0.   
           vint(25)=0.01*vint(149)   
     
         ELSE    
 C...Multiple interactions (first semihard interaction). 
 C...Choose tau and y*. Calculate cos(theta-hat).    
           IF(rlu(0).LE.coef(isub,1)) THEN   
             taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)  
             tau=xt2*(1.+taup)**2/(4.*taup)  
           ELSE  
             tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2)   
           ENDIF 
           vint(21)=tau  
           CALL pyklim(2)    
           ryst=rlu(0)   
           myst=1    
           IF(ryst.GT.coef(isub,7)) myst=2   
           IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3  
           CALL pykmap(2,myst,rlu(0))    
           vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0))   
         ENDIF   
         vint(71)=0.5*vint(1)*sqrt(vint(25)) 
     
 C...Store results of cross-section calculation. 
       ELSEIF(mmul.EQ.4) THEN    
         isub=mint(1)    
         xts=vint(25)    
         IF(iset(isub).EQ.1) xts=vint(21)    
         IF(iset(isub).EQ.2) xts=(4.*vint(48)+2.*vint(63)+2.*vint(64))/  
      &  vint(2) 
         IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) xts=vint(26) 
         rbin=max(0.000001,min(0.999999,xts*(1.+vint(149))/  
      &  (xts+vint(149))))   
         irbin=int(1.+20.*rbin)  
         IF(isub.EQ.96) nmul(irbin)=nmul(irbin)+1    
         IF(isub.EQ.96) sigm(irbin)=sigm(irbin)+vint(153)    
     
 C...Choose impact parameter.    
       ELSEIF(mmul.EQ.5) THEN    
         IF(mstp(82).EQ.3) THEN  
           vint(148)=rlu(0)/(paru(2)*vint(147))  
         ELSE    
           rtype=rlu(0)  
           cq2=parp(84)**2   
           IF(rtype.LT.(1.-parp(83))**2) THEN    
             b2=-log(rlu(0)) 
           ELSEIF(rtype.LT.1.-parp(83)**2) THEN  
             b2=-0.5*(1.+cq2)*log(rlu(0))    
           ELSE  
             b2=-cq2*log(rlu(0)) 
           ENDIF 
           vint(148)=((1.-parp(83))**2*exp(-min(100.,b2))+2.*parp(83)*   
      &    (1.-parp(83))*2./(1.+cq2)*exp(-min(100.,b2*2./(1.+cq2)))+ 
      &    parp(83)**2/cq2*exp(-min(100.,b2/cq2)))/(paru(2)*vint(147))   
         ENDIF   
     
 C...Multiple interactions (variable impact parameter) : reject with 
 C...probability exp(-overlap*cross-section above pT/normalization). 
         rncor=(irbin-20.*rbin)*nmul(irbin)  
         sigcor=(irbin-20.*rbin)*sigm(irbin) 
         DO 150 ibin=irbin+1,20  
         rncor=rncor+nmul(ibin)  
   150   sigcor=sigcor+sigm(ibin)    
         sigabv=(sigcor/rncor)*vint(149)*(1.-xts)/(xts+vint(149))    
         vint(150)=exp(-min(100.,vint(146)*vint(148)*sigabv/vint(106)))  
     
 C...Generate additional multiple semihard interactions. 
       ELSEIF(mmul.EQ.6) THEN    
     
 C...Reconstruct strings in hard scattering. 
         isub=mint(1)    
         nmax=mint(84)+4 
         IF(iset(isub).EQ.1) nmax=mint(84)+2 
         nstr=0  
         DO 170 i=mint(84)+1,nmax    
         kcs=kchg(lucomp(k(i,2)),2)*isign(1,k(i,2))  
         IF(kcs.EQ.0) GOTO 170   
         DO 160 j=1,4    
         IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) GOTO 160    
         IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) GOTO 160   
         IF(j.LE.2) THEN 
           ist=mod(k(i,j+3)/mstu(5),mstu(5)) 
         ELSE    
           ist=mod(k(i,j+1),mstu(5)) 
         ENDIF   
         IF(ist.LT.mint(84).OR.ist.GT.i) GOTO 160    
         IF(kchg(lucomp(k(ist,2)),2).EQ.0) GOTO 160  
         nstr=nstr+1 
         IF(j.EQ.1.OR.j.EQ.4) THEN   
           kstr(nstr,1)=i    
           kstr(nstr,2)=ist  
         ELSE    
           kstr(nstr,1)=ist  
           kstr(nstr,2)=i    
         ENDIF   
   160   CONTINUE    
   170   CONTINUE    
     
 C...Set up starting values for iteration in xT2.    
         xt2=vint(25)    
         IF(iset(isub).EQ.1) xt2=vint(21)    
         IF(iset(isub).EQ.2) xt2=(4.*vint(48)+2.*vint(63)+2.*vint(64))/  
      &  vint(2) 
         IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) xt2=vint(26) 
         isub=96 
         mint(1)=96  
         IF(mstp(82).LE.1) THEN  
           xt2fac=xsec(isub,1)*vint(149)/((1.-vint(149))*vint(106))  
         ELSE    
           xt2fac=vint(146)*vint(148)*xsec(isub,1)/vint(106)*    
      &    vint(149)*(1.+vint(149))  
         ENDIF   
         vint(63)=0. 
         vint(64)=0. 
         vint(151)=0.    
         vint(152)=0.    
         vint(143)=1.-vint(141)  
         vint(144)=1.-vint(142)  
     
 C...Iterate downwards in xT2.   
   180   IF(mstp(82).LE.1) THEN  
           xt2=xt2fac*xt2/(xt2fac-xt2*log(rlu(0)))   
           IF(xt2.LT.vint(149)) GOTO 220 
         ELSE    
           IF(xt2.LE.0.01*vint(149)) GOTO 220    
           xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*   
      &    log(rlu(0)))-vint(149)    
           IF(xt2.LE.0.) GOTO 220    
           xt2=max(0.01*vint(149),xt2)   
         ENDIF   
         vint(25)=xt2    
     
 C...Choose tau and y*. Calculate cos(theta-hat).    
         IF(rlu(0).LE.coef(isub,1)) THEN 
           taup=(2.*(1.+sqrt(1.-xt2))/xt2-1.)**rlu(0)    
           tau=xt2*(1.+taup)**2/(4.*taup)    
         ELSE    
           tau=xt2*(1.+tan(rlu(0)*atan(sqrt(1./xt2-1.)))**2) 
         ENDIF   
         vint(21)=tau    
         CALL pyklim(2)  
         ryst=rlu(0) 
         myst=1  
         IF(ryst.GT.coef(isub,7)) myst=2 
         IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3    
         CALL pykmap(2,myst,rlu(0))  
         vint(23)=sqrt(max(0.,1.-xt2/tau))*(-1)**int(1.5+rlu(0)) 
     
 C...Check that x not used up. Accept or reject kinematical variables.   
         x1m=sqrt(tau)*exp(vint(22)) 
         x2m=sqrt(tau)*exp(-vint(22))    
         IF(vint(143)-x1m.LT.0.01.OR.vint(144)-x2m.LT.0.01) GOTO 180 
         vint(71)=0.5*vint(1)*sqrt(xt2)  
         CALL pysigh(nchn,sigs)  
         IF(sigs.LT.xsec(isub,1)*rlu(0)) GOTO 180    
     
 C...Reset K, P and V vectors. Select some variables.    
         DO 190 i=n+1,n+2    
         DO 190 j=1,5    
         k(i,j)=0    
         p(i,j)=0.   
   190   v(i,j)=0.   
         rflav=rlu(0)    
         pt=0.5*vint(1)*sqrt(xt2)    
         phi=paru(2)*rlu(0)  
         cth=vint(23)    
     
 C...Add first parton to event record.   
         k(n+1,1)=3  
         k(n+1,2)=21 
         IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=   
      &  1+int((2.+parj(2))*rlu(0))  
         p(n+1,1)=pt*cos(phi)    
         p(n+1,2)=pt*sin(phi)    
         p(n+1,3)=0.25*vint(1)*(vint(41)*(1.+cth)-vint(42)*(1.-cth)) 
         p(n+1,4)=0.25*vint(1)*(vint(41)*(1.+cth)+vint(42)*(1.-cth)) 
         p(n+1,5)=0. 
     
 C...Add second parton to event record.  
         k(n+2,1)=3  
         k(n+2,2)=21 
         IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)   
         p(n+2,1)=-p(n+1,1)  
         p(n+2,2)=-p(n+1,2)  
         p(n+2,3)=0.25*vint(1)*(vint(41)*(1.-cth)-vint(42)*(1.+cth)) 
         p(n+2,4)=0.25*vint(1)*(vint(41)*(1.-cth)+vint(42)*(1.+cth)) 
         p(n+2,5)=0. 
     
         IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN    
 C....Choose relevant string pieces to place gluons on.  
           DO 210 i=n+1,n+2  
           dmin=1e8  
           DO 200 istr=1,nstr    
           i1=kstr(istr,1)   
           i2=kstr(istr,2)   
           dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-   
      &    p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-   
      &    p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1.,p(i1,4)*p(i2,4)-    
      &    p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))  
           IF(istr.EQ.1.OR.dist.LT.dmin) THEN    
             dmin=dist   
             ist1=i1 
             ist2=i2 
             istm=istr   
           ENDIF 
   200     CONTINUE  
     
 C....Colour flow adjustments, new string pieces.    
           IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+    
      &    mod(k(ist1,4),mstu(5))    
           IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)= 
      &    mstu(5)*(k(ist1,5)/mstu(5))+i 
           k(i,5)=mstu(5)*ist1   
           k(i,4)=mstu(5)*ist2   
           IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+    
      &    mod(k(ist2,5),mstu(5))    
           IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)= 
      &    mstu(5)*(k(ist2,4)/mstu(5))+i 
           kstr(istm,2)=i    
           kstr(nstr+1,1)=i  
           kstr(nstr+1,2)=ist2   
   210     nstr=nstr+1   
     
 C...String drawing and colour flow for gluon loop.  
         ELSEIF(k(n+1,2).EQ.21) THEN 
           k(n+1,4)=mstu(5)*(n+2)    
           k(n+1,5)=mstu(5)*(n+2)    
           k(n+2,4)=mstu(5)*(n+1)    
           k(n+2,5)=mstu(5)*(n+1)    
           kstr(nstr+1,1)=n+1    
           kstr(nstr+1,2)=n+2    
           kstr(nstr+2,1)=n+2    
           kstr(nstr+2,2)=n+1    
           nstr=nstr+2   
     
 C...String drawing and colour flow for q-qbar pair. 
         ELSE    
           k(n+1,4)=mstu(5)*(n+2)    
           k(n+2,5)=mstu(5)*(n+1)    
           kstr(nstr+1,1)=n+1    
           kstr(nstr+1,2)=n+2    
           nstr=nstr+1   
         ENDIF   
     
 C...Update remaining energy; iterate.   
         n=n+2   
         IF(n.GT.mstu(4)-mstu(32)-10) THEN   
           CALL luerrm(11,'(PYMULT:) no more memory left in LUJETS') 
           IF(mstu(21).GE.1) RETURN  
         ENDIF   
         mint(31)=mint(31)+1 
         vint(151)=vint(151)+vint(41)    
         vint(152)=vint(152)+vint(42)    
         vint(143)=vint(143)-vint(41)    
         vint(144)=vint(144)-vint(42)    
         IF(mint(31).LT.240) GOTO 180    
   220   CONTINUE    
       ENDIF 
     
 C...Format statements for printout. 
  1000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter', 
      &'actions for MSTP(82) =',i2,' ******')    
  1100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,    
      &e9.2,' mb: rejected') 
  1200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,    
      &e9.2,' mb: accepted') 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyovly()

subroutine pyovly ( MOVLY )

Definition at line 11764 of file hipyset1.35.f.

     
 C...Initializes multiplicity distribution and selects mutliplicity  
 C...of overlayed events, i.e. several events occuring at the same   
 C...beam crossing.  
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       dimension wti(0:100)  
       SAVE imax,wti,wts 
     
 C...Sum of allowed cross-sections for overlayed events. 
       IF(movly.EQ.1) THEN   
         vint(131)=vint(106) 
         IF(mstp(132).GE.2) vint(131)=vint(131)+vint(104)    
         IF(mstp(132).GE.3) vint(131)=vint(131)+vint(103)    
         IF(mstp(132).GE.4) vint(131)=vint(131)+vint(102)    
     
 C...Initialize multiplicity distribution for unbiased events.   
         IF(mstp(133).EQ.1) THEN 
           xnave=vint(131)*parp(131) 
           IF(xnave.GT.40.) WRITE(mstu(11),1000) xnave   
           wti(0)=exp(-min(50.,xnave))   
           wts=0.    
           wtn=0.    
           DO 100 i=1,100    
           wti(i)=wti(i-1)*xnave/i   
           IF(i-2.5.GT.xnave.AND.wti(i).LT.1e-6) GOTO 110    
           wts=wts+wti(i)    
           wtn=wtn+wti(i)*i  
   100     imax=i    
   110     vint(132)=xnave   
           vint(133)=wtn/wts 
           vint(134)=wts 
     
 C...Initialize mutiplicity distribution for biased events.  
         ELSEIF(mstp(133).EQ.2) THEN 
           xnave=vint(131)*parp(131) 
           IF(xnave.GT.40.) WRITE(mstu(11),1000) xnave   
           wti(1)=exp(-min(50.,xnave))*xnave 
           wts=wti(1)    
           wtn=wti(1)    
           DO 120 i=2,100    
           wti(i)=wti(i-1)*xnave/(i-1)   
           IF(i-2.5.GT.xnave.AND.wti(i).LT.1e-6) GOTO 130    
           wts=wts+wti(i)    
           wtn=wtn+wti(i)*i  
   120     imax=i    
   130     vint(132)=xnave   
           vint(133)=wtn/wts 
           vint(134)=wts 
         ENDIF   
     
 C...Pick multiplicity of overlayed events.  
       ELSE  
         IF(mstp(133).EQ.0) THEN 
           mint(81)=max(1,mstp(134)) 
         ELSE    
           wtr=wts*rlu(0)    
           DO 140 i=1,imax   
           mint(81)=i    
           wtr=wtr-wti(i)    
           IF(wtr.LE.0.) GOTO 150    
   140     CONTINUE  
   150     CONTINUE  
         ENDIF   
       ENDIF 
     
 C...Format statement for error message. 
  1000 FORMAT(1x,'Warning: requested average number of events per bunch',    
      &'crossing too large, ',1p,e12.4)  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyrand()

subroutine pyrand ( )

Definition at line 11844 of file hipyset1.35.f.

     
 C...Generates quantities characterizing the high-pT scattering at the   
 C...parton level according to the matrix elements. Chooses incoming,    
 C...reacting partons, their momentum fractions and one of the possible  
 C...subprocesses.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
       SAVE /pyint3/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
     
 C...Initial values, specifically for (first) semihard interaction.  
       mint(17)=0    
       mint(18)=0    
       vint(143)=1.  
       vint(144)=1.  
       IF(msub(95).EQ.1.OR.mint(82).GE.2) CALL pymult(2) 
       isub=0    
   100 mint(51)=0    
     
 C...Choice of process type - first event of overlay.    
       IF(mint(82).EQ.1.AND.(isub.LE.90.OR.isub.GT.96)) THEN 
         rsub=xsec(0,1)*rlu(0)   
         DO 110 i=1,200  
         IF(msub(i).NE.1) GOTO 110   
         isub=i  
         rsub=rsub-xsec(i,1) 
         IF(rsub.LE.0.) GOTO 120 
   110   CONTINUE    
   120   IF(isub.EQ.95) isub=96  
     
 C...Choice of inclusive process type - overlayed events.    
       ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN  
         rsub=vint(131)*rlu(0)   
         isub=96 
         IF(rsub.GT.vint(106)) isub=93   
         IF(rsub.GT.vint(106)+vint(104)) isub=92 
         IF(rsub.GT.vint(106)+vint(104)+vint(103)) isub=91   
       ENDIF 
       IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+1   
       IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+1 
       mint(1)=isub  
     
 C...Find resonances (explicit or implicit in cross-section).    
       mint(72)=0    
       kfr1=0    
       IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN   
         kfr1=kfpr(isub,1)   
       ELSEIF(isub.GE.71.AND.isub.LE.77) THEN    
         kfr1=25 
       ENDIF 
       IF(kfr1.NE.0) THEN    
         taur1=pmas(kfr1,1)**2/vint(2)   
         gamr1=pmas(kfr1,1)*pmas(kfr1,2)/vint(2) 
         mint(72)=1  
         mint(73)=kfr1   
         vint(73)=taur1  
         vint(74)=gamr1  
       ENDIF 
       IF(isub.EQ.141) THEN  
         kfr2=23 
         taur2=pmas(kfr2,1)**2/vint(2)   
         gamr2=pmas(kfr2,1)*pmas(kfr2,2)/vint(2) 
         mint(72)=2  
         mint(74)=kfr2   
         vint(75)=taur2  
         vint(76)=gamr2  
       ENDIF 
     
 C...Find product masses and minimum pT of process,  
 C...optionally with broadening according to a truncated Breit-Wigner.   
       vint(63)=0.   
       vint(64)=0.   
       mint(71)=0    
       vint(71)=ckin(3)  
       IF(mint(82).GE.2) vint(71)=0. 
       IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN   
         DO 130 i=1,2    
         IF(kfpr(isub,i).EQ.0) THEN  
         ELSEIF(mstp(42).LE.0) THEN  
           vint(62+i)=pmas(kfpr(isub,i),1)**2    
         ELSE    
           vint(62+i)=ulmass(kfpr(isub,i))**2    
         ENDIF   
   130   CONTINUE    
         IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1 
         IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5)) 
       ENDIF 
     
       IF(iset(isub).EQ.0) THEN  
 C...Double or single diffractive, or elastic scattering:    
 C...choose m^2 according to 1/m^2 (diffractive), constant (elastic) 
         is=int(1.5+rlu(0))  
         vint(63)=vint(3)**2 
         vint(64)=vint(4)**2 
         IF(isub.EQ.92.OR.isub.EQ.93) vint(62+is)=parp(111)**2   
         IF(isub.EQ.93) vint(65-is)=parp(111)**2 
         sh=vint(2)  
         sqm1=vint(3)**2 
         sqm2=vint(4)**2 
         sqm3=vint(63)   
         sqm4=vint(64)   
         sqla12=(sh-sqm1-sqm2)**2-4.*sqm1*sqm2   
         sqla34=(sh-sqm3-sqm4)**2-4.*sqm3*sqm4   
         thter1=sqm1+sqm2+sqm3+sqm4-(sqm1-sqm2)*(sqm3-sqm4)/sh-sh    
         thter2=sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh 
         thl=0.5*(thter1-thter2) 
         thu=0.5*(thter1+thter2) 
         thm=min(max(thl,parp(101)),thu) 
         jtmax=0 
         IF(isub.EQ.92.OR.isub.EQ.93) jtmax=isub-91  
         DO 140 jt=1,jtmax   
         mint(13+3*jt-is*(2*jt-3))=1 
         sqmmin=vint(59+3*jt-is*(2*jt-3))    
         sqmi=vint(8-3*jt+is*(2*jt-3))**2    
         sqmj=vint(3*jt-1-is*(2*jt-3))**2    
         sqmf=vint(68-3*jt+is*(2*jt-3))  
         squa=0.5*sh/sqmi*((1.+(sqmi-sqmj)/sh)*thm+sqmi-sqmf-    
      &  sqmj**2/sh+(sqmi+sqmj)*sqmf/sh+(sqmi-sqmj)**2/sh**2*sqmf)   
         quar=sh/sqmi*(thm*(thm+sh-sqmi-sqmj-sqmf*(1.-(sqmi-sqmj)/sh))+  
      &  sqmi*sqmj-sqmj*sqmf*(1.+(sqmi-sqmj-sqmf)/sh))   
         sqmmax=squa+sqrt(max(0.,squa**2-quar))  
         IF(abs(quar/squa**2).LT.1.e-06) sqmmax=0.5*quar/squa    
         sqmmax=min(sqmmax,(vint(1)-sqrt(sqmf))**2)  
         vint(59+3*jt-is*(2*jt-3))=sqmmin*(sqmmax/sqmmin)**rlu(0)    
   140   CONTINUE    
 C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).   
         sqm3=vint(63)   
         sqm4=vint(64)   
         sqla34=(sh-sqm3-sqm4)**2-4.*sqm3*sqm4   
         thter1=sqm1+sqm2+sqm3+sqm4-(sqm1-sqm2)*(sqm3-sqm4)/sh-sh    
         thter2=sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh 
         thl=0.5*(thter1-thter2) 
         thu=0.5*(thter1+thter2) 
         b=vint(121) 
         c=vint(122) 
         IF(isub.EQ.92.OR.isub.EQ.93) THEN   
           b=0.5*b   
           c=0.5*c   
         ENDIF   
         thm=min(max(thl,parp(101)),thu) 
         expth=0.    
         tharg=b*(thm-thu)   
         IF(tharg.GT.-20.) expth=exp(tharg)  
   150   th=thu+log(expth+(1.-expth)*rlu(0))/b   
         th=max(thm,min(thu,th)) 
         ratlog=min((b+c*(th+thm))*(th-thm),(b+c*(th+thu))*(th-thu)) 
         IF(ratlog.LT.log(rlu(0))) GOTO 150  
         vint(21)=1. 
         vint(22)=0. 
         vint(23)=min(1.,max(-1.,(2.*th-thter1)/thter2)) 
     
 C...Note: in the following, by In is meant the integral over the    
 C...quantity multiplying coefficient cn.    
 C...Choose tau according to h1(tau)/tau, where  
 C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +    
 C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +  
 C...I0/I4*c4*1/(tau+tau_R') +   
 C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and    
 C...c0 + c1 + c2 + c3 + c4 + c5 = 1 
       ELSEIF(iset(isub).GE.1.AND.iset(isub).LE.4) THEN  
         CALL pyklim(1)  
         IF(mint(51).NE.0) GOTO 100  
         rtau=rlu(0) 
         mtau=1  
         IF(rtau.GT.coef(isub,1)) mtau=2 
         IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3    
         IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4   
         IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)) 
      &  mtau=5  
         IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+ 
      &  coef(isub,5)) mtau=6    
         CALL pykmap(1,mtau,rlu(0))  
     
 C...2 -> 3, 4 processes:    
 C...Choose tau' according to h4(tau,tau')/tau', where   
 C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and 
 C...c0 + c1 = 1.    
         IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN 
           CALL pyklim(4)    
           IF(mint(51).NE.0) GOTO 100    
           rtaup=rlu(0)  
           mtaup=1   
           IF(rtaup.GT.coef(isub,15)) mtaup=2    
           CALL pykmap(4,mtaup,rlu(0))   
         ENDIF   
     
 C...Choose y* according to h2(y*), where    
 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +    
 C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.    
         CALL pyklim(2)  
         IF(mint(51).NE.0) GOTO 100  
         ryst=rlu(0) 
         myst=1  
         IF(ryst.GT.coef(isub,7)) myst=2 
         IF(ryst.GT.coef(isub,7)+coef(isub,8)) myst=3    
         CALL pykmap(2,myst,rlu(0))  
     
 C...2 -> 2 processes:   
 C...Choose cos(theta-hat) (cth) according to h3(cth), where 
 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +    
 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,    
 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), 
 C...and c0 + c1 + c2 + c3 + c4 = 1. 
         CALL pyklim(3)  
         IF(mint(51).NE.0) GOTO 100  
         IF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN 
           rcth=rlu(0)   
           mcth=1    
           IF(rcth.GT.coef(isub,10)) mcth=2  
           IF(rcth.GT.coef(isub,10)+coef(isub,11)) mcth=3    
           IF(rcth.GT.coef(isub,10)+coef(isub,11)+coef(isub,12)) mcth=4  
           IF(rcth.GT.coef(isub,10)+coef(isub,11)+coef(isub,12)+ 
      &    coef(isub,13)) mcth=5 
           CALL pykmap(3,mcth,rlu(0))    
         ENDIF   
     
 C...Low-pT or multiple interactions (first semihard interaction).   
       ELSEIF(iset(isub).EQ.5) THEN  
         CALL pymult(3)  
         isub=mint(1)    
       ENDIF 
     
 C...Choose azimuthal angle. 
       vint(24)=paru(2)*rlu(0)   
     
 C...Check against user cuts on kinematics at parton level.  
       mint(51)=0    
       IF(isub.LE.90.OR.isub.GT.100) CALL pyklim(0)  
       IF(mint(51).NE.0) GOTO 100    
       IF(mint(82).EQ.1.AND.mstp(141).GE.1) THEN 
         mcut=0  
         IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)   
      &  CALL pykcut(mcut)   
         IF(mcut.NE.0) GOTO 100  
       ENDIF 
     
 C...Calculate differential cross-section for different subprocesses.    
       CALL pysigh(nchn,sigs)    
     
 C...Calculations for Monte Carlo estimate of all cross-sections.    
       IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN   
         xsec(isub,2)=xsec(isub,2)+sigs  
       ELSEIF(mint(82).EQ.1) THEN    
         xsec(isub,2)=xsec(isub,2)+xsec(isub,1)  
       ENDIF 
     
 C...Multiple interactions: store results of cross-section calculation.  
       IF(mint(43).EQ.4.AND.mstp(82).GE.3) THEN  
         vint(153)=sigs  
         CALL pymult(4)  
       ENDIF 
     
 C...Weighting using estimate of maximum of differential cross-section.  
       viol=sigs/xsec(isub,1)    
       IF(viol.LT.rlu(0)) GOTO 100   
     
 C...Check for possible violation of estimated maximum of differential   
 C...cross-section used in weighting.    
       IF(mstp(123).LE.0) THEN   
         IF(viol.GT.1.) THEN 
           WRITE(mstu(11),1000) viol,ngen(0,3)+1 
           WRITE(mstu(11),1100) isub,vint(21),vint(22),vint(23),vint(26) 
           stop  
         ENDIF   
       ELSEIF(mstp(123).EQ.1) THEN   
         IF(viol.GT.vint(108)) THEN  
           vint(108)=viol    
 C          IF(VIOL.GT.1.) THEN   
 C            WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1   
 C            WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),   
 C     &      VINT(26)    
 C          ENDIF 
         ENDIF   
       ELSEIF(viol.GT.vint(108)) THEN    
         vint(108)=viol  
         IF(viol.GT.1.) THEN 
           xdif=xsec(isub,1)*(viol-1.)   
           xsec(isub,1)=xsec(isub,1)+xdif    
           IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))    
      &    xsec(0,1)=xsec(0,1)+xdif  
 C          WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1 
 C          WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26) 
 C          IF(ISUB.LE.9) THEN    
 C            WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)  
 C          ELSEIF(ISUB.LE.99) THEN   
 C            WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)  
 C          ELSE  
 C            WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)  
 C          ENDIF 
           vint(108)=1.  
         ENDIF   
       ENDIF 
     
 C...Multiple interactions: choose impact parameter. 
       vint(148)=1.  
       IF(mint(43).EQ.4.AND.(isub.LE.90.OR.isub.GE.96).AND.mstp(82).GE.3)    
      &THEN  
         CALL pymult(5)  
         IF(vint(150).LT.rlu(0)) GOTO 100    
       ENDIF 
       IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN  
         IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+1    
         IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1    
       ENDIF 
       IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1  
     
 C...Choose flavour of reacting partons (and subprocess).    
       rsigs=sigs*rlu(0) 
       qt2=vint(48)  
       rqqbar=parp(87)*(1.-(qt2/(qt2+(parp(88)*parp(82))**2))**2)    
       IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.    
      &rlu(0).GT.rqqbar)) THEN   
         DO 190 ichn=1,nchn  
         kfl1=isig(ichn,1)   
         kfl2=isig(ichn,2)   
         mint(2)=isig(ichn,3)    
         rsigs=rsigs-sigh(ichn)  
         IF(rsigs.LE.0.) GOTO 210    
   190   CONTINUE    
     
 C...Multiple interactions: choose qqbar preferentially at small pT. 
       ELSEIF(isub.EQ.96) THEN   
         CALL pyspli(mint(11),21,kfl1,kfldum)    
         CALL pyspli(mint(12),21,kfl2,kfldum)    
         mint(1)=11  
         mint(2)=1   
         IF(kfl1.EQ.kfl2.AND.rlu(0).LT.0.5) mint(2)=2    
     
 C...Low-pT: choose string drawing configuration.    
       ELSE  
         kfl1=21 
         kfl2=21 
         rsigs=6.*rlu(0) 
         mint(2)=1   
         IF(rsigs.GT.1.) mint(2)=2   
         IF(rsigs.GT.2.) mint(2)=3   
       ENDIF 
     
 C...Reassign QCD process. Partons before initial state radiation.   
   210 IF(mint(2).GT.10) THEN    
         mint(1)=mint(2)/10  
         mint(2)=mod(mint(2),10) 
       ENDIF 
       mint(15)=kfl1 
       mint(16)=kfl2 
       mint(13)=mint(15) 
       mint(14)=mint(16) 
       vint(141)=vint(41)    
       vint(142)=vint(42)    
     
 C...Format statements for differential cross-section maximum violations.    
  1000 FORMAT(1x,'Error: maximum violated by',1p,e11.3,1x,   
      &'in event',1x,i7,'.'/1x,'Execution stopped!') 
  1100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p, 
      &e11.3,', y* =',e11.3,', cthe = ',0p,f11.7,', tau'' =',1p,e11.3)   
  1200 FORMAT(1x,'Warning: maximum violated by',1p,e11.3,1x, 
      &'in event',1x,i7) 
  1300 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,e11.3) 
  1400 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,e11.3) 
  1500 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,e11.3) 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyremn()

subroutine pyremn	(	IPU1,
		IPU2
	)

Definition at line 14117 of file hipyset1.35.f.

     
 C...Adds on target remnants (one or two from each side) and 
 C...includes primordial kT. 
       common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
       SAVE  /hiparnt/
       common/histrng/nfp(300,15),pphi(300,15),nft(300,15),pthi(300,15)
       SAVE  /histrng/
 C...COMMON BLOCK FROM HIJING
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       dimension kflch(2),kflsp(2),chi(2),pms(6),is(2),robo(5)   
     
 C...Special case for lepton-lepton interaction. 
       IF(mint(43).EQ.1) THEN    
         DO 100 jt=1,2   
         i=mint(83)+jt+2 
         k(i,1)=21   
         k(i,2)=k(i-2,2) 
         k(i,3)=i-2  
         DO 100 j=1,5    
   100   p(i,j)=p(i-2,j) 
       ENDIF 
     
 C...Find event type, set pointers.  
       IF(ipu1.EQ.0.AND.ipu2.EQ.0) RETURN    
       isub=mint(1)  
       ilep=0    
       IF(ipu1.EQ.0) ilep=1  
       IF(ipu2.EQ.0) ilep=2  
       IF(isub.EQ.95) ilep=-1    
       IF(ilep.EQ.1) iq=mint(84)+1   
       IF(ilep.EQ.2) iq=mint(84)+2   
       ip=max(ipu1,ipu2) 
       ilepr=mint(83)+5-ilep 
       ns=n  
     
 C...Define initial partons, including primordial kT.    
   110 DO 130 jt=1,2 
       i=mint(83)+jt+2   
       IF(jt.EQ.1) ipu=ipu1  
       IF(jt.EQ.2) ipu=ipu2  
       k(i,1)=21 
       k(i,3)=i-2    
       IF(isub.EQ.95) THEN   
         k(i,2)=21   
         shs=0.  
       ELSEIF(mint(40+jt).EQ.1.AND.ipu.NE.0) THEN    
         k(i,2)=k(ipu,2) 
         p(i,5)=p(ipu,5) 
         p(i,1)=0.   
         p(i,2)=0.   
         pms(jt)=p(i,5)**2   
       ELSEIF(ipu.NE.0) THEN 
         k(i,2)=k(ipu,2) 
         p(i,5)=p(ipu,5) 
 C...No primordial kT or chosen according to truncated Gaussian or   
 C...exponential.
 C
 c     X.N. Wang (7.22.97)
 c
         rpt1=0.0
         rpt2=0.0
         ss_w2=(pphi(ihnt2(11),4)+pthi(ihnt2(12),4))**2
      &       -(pphi(ihnt2(11),1)+pthi(ihnt2(12),1))**2
      &       -(pphi(ihnt2(11),2)+pthi(ihnt2(12),2))**2
      &       -(pphi(ihnt2(11),3)+pthi(ihnt2(12),3))**2
 C
 C********this is s of the current NN collision
         IF(ss_w2.LE.4.0*parp(93)**2) GOTO 1211
 c
         IF(ihpr2(5).LE.0) THEN
 120      IF(mstp(91).LE.0) THEN
                pt=0. 
              ELSEIF(mstp(91).EQ.1) THEN
                pt=parp(91)*sqrt(-log(rlu(0)))
              ELSE    
                rpt1=rlu(0)   
                rpt2=rlu(0)   
                pt=-parp(92)*log(rpt1*rpt2)   
              ENDIF   
              IF(pt.GT.parp(93)) GOTO 120 
          phi=paru(2)*rlu(0)  
          rpt1=pt*cos(phi)  
          rpt2=pt*sin(phi)
     ELSE IF(ihpr2(5).EQ.1) THEN
          IF(jt.EQ.1) jpt=nfp(ihnt2(11),11)
          IF(jt.EQ.2) jpt=nft(ihnt2(12),11)
 1205         ptgs=parp(91)*sqrt(-log(rlu(0)))
          IF(ptgs.GT.parp(93)) GO TO 1205
          phi=2.0*hipr1(40)*rlu(0)
          rpt1=ptgs*cos(phi)
          rpt2=ptgs*sin(phi)
          DO 1210 i_int=1,jpt-1
         pkcsq=parp(91)*sqrt(-log(rlu(0)))
         phi=2.0*hipr1(40)*rlu(0)
         rpt1=rpt1+pkcsq*cos(phi)
         rpt2=rpt2+pkcsq*sin(phi)
 1210         CONTINUE
              IF(rpt1**2+rpt2**2.GE.ss_w2/4.0) GO TO 1205
     ENDIF
 C     X.N. Wang
 C           ********When initial interaction among soft partons is
 C               assumed the primordial pt comes from the sum of
 C               pt of JPT-1 number of initial interaction, JPT
 C               is the number of interaction including present
 C               one that nucleon hassuffered 
 1211    p(i,1)=rpt1
     p(i,2)=rpt2  
         pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2   
       ELSE  
         k(i,2)=k(iq,2)  
         q2=vint(52) 
         p(i,5)=-sqrt(q2)    
         pms(jt)=-q2 
         shs=(1.-vint(43-jt))*q2/vint(43-jt)+vint(5-jt)**2   
       ENDIF 
   130 CONTINUE  
     
 C...Kinematics construction for initial partons.    
       i1=mint(83)+3 
       i2=mint(83)+4 
       IF(ilep.EQ.0) shs=vint(141)*vint(142)*vint(2)+    
      &(p(i1,1)+p(i2,1))**2+(p(i1,2)+p(i2,2))**2 
       shr=sqrt(max(0.,shs)) 
       IF(ilep.EQ.0) THEN    
         IF((shs-pms(1)-pms(2))**2-4.*pms(1)*pms(2).LE.0.) GOTO 110  
         p(i1,4)=0.5*(shr+(pms(1)-pms(2))/shr)   
         p(i1,3)=sqrt(max(0.,p(i1,4)**2-pms(1))) 
         p(i2,4)=shr-p(i1,4) 
         p(i2,3)=-p(i1,3)    
       ELSEIF(ilep.EQ.1) THEN    
         p(i1,4)=p(iq,4) 
         p(i1,3)=p(iq,3) 
         p(i2,4)=p(ip,4) 
         p(i2,3)=p(ip,3) 
       ELSEIF(ilep.EQ.2) THEN    
         p(i1,4)=p(ip,4) 
         p(i1,3)=p(ip,3) 
         p(i2,4)=p(iq,4) 
         p(i2,3)=p(iq,3) 
       ENDIF 
       IF(mint(43).EQ.1) RETURN  
     
 C...Transform partons to overall CM-frame (not for leptoproduction).    
       IF(ilep.EQ.0) THEN    
         robo(3)=(p(i1,1)+p(i2,1))/shr   
         robo(4)=(p(i1,2)+p(i2,2))/shr   
         CALL ludbrb(i1,i2,0.,0.,-dble(robo(3)),-dble(robo(4)),0d0)  
         robo(2)=ulangl(p(i1,1),p(i1,2)) 
         CALL ludbrb(i1,i2,0.,-robo(2),0d0,0d0,0d0)  
         robo(1)=ulangl(p(i1,3),p(i1,1)) 
         CALL ludbrb(i1,i2,-robo(1),0.,0d0,0d0,0d0)  
         nmax=max(mint(52),ipu1,ipu2)    
         CALL ludbrb(i1,nmax,robo(1),robo(2),dble(robo(3)),dble(robo(4)),    
      &  0d0)    
         robo(5)=max(-0.999999,min(0.999999,(vint(141)-vint(142))/   
      &  (vint(141)+vint(142)))) 
         CALL ludbrb(i1,nmax,0.,0.,0d0,0d0,dble(robo(5)))    
       ENDIF 
     
 C...Check invariant mass of remnant system: 
 C...hadronic events or leptoproduction. 
       IF(ilep.LE.0) THEN    
         IF(mstp(81).LE.0.OR.mstp(82).LE.0.OR.isub.EQ.95) THEN   
           vint(151)=0.  
           vint(152)=0.  
         ENDIF   
         peh=p(i1,4)+p(i2,4)+0.5*vint(1)*(vint(151)+vint(152))   
         pzh=p(i1,3)+p(i2,3)+0.5*vint(1)*(vint(151)-vint(152))   
         shh=(vint(1)-peh)**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+p(i2,2))**2- 
      &  pzh**2  
         pmmin=p(mint(83)+1,5)+p(mint(83)+2,5)+ulmass(k(i1,2))+  
      &  ulmass(k(i2,2)) 
         IF(shr.GE.vint(1).OR.shh.LE.(pmmin+parp(111))**2) THEN  
           mint(51)=1    
           RETURN    
         ENDIF   
         shr=sqrt(shh+(p(i1,1)+p(i2,1))**2+(p(i1,2)+p(i2,2))**2) 
       ELSE  
         pei=p(iq,4)+p(ip,4) 
         pzi=p(iq,3)+p(ip,3) 
         pms(ilep)=max(0.,pei**2-pzi**2) 
         pmmin=p(ilepr-2,5)+ulmass(k(ilepr,2))+sqrt(pms(ilep))   
         IF(shr.LE.pmmin+parp(111)) THEN 
           mint(51)=1    
           RETURN    
         ENDIF   
       ENDIF 
     
 C...Subdivide remnant if necessary, store first parton. 
   140 i=ns  
       DO 190 jt=1,2 
       IF(jt.EQ.ilep) GOTO 190   
       IF(jt.EQ.1) ipu=ipu1  
       IF(jt.EQ.2) ipu=ipu2  
       CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))  
       i=i+1 
       is(jt)=i  
       DO 150 j=1,5  
       k(i,j)=0  
       p(i,j)=0. 
   150 v(i,j)=0. 
       k(i,1)=3  
       k(i,2)=kflsp(jt)  
       k(i,3)=mint(83)+jt    
       p(i,5)=ulmass(k(i,2)) 
     
 C...First parton colour connections and transverse mass.    
       kfls=(3-kchg(lucomp(kflsp(jt)),2)*isign(1,kflsp(jt)))/2   
       k(i,kfls+3)=ipu   
       k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i    
       IF(kflch(jt).EQ.0) THEN   
         p(i,1)=-p(mint(83)+jt+2,1)  
         p(i,2)=-p(mint(83)+jt+2,2)  
         pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2   
     
 C...When extra remnant parton or hadron: find relative pT, store.   
       ELSE  
         CALL luptdi(1,p(i,1),p(i,2))    
         pms(jt+2)=p(i,5)**2+p(i,1)**2+p(i,2)**2 
         i=i+1   
         DO 160 j=1,5    
         k(i,j)=0    
         p(i,j)=0.   
   160   v(i,j)=0.   
         k(i,1)=1    
         k(i,2)=kflch(jt)    
         k(i,3)=mint(83)+jt  
         p(i,5)=ulmass(k(i,2))   
         p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1) 
         p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2) 
         pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2 
 C...Relative distribution of energy for particle into two jets. 
         imb=1   
         IF(mod(mint(10+jt)/1000,10).NE.0) imb=2 
         IF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN   
           chik=parp(92+2*imb)   
           IF(mstp(92).LE.1) THEN    
             IF(imb.EQ.1) chi(jt)=rlu(0) 
             IF(imb.EQ.2) chi(jt)=1.-sqrt(rlu(0))    
           ELSEIF(mstp(92).EQ.2) THEN    
             chi(jt)=1.-rlu(0)**(1./(1.+chik))   
           ELSEIF(mstp(92).EQ.3) THEN    
             cut=2.*0.3/vint(1)  
   170       chi(jt)=rlu(0)**2   
             IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25*(1.-chi(jt))**chik    
      &      .LT.rlu(0)) GOTO 170    
           ELSE  
             cut=2.*0.3/vint(1)  
             cutr=(1.+sqrt(1.+cut**2))/cut   
   180       chir=cut*cutr**rlu(0)   
             chi(jt)=(chir**2-cut**2)/(2.*chir)  
             IF((1.-chi(jt))**chik.LT.rlu(0)) GOTO 180   
           ENDIF 
 C...Relative distribution of energy for particle into jet plus particle.    
         ELSE    
           IF(mstp(92).LE.1) THEN    
             IF(imb.EQ.1) chi(jt)=rlu(0) 
             IF(imb.EQ.2) chi(jt)=1.-sqrt(rlu(0))    
           ELSE  
             chi(jt)=1.-rlu(0)**(1./(1.+parp(93+2*imb))) 
           ENDIF 
           IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1.-chi(jt)    
         ENDIF   
         pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1.-chi(jt))    
         kfls=kchg(lucomp(kflch(jt)),2)*isign(1,kflch(jt))   
         IF(kfls.NE.0) THEN  
           k(i,1)=3  
           kfls=(3-kfls)/2   
           k(i,kfls+3)=ipu   
           k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i    
         ENDIF   
       ENDIF 
   190 CONTINUE  
       IF(shr.LE.sqrt(pms(1))+sqrt(pms(2))) GOTO 140 
       n=i   
     
 C...Reconstruct kinematics of remnants. 
       DO 200 jt=1,2 
       IF(jt.EQ.ilep) GOTO 200   
       pe=0.5*(shr+(pms(jt)-pms(3-jt))/shr)  
       pz=sqrt(pe**2-pms(jt))    
       IF(kflch(jt).EQ.0) THEN   
         p(is(jt),4)=pe  
         p(is(jt),3)=pz*(-1)**(jt-1) 
       ELSE  
         pw1=chi(jt)*(pe+pz) 
         p(is(jt)+1,4)=0.5*(pw1+pms(jt+4)/pw1)   
         p(is(jt)+1,3)=0.5*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)  
         p(is(jt),4)=pe-p(is(jt)+1,4)    
         p(is(jt),3)=pz*(-1)**(jt-1)-p(is(jt)+1,3)   
       ENDIF 
   200 CONTINUE  
     
 C...Hadronic events: boost remnants to correct longitudinal frame.  
       IF(ilep.LE.0) THEN    
         CALL ludbrb(ns+1,n,0.,0.,0d0,0d0,-dble(pzh/(vint(1)-peh)))  
 C...Leptoproduction events: boost colliding subsystem.  
       ELSE  
         nmax=max(ip,mint(52))   
         pef=shr-pe  
         pzf=pz*(-1)**(ilep-1)   
         pt2=p(ilepr,1)**2+p(ilepr,2)**2 
         phipt=ulangl(p(ilepr,1),p(ilepr,2)) 
         CALL ludbrb(mint(84)+1,nmax,0.,-phipt,0d0,0d0,0d0)  
         rqp=p(iq,3)*(pt2+pei**2)-p(iq,4)*pei*pzi    
         sinth=p(iq,4)*sqrt(pt2*(pt2+pei**2)/(rqp**2+pt2*    
      &  p(iq,4)**2*pzi**2))*sign(1.,-rqp)   
         CALL ludbrb(mint(84)+1,nmax,asin(sinth),0.,0d0,0d0,0d0) 
         betax=(-pei*pzi*sinth+sqrt(pt2*(pt2+pei**2-(pzi*sinth)**2)))/   
      &  (pt2+pei**2)    
         CALL ludbrb(mint(84)+1,nmax,0.,0.,dble(betax),0d0,0d0)  
         CALL ludbrb(mint(84)+1,nmax,0.,phipt,0d0,0d0,0d0)   
         pem=p(iq,4)+p(ip,4) 
         pzm=p(iq,3)+p(ip,3) 
         betaz=(-pem*pzm+pzf*sqrt(pzf**2+pem**2-pzm**2))/(pzf**2+pem**2) 
         CALL ludbrb(mint(84)+1,nmax,0.,0.,0d0,0d0,dble(betaz))  
         CALL ludbrb(i1,i2,asin(sinth),0.,dble(betax),0d0,0d0)   
         CALL ludbrb(i1,i2,0.,phipt,0d0,0d0,dble(betaz)) 
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyresd()

subroutine pyresd ( )

Definition at line 14452 of file hipyset1.35.f.

     
 C...Allows resonances to decay (including parton showers for hadronic   
 C...channels).  
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       dimension iref(10,6),kdcy(2),kfl1(2),kfl2(2),nsd(2),ilin(6),  
      &coup(6,4),pk(6,4),pkk(6,6),cthe(2),phi(2),wdtp(0:40), 
      &wdte(0:40,0:5)    
       COMPLEX fgk,ha(6,6),hc(6,6)   
     
 C...The F, Xi and Xj functions of Gunion and Kunszt 
 C...(Phys. Rev. D33, 665, plus errata from the authors).    
       fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)* 
      &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))    
       digk(dt,du)=-4.*d34*d56+dt*(3.*dt+4.*du)+dt**2*(dt*du/(d34*d56)-  
      &2.*(1./d34+1./d56)*(dt+du)+2.*(d34/d56+d56/d34))  
       djgk(dt,du)=8.*(d34+d56)**2-8.*(d34+d56)*(dt+du)-6.*dt*du-    
      &2.*dt*du*(dt*du/(d34*d56)-2.*(1./d34+1./d56)*(dt+du)+ 
      &2.*(d34/d56+d56/d34)) 
     
 C...Define initial two objects, initialize loop.    
       isub=mint(1)  
       sh=vint(44)   
       iref(1,5)=0   
       iref(1,6)=0   
       IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN   
         iref(1,1)=mint(84)+2+iset(isub) 
         iref(1,2)=0 
         iref(1,3)=mint(83)+6+iset(isub) 
         iref(1,4)=0 
       ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN   
         iref(1,1)=mint(84)+1+iset(isub) 
         iref(1,2)=mint(84)+2+iset(isub) 
         iref(1,3)=mint(83)+5+iset(isub) 
         iref(1,4)=mint(83)+6+iset(isub) 
       ENDIF 
       np=1  
       ip=0  
   100 ip=ip+1   
       ninh=0    
     
 C...Loop over one/two resonances; reset decay rates.    
       jtmax=2   
       IF(ip.EQ.1.AND.(iset(isub).EQ.1.OR.iset(isub).EQ.3)) jtmax=1  
       DO 140 jt=1,jtmax 
       kdcy(jt)=0    
       kfl1(jt)=0    
       kfl2(jt)=0    
       nsd(jt)=iref(ip,jt)   
       id=iref(ip,jt)    
       IF(id.EQ.0) GOTO 140  
       kfa=iabs(k(id,2)) 
       IF(kfa.LT.23.OR.kfa.GT.40) GOTO 140   
       IF(mdcy(kfa,1).NE.0) THEN 
         IF(isub.EQ.1.OR.isub.EQ.141) mint(61)=1 
         CALL pywidt(kfa,p(id,5),wdtp,wdte)  
         IF(kchg(kfa,3).EQ.0) THEN   
           ipm=2 
         ELSE    
           ipm=(5+isign(1,k(id,2)))/2    
         ENDIF   
         IF(jtmax.EQ.1.OR.iabs(k(iref(ip,1),2)).NE.iabs(k(iref(ip,2),2)))    
      &  THEN    
           i12=4 
         ELSE    
           IF(jt.EQ.1) i12=int(4.5+rlu(0))   
           i12=9-i12 
         ENDIF   
         rkfl=(wdte(0,1)+wdte(0,ipm)+wdte(0,i12))*rlu(0) 
         DO 120 i=1,mdcy(kfa,3)  
         idc=i+mdcy(kfa,2)-1 
         kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))   
         kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))   
         rkfl=rkfl-(wdte(i,1)+wdte(i,ipm)+wdte(i,i12))   
         IF(rkfl.LE.0.) GOTO 130 
   120   CONTINUE    
   130   CONTINUE    
       ENDIF 
     
 C...Summarize result on decay channel chosen.   
       IF((kfa.EQ.23.OR.kfa.EQ.24).AND.kfl1(jt).EQ.0) ninh=ninh+1    
       IF(kfl1(jt).EQ.0) GOTO 140    
       kdcy(jt)=2    
       IF(iabs(kfl1(jt)).LE.10.OR.kfl1(jt).EQ.21) kdcy(jt)=1 
       IF((iabs(kfl1(jt)).GE.23.AND.iabs(kfl1(jt)).LE.25).OR.    
      &(iabs(kfl1(jt)).EQ.37)) kdcy(jt)=3    
       nsd(jt)=n 
     
 C...Fill decay products, prepared for parton showers for quarks.    
       IF(kdcy(jt).EQ.1) THEN    
         CALL lu2ent(-(n+1),kfl1(jt),kfl2(jt),p(id,5))   
       ELSE  
         CALL lu2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))  
       ENDIF 
       IF(jtmax.EQ.1) THEN   
         cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*rlu(0)  
         IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)    
         phi(jt)=vint(24)    
       ELSE  
         cthe(jt)=2.*rlu(0)-1.   
         phi(jt)=paru(2)*rlu(0)  
       ENDIF 
   140 CONTINUE  
       IF(mint(3).EQ.1.AND.ip.EQ.1) THEN 
         mint(25)=kfl1(1)    
         mint(26)=kfl2(1)    
       ENDIF 
       IF(jtmax.EQ.1.AND.kdcy(1).EQ.0) GOTO 530  
       IF(jtmax.EQ.2.AND.kdcy(1).EQ.0.AND.kdcy(2).EQ.0) GOTO 530 
       IF(mstp(45).LE.0.OR.iref(ip,2).EQ.0.OR.ninh.GE.1) GOTO 500    
       IF(k(iref(1,1),2).EQ.25.AND.ip.EQ.1) GOTO 500 
       IF(k(iref(1,1),2).EQ.25.AND.kdcy(1)*kdcy(2).EQ.0) GOTO 500    
     
 C...Order incoming partons and outgoing resonances. 
       ilin(1)=mint(84)+1    
       IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2   
       IF(k(ilin(1),2).EQ.21) ilin(1)=2*mint(84)+3-ilin(1)   
       ilin(2)=2*mint(84)+3-ilin(1)  
       imin=1    
       IF(iref(ip,5).EQ.25) imin=3   
       imax=2    
       iord=1    
       IF(k(iref(ip,1),2).EQ.23) iord=2  
       IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2   
       IF(iabs(k(iref(ip,iord),2)).EQ.25) iord=3-iord    
       IF(kdcy(iord).EQ.0) iord=3-iord   
     
 C...Order decay products of resonances. 
       DO 390 jt=iord,3-iord,3-2*iord    
       IF(kdcy(jt).EQ.0) THEN    
         ilin(imax+1)=nsd(jt)    
         imax=imax+1 
       ELSEIF(k(nsd(jt)+1,2).GT.0) THEN  
         ilin(imax+1)=n+2*jt-1   
         ilin(imax+2)=n+2*jt 
         imax=imax+2 
         k(n+2*jt-1,2)=k(nsd(jt)+1,2)    
         k(n+2*jt,2)=k(nsd(jt)+2,2)  
       ELSE  
         ilin(imax+1)=n+2*jt 
         ilin(imax+2)=n+2*jt-1   
         imax=imax+2 
         k(n+2*jt-1,2)=k(nsd(jt)+1,2)    
         k(n+2*jt,2)=k(nsd(jt)+2,2)  
       ENDIF 
   390 CONTINUE  
     
 C...Find charge, isospin, left- and righthanded couplings.  
       xw=paru(102)  
       DO 410 i=imin,imax    
       DO 400 j=1,4  
   400 coup(i,j)=0.  
       kfa=iabs(k(ilin(i),2))    
       IF(kfa.GT.20) GOTO 410    
       coup(i,1)=luchge(kfa)/3.  
       coup(i,2)=(-1)**mod(kfa,2)    
       coup(i,4)=-2.*coup(i,1)*xw    
       coup(i,3)=coup(i,2)+coup(i,4) 
   410 CONTINUE  
       sqmz=pmas(23,1)**2    
       gzmz=pmas(23,1)*pmas(23,2)    
       sqmw=pmas(24,1)**2    
       gzmw=pmas(24,1)*pmas(24,2)    
       sqmzp=pmas(32,1)**2   
       gzmzp=pmas(32,1)*pmas(32,2)   
     
 C...Select random angles; construct massless four-vectors.  
   420 DO 430 i=n+1,n+4  
       k(i,1)=1  
       DO 430 j=1,5  
   430 p(i,j)=0. 
       DO 440 jt=1,jtmax 
       IF(kdcy(jt).EQ.0) GOTO 440    
       id=iref(ip,jt)    
       p(n+2*jt-1,3)=0.5*p(id,5) 
       p(n+2*jt-1,4)=0.5*p(id,5) 
       p(n+2*jt,3)=-0.5*p(id,5)  
       p(n+2*jt,4)=0.5*p(id,5)   
       cthe(jt)=2.*rlu(0)-1. 
       phi(jt)=paru(2)*rlu(0)    
       CALL ludbrb(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),   
      &dble(p(id,1)/p(id,4)),dble(p(id,2)/p(id,4)),dble(p(id,3)/p(id,4)))    
   440 CONTINUE  
     
 C...Store incoming and outgoing momenta, with random rotation to    
 C...avoid accidental zeroes in HA expressions.  
       DO 450 i=1,imax   
       k(n+4+i,1)=1  
       p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+p(ilin(i),3)**2+  
      &p(ilin(i),5)**2)  
       p(n+4+i,5)=p(ilin(i),5)   
       DO 450 j=1,3  
   450 p(n+4+i,j)=p(ilin(i),j)   
       therr=acos(2.*rlu(0)-1.)  
       phirr=paru(2)*rlu(0)  
       CALL ludbrb(n+5,n+4+imax,therr,phirr,0d0,0d0,0d0) 
       DO 460 i=1,imax   
       DO 460 j=1,4  
   460 pk(i,j)=p(n+4+i,j)    
     
 C...Calculate internal products.    
       IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25) THEN   
         DO 470 i1=imin,imax-1   
         DO 470 i2=i1+1,imax 
         ha(i1,i2)=sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+pk(i2,3))/ 
      &  (1e-20+pk(i1,1)**2+pk(i1,2)**2))*cmplx(pk(i1,1),pk(i1,2))-  
      &  sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/   
      &  (1e-20+pk(i2,1)**2+pk(i2,2)**2))*cmplx(pk(i2,1),pk(i2,2))   
         hc(i1,i2)=conjg(ha(i1,i2))  
         IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)    
         IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)    
         ha(i2,i1)=-ha(i1,i2)    
   470   hc(i2,i1)=-hc(i1,i2)    
       ENDIF 
       DO 480 i=1,2  
       DO 480 j=1,4  
   480 pk(i,j)=-pk(i,j)  
       DO 490 i1=imin,imax-1 
       DO 490 i2=i1+1,imax   
       pkk(i1,i2)=2.*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-   
      &pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))  
   490 pkk(i2,i1)=pkk(i1,i2) 
     
       IF(iref(ip,5).EQ.25) THEN 
 C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons 
         wt=16.*pkk(3,5)*pkk(4,6)    
         IF(ip.EQ.1) wtmax=sh**2 
         IF(ip.GE.2) wtmax=p(iref(ip,6),5)**4    
     
       ELSEIF(isub.EQ.1) THEN    
         IF(kfa.NE.37) THEN  
 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons    
           ei=kchg(iabs(mint(15)),1)/3.  
           ai=sign(1.,ei+0.1)    
           vi=ai-4.*ei*xw    
           ef=kchg(kfa,1)/3. 
           af=sign(1.,ef+0.1)    
           vf=af-4.*ef*xw    
           gg=1. 
           gz=1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2) 
           zz=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)    
           IF(mstp(43).EQ.1) THEN    
 C...Only gamma* production included 
             gz=0.   
             zz=0.   
           ELSEIF(mstp(43).EQ.2) THEN    
 C...Only Z0 production included 
             gg=0.   
             gz=0.   
           ENDIF 
           asym=2.*(ei*ai*gz*ef*af+4.*vi*ai*zz*vf*af)/(ei**2*gg*ef**2+   
      &    ei*vi*gz*ef*vf+(vi**2+ai**2)*zz*(vf**2+af**2))    
           wt=1.+asym*cthe(jt)+cthe(jt)**2   
           wtmax=2.+abs(asym)    
         ELSE    
 C...Angular weight for gamma*/Z0 -> H+ + H- 
           wt=1.-cthe(jt)**2 
           wtmax=1.  
         ENDIF   
     
       ELSEIF(isub.EQ.2) THEN    
 C...Angular weight for W+/- -> 2 quarks/leptons 
         wt=(1.+cthe(jt))**2 
         wtmax=4.    
     
       ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN 
 C...Angular weight for f + fb -> gluon/gamma + Z0 ->    
 C...-> gluon/gamma + 2 quarks/leptons   
         wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)* 
      &  (pkk(1,3)**2+pkk(2,4)**2)+((coup(1,3)*coup(3,4))**2+    
      &  (coup(1,4)*coup(3,3))**2)*(pkk(1,4)**2+pkk(2,3)**2) 
         wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*  
      &  ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2) 
     
       ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN 
 C...Angular weight for f + fb' -> gluon/gamma + W+/- -> 
 C...-> gluon/gamma + 2 quarks/leptons   
         wt=pkk(1,3)**2+pkk(2,4)**2  
         wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2 
     
       ELSEIF(isub.EQ.22) THEN   
 C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons    
         s34=p(iref(ip,iord),5)**2   
         s56=p(iref(ip,3-iord),5)**2 
         ti=pkk(1,3)+pkk(1,4)+s34    
         ui=pkk(1,5)+pkk(1,6)+s56    
         wt=coup(1,3)**4*((coup(3,3)*coup(5,3)*abs(fgk(1,2,3,4,5,6)/ 
      &  ti+fgk(1,2,5,6,3,4)/ui))**2+(coup(3,4)*coup(5,3)*abs(   
      &  fgk(1,2,4,3,5,6)/ti+fgk(1,2,5,6,4,3)/ui))**2+(coup(3,3)*    
      &  coup(5,4)*abs(fgk(1,2,3,4,6,5)/ti+fgk(1,2,6,5,3,4)/ui))**2+ 
      &  (coup(3,4)*coup(5,4)*abs(fgk(1,2,4,3,6,5)/ti+fgk(1,2,6,5,4,3)/  
      &  ui))**2)+coup(1,4)**4*((coup(3,3)*coup(5,3)*abs(    
      &  fgk(2,1,5,6,3,4)/ti+fgk(2,1,3,4,5,6)/ui))**2+(coup(3,4)*    
      &  coup(5,3)*abs(fgk(2,1,6,5,3,4)/ti+fgk(2,1,3,4,6,5)/ui))**2+ 
      &  (coup(3,3)*coup(5,4)*abs(fgk(2,1,5,6,4,3)/ti+fgk(2,1,4,3,5,6)/  
      &  ui))**2+(coup(3,4)*coup(5,4)*abs(fgk(2,1,6,5,4,3)/ti+   
      &  fgk(2,1,4,3,6,5)/ui))**2)   
         wtmax=4.*s34*s56*(coup(1,3)**4+coup(1,4)**4)*(coup(3,3)**2+ 
      &  coup(3,4)**2)*(coup(5,3)**2+coup(5,4)**2)*4.*(ti/ui+ui/ti+  
      &  2.*sh*(s34+s56)/(ti*ui)-s34*s56*(1./ti**2+1./ui**2))    
     
       ELSEIF(isub.EQ.23) THEN   
 C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons    
         d34=p(iref(ip,iord),5)**2   
         d56=p(iref(ip,3-iord),5)**2 
         dt=pkk(1,3)+pkk(1,4)+d34    
         du=pkk(1,5)+pkk(1,6)+d56    
         cawz=coup(2,3)/sngl(dt)-2.*(1.-xw)*coup(1,2)/(sh-sqmw)  
         cbwz=coup(1,3)/sngl(du)+2.*(1.-xw)*coup(1,2)/(sh-sqmw)  
         wt=coup(5,3)**2*abs(cawz*fgk(1,2,3,4,5,6)+cbwz* 
      &  fgk(1,2,5,6,3,4))**2+coup(5,4)**2*abs(cawz* 
      &  fgk(1,2,3,4,6,5)+cbwz*fgk(1,2,6,5,3,4))**2  
         wtmax=4.*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*  
      &  digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))  
     
       ELSEIF(isub.EQ.24) THEN   
 C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0   
         wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)* 
      &  pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)* 
      &  coup(3,3))**2)*pkk(1,4)*pkk(2,3)    
         wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*  
      &  (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4)) 
     
       ELSEIF(isub.EQ.25) THEN   
 C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons    
         d34=p(iref(ip,iord),5)**2   
         d56=p(iref(ip,3-iord),5)**2 
         dt=pkk(1,3)+pkk(1,4)+d34    
         du=pkk(1,5)+pkk(1,6)+d56    
         cdww=(coup(1,3)*sqmz/(sh-sqmz)+coup(1,2))/sh    
         caww=cdww+0.5*(coup(1,2)+1.)/sngl(dt)   
         cbww=cdww+0.5*(coup(1,2)-1.)/sngl(du)   
         ccww=coup(1,4)*sqmz/(sh-sqmz)/sh    
         wt=abs(caww*fgk(1,2,3,4,5,6)-cbww*fgk(1,2,5,6,3,4))**2+ 
      &  ccww**2*abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))**2   
         wtmax=4.*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-caww* 
      &  cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du))) 
     
       ELSEIF(isub.EQ.26) THEN   
 C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0    
         wt=pkk(1,3)*pkk(2,4)    
         wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))   
     
       ELSEIF(isub.EQ.30) THEN   
 C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons  
         IF(k(ilin(1),2).GT.0) wt=((coup(1,3)*coup(3,3))**2+ 
      &  (coup(1,4)*coup(3,4))**2)*(pkk(1,4)**2+pkk(3,5)**2)+    
      &  ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*    
      &  (pkk(1,3)**2+pkk(4,5)**2)   
         IF(k(ilin(1),2).LT.0) wt=((coup(1,3)*coup(3,3))**2+ 
      &  (coup(1,4)*coup(3,4))**2)*(pkk(1,3)**2+pkk(4,5)**2)+    
      &  ((coup(1,3)*coup(3,4))**2+(coup(1,4)*coup(3,3))**2)*    
      &  (pkk(1,4)**2+pkk(3,5)**2)   
         wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*  
      &  ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2) 
     
       ELSEIF(isub.EQ.31) THEN   
 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons  
         IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2    
         IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2    
         wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2 
     
       ELSEIF(isub.EQ.141) THEN  
 C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons    
         ei=kchg(iabs(mint(15)),1)/3.    
         ai=sign(1.,ei+0.1)  
         vi=ai-4.*ei*xw  
         api=sign(1.,ei+0.1) 
         vpi=api-4.*ei*xw    
         ef=kchg(kfa,1)/3.   
         af=sign(1.,ef+0.1)  
         vf=af-4.*ef*xw  
         apf=sign(1.,ef+0.1) 
         vpf=apf-4.*ef*xw    
         gg=1.   
         gz=1./(8.*xw*(1.-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gzmz**2)   
         gzp=1./(8.*xw*(1.-xw))*sh*(sh-sqmzp)/((sh-sqmzp)**2+gzmzp**2)   
         zz=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmz)**2+gzmz**2)  
         zzp=2./(16.*xw*(1.-xw))**2* 
      &  sh**2*((sh-sqmz)*(sh-sqmzp)+gzmz*gzmzp)/    
      &  (((sh-sqmz)**2+gzmz**2)*((sh-sqmzp)**2+gzmzp**2))   
         zpzp=1./(16.*xw*(1.-xw))**2*sh**2/((sh-sqmzp)**2+gzmzp**2)  
         IF(mstp(44).EQ.1) THEN  
 C...Only gamma* production included 
           gz=0. 
           gzp=0.    
           zz=0. 
           zzp=0.    
           zpzp=0.   
         ELSEIF(mstp(44).EQ.2) THEN  
 C...Only Z0 production included 
           gg=0. 
           gz=0. 
           gzp=0.    
           zzp=0.    
           zpzp=0.   
         ELSEIF(mstp(44).EQ.3) THEN  
 C...Only Z'0 production included    
           gg=0. 
           gz=0. 
           gzp=0.    
           zz=0. 
           zzp=0.    
         ELSEIF(mstp(44).EQ.4) THEN  
 C...Only gamma*/Z0 production included  
           gzp=0.    
           zzp=0.    
           zpzp=0.   
         ELSEIF(mstp(44).EQ.5) THEN  
 C...Only gamma*/Z'0 production included 
           gz=0. 
           zz=0. 
           zzp=0.    
         ELSEIF(mstp(44).EQ.6) THEN  
 C...Only Z0/Z'0 production included 
           gg=0. 
           gz=0. 
           gzp=0.    
         ENDIF   
         asym=2.*(ei*ai*gz*ef*af+ei*api*gzp*ef*apf+4.*vi*ai*zz*vf*af+    
      &  (vi*api+vpi*ai)*zzp*(vf*apf+vpf*af)+4.*vpi*api*zpzp*vpf*apf)/   
      &  (ei**2*gg*ef**2+ei*vi*gz*ef*vf+ei*vpi*gzp*ef*vpf+   
      &  (vi**2+ai**2)*zz*(vf**2+af**2)+(vi*vpi+ai*api)*zzp* 
      &  (vf*vpf+af*apf)+(vpi**2+api**2)*zpzp*(vpf**2+apf**2))   
         wt=1.+asym*cthe(jt)+cthe(jt)**2 
         wtmax=2.+abs(asym)  
     
       ELSE  
         wt=1.   
         wtmax=1.    
       ENDIF 
 C...Obtain correct angular distribution by rejection techniques.    
       IF(wt.LT.rlu(0)*wtmax) GOTO 420   
     
 C...Construct massive four-vectors using angles chosen. Mark decayed    
 C...resonances, add documentation lines. Shower evolution.  
   500 DO 520 jt=1,jtmax 
       IF(kdcy(jt).EQ.0) GOTO 520    
       id=iref(ip,jt)    
       CALL ludbrb(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),   
      &dble(p(id,1)/p(id,4)),dble(p(id,2)/p(id,4)),dble(p(id,3)/p(id,4)))    
       k(id,1)=k(id,1)+10    
       k(id,4)=nsd(jt)+1 
       k(id,5)=nsd(jt)+2 
       idoc=mint(83)+mint(4) 
       DO 510 i=nsd(jt)+1,nsd(jt)+2  
       mint(4)=mint(4)+1 
       i1=mint(83)+mint(4)   
       k(i,3)=i1 
       k(i1,1)=21    
       k(i1,2)=k(i,2)    
       k(i1,3)=iref(ip,jt+2) 
       DO 510 j=1,5  
   510 p(i1,j)=p(i,j)    
       IF(jtmax.EQ.1) THEN   
         mint(7)=mint(83)+6+2*iset(isub) 
         mint(8)=mint(83)+7+2*iset(isub) 
       ENDIF 
       IF(mstp(71).GE.1.AND.kdcy(jt).EQ.1) CALL lushow(nsd(jt)+1,    
      &nsd(jt)+2,p(id,5))    
     
 C...Check if new resonances were produced, loop back if needed. 
       IF(kdcy(jt).NE.3) GOTO 520    
       np=np+1   
       iref(np,1)=nsd(jt)+1  
       iref(np,2)=nsd(jt)+2  
       iref(np,3)=idoc+1 
       iref(np,4)=idoc+2 
       iref(np,5)=k(iref(ip,jt),2)   
       iref(np,6)=iref(ip,jt)    
   520 CONTINUE  
   530 IF(ip.LT.np) GOTO 100 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyscat()

subroutine pyscat ( )

Definition at line 12225 of file hipyset1.35.f.

     
 C...Finds outgoing flavours and event type; sets up the kinematics  
 C...and colour flow of the hard scattering. 
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
       SAVE /pyint3/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
       dimension wdtp(0:40),wdte(0:40,0:5),pmq(2),z(2),cthe(2),phi(2)    
     
 C...Choice of subprocess, number of documentation lines.    
       isub=mint(1)  
       idoc=6+iset(isub) 
       IF(isub.EQ.95) idoc=8 
       mint(3)=idoc-6    
       IF(idoc.GE.9) idoc=idoc+2 
       mint(4)=idoc  
       ipu1=mint(84)+1   
       ipu2=mint(84)+2   
       ipu3=mint(84)+3   
       ipu4=mint(84)+4   
       ipu5=mint(84)+5   
       ipu6=mint(84)+6   
     
 C...Reset K, P and V vectors. Store incoming particles. 
       DO 100 jt=1,mstp(126)+10  
       i=mint(83)+jt 
       DO 100 j=1,5  
       k(i,j)=0  
       p(i,j)=0. 
   100 v(i,j)=0. 
       DO 110 jt=1,2 
       i=mint(83)+jt 
       k(i,1)=21 
       k(i,2)=mint(10+jt)    
       p(i,1)=0. 
       p(i,2)=0. 
       p(i,5)=vint(2+jt) 
       p(i,3)=vint(5)*(-1)**(jt+1)   
   110 p(i,4)=sqrt(p(i,3)**2+p(i,5)**2)  
       mint(6)=2 
       kfres=0   
     
 C...Store incoming partons in their CM-frame.   
       sh=vint(44)   
       shr=sqrt(sh)  
       shp=vint(26)*vint(2)  
       shpr=sqrt(shp)    
       shuser=shr    
       IF(iset(isub).GE.3) shuser=shpr   
       DO 120 jt=1,2 
       i=mint(84)+jt 
       k(i,1)=14 
       k(i,2)=mint(14+jt)    
       k(i,3)=mint(83)+2+jt  
   120 p(i,5)=ulmass(k(i,2)) 
       IF(p(ipu1,5)+p(ipu2,5).GE.shuser) THEN    
         p(ipu1,5)=0.    
         p(ipu2,5)=0.    
       ENDIF 
       p(ipu1,4)=0.5*(shuser+(p(ipu1,5)**2-p(ipu2,5)**2)/shuser) 
       p(ipu1,3)=sqrt(max(0.,p(ipu1,4)**2-p(ipu1,5)**2)) 
       p(ipu2,4)=shuser-p(ipu1,4)    
       p(ipu2,3)=-p(ipu1,3)  
     
 C...Copy incoming partons to documentation lines.   
       DO 130 jt=1,2 
       i1=mint(83)+4+jt  
       i2=mint(84)+jt    
       k(i1,1)=21    
       k(i1,2)=k(i2,2)   
       k(i1,3)=i1-2  
       DO 130 j=1,5  
   130 p(i1,j)=p(i2,j)   
     
 C...Choose new quark flavour for relevant annihilation graphs.  
       IF(isub.EQ.12.OR.isub.EQ.53) THEN 
         CALL pywidt(21,shr,wdtp,wdte)   
         rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*rlu(0) 
         DO 140 i=1,2*mstp(1)    
         kflq=i  
         rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))   
         IF(rkfl.LE.0.) GOTO 150 
   140   CONTINUE    
   150   CONTINUE    
       ENDIF 
     
 C...Final state flavours and colour flow: default values.   
       js=1  
       mint(21)=mint(15) 
       mint(22)=mint(16) 
       mint(23)=0    
       mint(24)=0    
       kcc=20    
       kcs=isign(1,mint(15)) 
     
       IF(isub.LE.10) THEN   
       IF(isub.EQ.1) THEN    
 C...f + fb -> gamma*/Z0.    
         kfres=23    
     
       ELSEIF(isub.EQ.2) THEN    
 C...f + fb' -> W+/- .   
         kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
         kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
         kfres=isign(24,kch1+kch2)   
     
       ELSEIF(isub.EQ.3) THEN    
 C...f + fb -> H0.   
         kfres=25    
     
       ELSEIF(isub.EQ.4) THEN    
 C...gamma + W+/- -> W+/-.   
     
       ELSEIF(isub.EQ.5) THEN    
 C...Z0 + Z0 -> H0.  
         xh=sh/shp   
         mint(21)=mint(15)   
         mint(22)=mint(16)   
         pmq(1)=ulmass(mint(21)) 
         pmq(2)=ulmass(mint(22)) 
   240   jt=int(1.5+rlu(0))  
         zmin=2.*pmq(jt)/shpr    
         zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
         zmax=min(1.-xh,zmax)    
         z(jt)=zmin+(zmax-zmin)*rlu(0)   
         IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
      &  (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 240 
         sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 240  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp) 
         cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
         cthe(jt)=min(1.,max(-1.,cthe(jt)))  
         z(3-jt)=1.-xh/(1.-z(jt))    
         sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 240  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
         cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
         cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
         phir=paru(2)*rlu(0) 
         cphi=cos(phir)  
         ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
         z1=2.-z(jt) 
         z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
         z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
         z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
      &  pmq(3-jt)**2/shp))  
         zmin=2.*pmq(3-jt)/shpr  
         zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
         zmax=min(1.-xh,zmax)    
         IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 240 
         kcc=22  
         kfres=25    
     
       ELSEIF(isub.EQ.6) THEN    
 C...Z0 + W+/- -> W+/-.  
     
       ELSEIF(isub.EQ.7) THEN    
 C...W+ + W- -> Z0.  
     
       ELSEIF(isub.EQ.8) THEN    
 C...W+ + W- -> H0.  
         xh=sh/shp   
   250   DO 280 jt=1,2   
         i=mint(14+jt)   
         ia=iabs(i)  
         IF(ia.LE.10) THEN   
           rvckm=vint(180+i)*rlu(0)  
           DO 270 j=1,mstp(1)    
           ib=2*j-1+mod(ia,2)    
           ipm=(5-isign(1,i))/2  
           idc=j+mdcy(ia,2)+2    
           IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 270  
           mint(20+jt)=isign(ib,i)   
           rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)   
           IF(rvckm.LE.0.) GOTO 280  
   270     CONTINUE  
         ELSE    
           ib=2*((ia+1)/2)-1+mod(ia,2)   
           mint(20+jt)=isign(ib,i)   
         ENDIF   
   280   pmq(jt)=ulmass(mint(20+jt)) 
         jt=int(1.5+rlu(0))  
         zmin=2.*pmq(jt)/shpr    
         zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
         zmax=min(1.-xh,zmax)    
         z(jt)=zmin+(zmax-zmin)*rlu(0)   
         IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
      &  (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 250 
         sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 250  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp) 
         cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
         cthe(jt)=min(1.,max(-1.,cthe(jt)))  
         z(3-jt)=1.-xh/(1.-z(jt))    
         sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 250  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
         cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
         cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
         phir=paru(2)*rlu(0) 
         cphi=cos(phir)  
         ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
         z1=2.-z(jt) 
         z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
         z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
         z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
      &  pmq(3-jt)**2/shp))  
         zmin=2.*pmq(3-jt)/shpr  
         zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
         zmax=min(1.-xh,zmax)    
         IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 250 
         kcc=22  
         kfres=25    
       ENDIF 
     
       ELSEIF(isub.LE.20) THEN   
       IF(isub.EQ.11) THEN   
 C...f + f' -> f + f'; th = (p(f)-p(f))**2.  
         kcc=mint(2) 
         IF(mint(15)*mint(16).LT.0) kcc=kcc+2    
     
       ELSEIF(isub.EQ.12) THEN   
 C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.   
         mint(21)=isign(kflq,mint(15))   
         mint(22)=-mint(21)  
         kcc=4   
     
       ELSEIF(isub.EQ.13) THEN   
 C...f + fb -> g + g; th arbitrary.  
         mint(21)=21 
         mint(22)=21 
         kcc=mint(2)+4   
     
       ELSEIF(isub.EQ.14) THEN   
 C...f + fb -> g + gam; th arbitrary.    
         IF(rlu(0).GT.0.5) js=2  
         mint(20+js)=21  
         mint(23-js)=22  
         kcc=17+js   
     
       ELSEIF(isub.EQ.15) THEN   
 C...f + fb -> g + Z0; th arbitrary. 
         IF(rlu(0).GT.0.5) js=2  
         mint(20+js)=21  
         mint(23-js)=23  
         kcc=17+js   
     
       ELSEIF(isub.EQ.16) THEN   
 C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 
         kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
         kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
         IF(mint(15)*(kch1+kch2).LT.0) js=2  
         mint(20+js)=21  
         mint(23-js)=isign(24,kch1+kch2) 
         kcc=17+js   
     
       ELSEIF(isub.EQ.17) THEN   
 C...f + fb -> g + H0; th arbitrary. 
         IF(rlu(0).GT.0.5) js=2  
         mint(20+js)=21  
         mint(23-js)=25  
         kcc=17+js   
     
       ELSEIF(isub.EQ.18) THEN   
 C...f + fb -> gamma + gamma; th arbitrary.  
         mint(21)=22 
         mint(22)=22 
     
       ELSEIF(isub.EQ.19) THEN   
 C...f + fb -> gamma + Z0; th arbitrary. 
         IF(rlu(0).GT.0.5) js=2  
         mint(20+js)=22  
         mint(23-js)=23  
     
       ELSEIF(isub.EQ.20) THEN   
 C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2. 
         kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
         kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
         IF(mint(15)*(kch1+kch2).LT.0) js=2  
         mint(20+js)=22  
         mint(23-js)=isign(24,kch1+kch2) 
       ENDIF 
     
       ELSEIF(isub.LE.30) THEN   
       IF(isub.EQ.21) THEN   
 C...f + fb -> gamma + H0; th arbitrary. 
         IF(rlu(0).GT.0.5) js=2  
         mint(20+js)=22  
         mint(23-js)=25  
     
       ELSEIF(isub.EQ.22) THEN   
 C...f + fb -> Z0 + Z0; th arbitrary.    
         mint(21)=23 
         mint(22)=23 
     
       ELSEIF(isub.EQ.23) THEN   
 C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    
         kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
         kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
         IF(mint(15)*(kch1+kch2).LT.0) js=2  
         mint(20+js)=23  
         mint(23-js)=isign(24,kch1+kch2) 
     
       ELSEIF(isub.EQ.24) THEN   
 C...f + fb -> Z0 + H0; th arbitrary.    
         IF(rlu(0).GT.0.5) js=2  
         mint(20+js)=23  
         mint(23-js)=25  
     
       ELSEIF(isub.EQ.25) THEN   
 C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.    
         mint(21)=-isign(24,mint(15))    
         mint(22)=-mint(21)  
     
       ELSEIF(isub.EQ.26) THEN   
 C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.    
         kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
         kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
         IF(mint(15)*(kch1+kch2).GT.0) js=2  
         mint(20+js)=isign(24,kch1+kch2) 
         mint(23-js)=25  
     
       ELSEIF(isub.EQ.27) THEN   
 C...f + fb -> H0 + H0.  
     
       ELSEIF(isub.EQ.28) THEN   
 C...f + g -> f + g; th = (p(f)-p(f))**2.    
         kcc=mint(2)+6   
         IF(mint(15).EQ.21) kcc=kcc+2    
         IF(mint(15).NE.21) kcs=isign(1,mint(15))    
         IF(mint(16).NE.21) kcs=isign(1,mint(16))    
     
       ELSEIF(isub.EQ.29) THEN   
 C...f + g -> f + gamma; th = (p(f)-p(f))**2.    
         IF(mint(15).EQ.21) js=2 
         mint(23-js)=22  
         kcc=15+js   
         kcs=isign(1,mint(14+js))    
     
       ELSEIF(isub.EQ.30) THEN   
 C...f + g -> f + Z0; th = (p(f)-p(f))**2.   
         IF(mint(15).EQ.21) js=2 
         mint(23-js)=23  
         kcc=15+js   
         kcs=isign(1,mint(14+js))    
       ENDIF 
     
       ELSEIF(isub.LE.40) THEN   
       IF(isub.EQ.31) THEN   
 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.    
         IF(mint(15).EQ.21) js=2 
         i=mint(14+js)   
         ia=iabs(i)  
         mint(23-js)=isign(24,kchg(ia,1)*i)  
         rvckm=vint(180+i)*rlu(0)    
         DO 220 j=1,mstp(1)  
         ib=2*j-1+mod(ia,2)  
         ipm=(5-isign(1,i))/2    
         idc=j+mdcy(ia,2)+2  
         IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 220    
         mint(20+js)=isign(ib,i) 
         rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2) 
         IF(rvckm.LE.0.) GOTO 230    
   220   CONTINUE    
   230   kcc=15+js   
         kcs=isign(1,mint(14+js))    
     
       ELSEIF(isub.EQ.32) THEN   
 C...f + g -> f + H0; th = (p(f)-p(f))**2.   
         IF(mint(15).EQ.21) js=2 
         mint(23-js)=25  
         kcc=15+js   
         kcs=isign(1,mint(14+js))    
     
       ELSEIF(isub.EQ.33) THEN   
 C...f + gamma -> f + g. 
     
       ELSEIF(isub.EQ.34) THEN   
 C...f + gamma -> f + gamma. 
     
       ELSEIF(isub.EQ.35) THEN   
 C...f + gamma -> f + Z0.    
     
       ELSEIF(isub.EQ.36) THEN   
 C...f + gamma -> f' + W+/-. 
     
       ELSEIF(isub.EQ.37) THEN   
 C...f + gamma -> f + H0.    
     
       ELSEIF(isub.EQ.38) THEN   
 C...f + Z0 -> f + g.    
     
       ELSEIF(isub.EQ.39) THEN   
 C...f + Z0 -> f + gamma.    
     
       ELSEIF(isub.EQ.40) THEN   
 C...f + Z0 -> f + Z0.   
       ENDIF 
     
       ELSEIF(isub.LE.50) THEN   
       IF(isub.EQ.41) THEN   
 C...f + Z0 -> f' + W+/-.    
     
       ELSEIF(isub.EQ.42) THEN   
 C...f + Z0 -> f + H0.   
     
       ELSEIF(isub.EQ.43) THEN   
 C...f + W+/- -> f' + g. 
     
       ELSEIF(isub.EQ.44) THEN   
 C...f + W+/- -> f' + gamma. 
     
       ELSEIF(isub.EQ.45) THEN   
 C...f + W+/- -> f' + Z0.    
     
       ELSEIF(isub.EQ.46) THEN   
 C...f + W+/- -> f' + W+/-.  
     
       ELSEIF(isub.EQ.47) THEN   
 C...f + W+/- -> f' + H0.    
     
       ELSEIF(isub.EQ.48) THEN   
 C...f + H0 -> f + g.    
     
       ELSEIF(isub.EQ.49) THEN   
 C...f + H0 -> f + gamma.    
     
       ELSEIF(isub.EQ.50) THEN   
 C...f + H0 -> f + Z0.   
       ENDIF 
     
       ELSEIF(isub.LE.60) THEN   
       IF(isub.EQ.51) THEN   
 C...f + H0 -> f' + W+/-.    
     
       ELSEIF(isub.EQ.52) THEN   
 C...f + H0 -> f + H0.   
     
       ELSEIF(isub.EQ.53) THEN   
 C...g + g -> f + fb; th arbitrary.  
         kcs=(-1)**int(1.5+rlu(0))   
         mint(21)=isign(kflq,kcs)    
         mint(22)=-mint(21)  
         kcc=mint(2)+10  
     
       ELSEIF(isub.EQ.54) THEN   
 C...g + gamma -> f + fb.    
     
       ELSEIF(isub.EQ.55) THEN   
 C...g + Z0 -> f + fb.   
     
       ELSEIF(isub.EQ.56) THEN   
 C...g + W+/- -> f + fb'.    
     
       ELSEIF(isub.EQ.57) THEN   
 C...g + H0 -> f + fb.   
     
       ELSEIF(isub.EQ.58) THEN   
 C...gamma + gamma -> f + fb.    
     
       ELSEIF(isub.EQ.59) THEN   
 C...gamma + Z0 -> f + fb.   
     
       ELSEIF(isub.EQ.60) THEN   
 C...gamma + W+/- -> f + fb'.    
       ENDIF 
     
       ELSEIF(isub.LE.70) THEN   
       IF(isub.EQ.61) THEN   
 C...gamma + H0 -> f + fb.   
     
       ELSEIF(isub.EQ.62) THEN   
 C...Z0 + Z0 -> f + fb.  
     
       ELSEIF(isub.EQ.63) THEN   
 C...Z0 + W+/- -> f + fb'.   
     
       ELSEIF(isub.EQ.64) THEN   
 C...Z0 + H0 -> f + fb.  
     
       ELSEIF(isub.EQ.65) THEN   
 C...W+ + W- -> f + fb.  
     
       ELSEIF(isub.EQ.66) THEN   
 C...W+/- + H0 -> f + fb'.   
     
       ELSEIF(isub.EQ.67) THEN   
 C...H0 + H0 -> f + fb.  
     
       ELSEIF(isub.EQ.68) THEN   
 C...g + g -> g + g; th arbitrary.   
         kcc=mint(2)+12  
         kcs=(-1)**int(1.5+rlu(0))   
     
       ELSEIF(isub.EQ.69) THEN   
 C...gamma + gamma -> W+ + W-.   
     
       ELSEIF(isub.EQ.70) THEN   
 C...gamma + W+/- -> gamma + W+/-    
       ENDIF 
     
       ELSEIF(isub.LE.80) THEN   
       IF(isub.EQ.71.OR.isub.EQ.72) THEN 
 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-. 
         xh=sh/shp   
         mint(21)=mint(15)   
         mint(22)=mint(16)   
         pmq(1)=ulmass(mint(21)) 
         pmq(2)=ulmass(mint(22)) 
   290   jt=int(1.5+rlu(0))  
         zmin=2.*pmq(jt)/shpr    
         zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
         zmax=min(1.-xh,zmax)    
         z(jt)=zmin+(zmax-zmin)*rlu(0)   
         IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
      &  (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 290 
         sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 290  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp) 
         cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
         cthe(jt)=min(1.,max(-1.,cthe(jt)))  
         z(3-jt)=1.-xh/(1.-z(jt))    
         sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 290  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
         cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
         cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
         phir=paru(2)*rlu(0) 
         cphi=cos(phir)  
         ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
         z1=2.-z(jt) 
         z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
         z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
         z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
      &  pmq(3-jt)**2/shp))  
         zmin=2.*pmq(3-jt)/shpr  
         zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
         zmax=min(1.-xh,zmax)    
         IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 290 
         kcc=22  
     
       ELSEIF(isub.EQ.73) THEN   
 C...Z0 + W+/- -> Z0 + W+/-. 
         xh=sh/shp   
   300   jt=int(1.5+rlu(0))  
         i=mint(14+jt)   
         ia=iabs(i)  
         IF(ia.LE.10) THEN   
           rvckm=vint(180+i)*rlu(0)  
           DO 320 j=1,mstp(1)    
           ib=2*j-1+mod(ia,2)    
           ipm=(5-isign(1,i))/2  
           idc=j+mdcy(ia,2)+2    
           IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 320  
           mint(20+jt)=isign(ib,i)   
           rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)   
           IF(rvckm.LE.0.) GOTO 330  
   320     CONTINUE  
         ELSE    
           ib=2*((ia+1)/2)-1+mod(ia,2)   
           mint(20+jt)=isign(ib,i)   
         ENDIF   
   330   pmq(jt)=ulmass(mint(20+jt)) 
         mint(23-jt)=mint(17-jt) 
         pmq(3-jt)=ulmass(mint(23-jt))   
         jt=int(1.5+rlu(0))  
         zmin=2.*pmq(jt)/shpr    
         zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
         zmax=min(1.-xh,zmax)    
         z(jt)=zmin+(zmax-zmin)*rlu(0)   
         IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
      &  (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 300 
         sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 300  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp) 
         cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
         cthe(jt)=min(1.,max(-1.,cthe(jt)))  
         z(3-jt)=1.-xh/(1.-z(jt))    
         sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 300  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
         cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
         cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
         phir=paru(2)*rlu(0) 
         cphi=cos(phir)  
         ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
         z1=2.-z(jt) 
         z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
         z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
         z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
      &  pmq(3-jt)**2/shp))  
         zmin=2.*pmq(3-jt)/shpr  
         zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
         zmax=min(1.-xh,zmax)    
         IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 300 
         kcc=22  
     
       ELSEIF(isub.EQ.74) THEN   
 C...Z0 + H0 -> Z0 + H0. 
     
       ELSEIF(isub.EQ.75) THEN   
 C...W+ + W- -> gamma + gamma.   
     
       ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN 
 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-. 
         xh=sh/shp   
   340   DO 370 jt=1,2   
         i=mint(14+jt)   
         ia=iabs(i)  
         IF(ia.LE.10) THEN   
           rvckm=vint(180+i)*rlu(0)  
           DO 360 j=1,mstp(1)    
           ib=2*j-1+mod(ia,2)    
           ipm=(5-isign(1,i))/2  
           idc=j+mdcy(ia,2)+2    
           IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 360  
           mint(20+jt)=isign(ib,i)   
           rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)   
           IF(rvckm.LE.0.) GOTO 370  
   360     CONTINUE  
         ELSE    
           ib=2*((ia+1)/2)-1+mod(ia,2)   
           mint(20+jt)=isign(ib,i)   
         ENDIF   
   370   pmq(jt)=ulmass(mint(20+jt)) 
         jt=int(1.5+rlu(0))  
         zmin=2.*pmq(jt)/shpr    
         zmax=1.-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/(shpr*(shpr-pmq(3-jt)))  
         zmax=min(1.-xh,zmax)    
         z(jt)=zmin+(zmax-zmin)*rlu(0)   
         IF(-1.+(1.+xh)/(1.-z(jt))-xh/(1.-z(jt))**2.LT.  
      &  (1.-xh)**2/(4.*xh)*rlu(0)) GOTO 340 
         sqc1=1.-4.*pmq(jt)**2/(z(jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 340  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp) 
         cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1   
         cthe(jt)=min(1.,max(-1.,cthe(jt)))  
         z(3-jt)=1.-xh/(1.-z(jt))    
         sqc1=1.-4.*pmq(3-jt)**2/(z(3-jt)**2*shp)    
         IF(sqc1.LT.1.e-8) GOTO 340  
         c1=sqrt(sqc1)   
         c2=1.+2.*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp) 
         cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2.*rlu(0)-1.)*c1))/c1 
         cthe(3-jt)=min(1.,max(-1.,cthe(3-jt)))  
         phir=paru(2)*rlu(0) 
         cphi=cos(phir)  
         ang=cthe(1)*cthe(2)-sqrt(1.-cthe(1)**2)*sqrt(1.-cthe(2)**2)*cphi    
         z1=2.-z(jt) 
         z2=ang*sqrt(z(jt)**2-4.*pmq(jt)**2/shp) 
         z3=1.-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp    
         z(3-jt)=2./(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*    
      &  pmq(3-jt)**2/shp))  
         zmin=2.*pmq(3-jt)/shpr  
         zmax=1.-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))    
         zmax=min(1.-xh,zmax)    
         IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 340 
         kcc=22  
     
       ELSEIF(isub.EQ.78) THEN   
 C...W+/- + H0 -> W+/- + H0. 
     
       ELSEIF(isub.EQ.79) THEN   
 C...H0 + H0 -> H0 + H0. 
       ENDIF 
     
       ELSEIF(isub.LE.90) THEN   
       IF(isub.EQ.81) THEN   
 C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.   
         mint(21)=isign(mint(46),mint(15))   
         mint(22)=-mint(21)  
         kcc=4   
     
       ELSEIF(isub.EQ.82) THEN   
 C...g + g -> Q + Qb; th arbitrary.  
         kcs=(-1)**int(1.5+rlu(0))   
         mint(21)=isign(mint(46),kcs)    
         mint(22)=-mint(21)  
         kcc=mint(2)+10  
       ENDIF 
     
       ELSEIF(isub.LE.100) THEN  
       IF(isub.EQ.95) THEN   
 C...Low-pT ( = energyless g + g -> g + g).  
         kcc=mint(2)+12  
         kcs=(-1)**int(1.5+rlu(0))   
     
       ELSEIF(isub.EQ.96) THEN   
 C...Multiple interactions (should be reassigned to QCD process).    
       ENDIF 
     
       ELSEIF(isub.LE.110) THEN  
       IF(isub.EQ.101) THEN  
 C...g + g -> gamma*/Z0. 
         kcc=21  
         kfres=22    
     
       ELSEIF(isub.EQ.102) THEN  
 C...g + g -> H0.    
         kcc=21  
         kfres=25    
       ENDIF 
     
       ELSEIF(isub.LE.120) THEN  
       IF(isub.EQ.111) THEN  
 C...f + fb -> g + H0; th arbitrary. 
         IF(rlu(0).GT.0.5) js=2  
         mint(20+js)=21  
         mint(23-js)=25  
         kcc=17+js   
     
       ELSEIF(isub.EQ.112) THEN  
 C...f + g -> f + H0; th = (p(f) - p(f))**2. 
         IF(mint(15).EQ.21) js=2 
         mint(23-js)=25  
         kcc=15+js   
         kcs=isign(1,mint(14+js))    
     
       ELSEIF(isub.EQ.113) THEN  
 C...g + g -> g + H0; th arbitrary.  
         IF(rlu(0).GT.0.5) js=2  
         mint(23-js)=25  
         kcc=22+js   
         kcs=(-1)**int(1.5+rlu(0))   
     
       ELSEIF(isub.EQ.114) THEN  
 C...g + g -> gamma + gamma; th arbitrary.   
         IF(rlu(0).GT.0.5) js=2  
         mint(21)=22 
         mint(22)=22 
         kcc=21  
     
       ELSEIF(isub.EQ.115) THEN  
 C...g + g -> gamma + Z0.    
     
       ELSEIF(isub.EQ.116) THEN  
 C...g + g -> Z0 + Z0.   
     
       ELSEIF(isub.EQ.117) THEN  
 C...g + g -> W+ + W-.   
       ENDIF 
     
       ELSEIF(isub.LE.140) THEN  
       IF(isub.EQ.121) THEN  
 C...g + g -> f + fb + H0.   
       ENDIF 
     
       ELSEIF(isub.LE.160) THEN  
       IF(isub.EQ.141) THEN  
 C...f + fb -> gamma*/Z0/Z'0.    
         kfres=32    
     
       ELSEIF(isub.EQ.142) THEN  
 C...f + fb' -> H+/-.    
         kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))   
         kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))   
         kfres=isign(37,kch1+kch2)   
     
       ELSEIF(isub.EQ.143) THEN  
 C...f + fb' -> R.   
         kfres=isign(40,mint(15)+mint(16))   
       ENDIF 
     
       ELSE  
       IF(isub.EQ.161) THEN  
 C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.    
         IF(mint(16).EQ.21) js=2 
         ia=iabs(mint(17-js))    
         mint(20+js)=isign(37,kchg(ia,1)*mint(17-js))    
         ja=ia+mod(ia,2)-mod(ia+1,2) 
         mint(23-js)=isign(ja,mint(17-js))   
         kcc=18-js   
         IF(mint(15).NE.21) kcs=isign(1,mint(15))    
         IF(mint(16).NE.21) kcs=isign(1,mint(16))    
       ENDIF 
       ENDIF 
     
       IF(idoc.EQ.7) THEN    
 C...Resonance not decaying: store colour connection indices.    
         i=mint(83)+7    
         k(ipu3,1)=1 
         k(ipu3,2)=kfres 
         k(ipu3,3)=i 
         p(ipu3,4)=shuser    
         p(ipu3,5)=shuser    
         k(ipu1,4)=ipu2  
         k(ipu1,5)=ipu2  
         k(ipu2,4)=ipu1  
         k(ipu2,5)=ipu1  
         k(i,1)=21   
         k(i,2)=kfres    
         p(i,4)=shuser   
         p(i,5)=shuser   
         n=ipu3  
         mint(21)=kfres  
         mint(22)=0  
     
       ELSEIF(idoc.EQ.8) THEN    
 C...2 -> 2 processes: store outgoing partons in their CM-frame. 
         DO 390 jt=1,2   
         i=mint(84)+2+jt 
         k(i,1)=1    
         IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3   
         k(i,2)=mint(20+jt)  
         k(i,3)=mint(83)+idoc+jt-2   
         IF(iabs(k(i,2)).LE.10.OR.k(i,2).EQ.21) THEN 
           p(i,5)=ulmass(k(i,2)) 
         ELSE    
           p(i,5)=sqrt(vint(63+mod(js+jt,2)))    
         ENDIF   
   390   CONTINUE    
         IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN 
           kfa1=iabs(mint(21))   
           kfa2=iabs(mint(22))   
           IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))  
      &    THEN  
             mint(51)=1  
             RETURN  
           ENDIF 
           p(ipu3,5)=0.  
           p(ipu4,5)=0.  
         ENDIF   
         p(ipu3,4)=0.5*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr) 
         p(ipu3,3)=sqrt(max(0.,p(ipu3,4)**2-p(ipu3,5)**2))   
         p(ipu4,4)=shr-p(ipu3,4) 
         p(ipu4,3)=-p(ipu3,3)    
         n=ipu4  
         mint(7)=mint(83)+7  
         mint(8)=mint(83)+8  
     
 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4). 
         CALL ludbrb(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)  
     
       ELSEIF(idoc.EQ.9) THEN    
 C'''2 -> 3 processes:   
     
       ELSEIF(idoc.EQ.11) THEN   
 C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons. 
         phi(1)=paru(2)*rlu(0)   
         phi(2)=phi(1)-phir  
         DO 400 jt=1,2   
         i=mint(84)+2+jt 
         k(i,1)=1    
         IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3   
         k(i,2)=mint(20+jt)  
         k(i,3)=mint(83)+idoc+jt-2   
         p(i,5)=ulmass(k(i,2))   
         IF(0.5*shpr*z(jt).LE.p(i,5)) p(i,5)=0.  
         pabs=sqrt(max(0.,(0.5*shpr*z(jt))**2-p(i,5)**2))    
         ptabs=pabs*sqrt(max(0.,1.-cthe(jt)**2)) 
         p(i,1)=ptabs*cos(phi(jt))   
         p(i,2)=ptabs*sin(phi(jt))   
         p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)   
         p(i,4)=0.5*shpr*z(jt)   
         izw=mint(83)+6+jt   
         k(izw,1)=21 
         k(izw,2)=23 
         IF(isub.EQ.8) k(izw,2)=isign(24,luchge(mint(14+jt)))    
         k(izw,3)=izw-2  
         p(izw,1)=-p(i,1)    
         p(izw,2)=-p(i,2)    
         p(izw,3)=(0.5*shpr-pabs*cthe(jt))*(-1)**(jt+1)  
         p(izw,4)=0.5*shpr*(1.-z(jt))    
   400   p(izw,5)=-sqrt(max(0.,p(izw,3)**2+ptabs**2-p(izw,4)**2))    
         i=mint(83)+9    
         k(ipu5,1)=1 
         k(ipu5,2)=kfres 
         k(ipu5,3)=i 
         p(ipu5,5)=shr   
         p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)  
         p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)  
         p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)  
         p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)  
         k(i,1)=21   
         k(i,2)=kfres    
         DO 410 j=1,5    
   410   p(i,j)=p(ipu5,j)    
         n=ipu5  
         mint(23)=kfres  
     
       ELSEIF(idoc.EQ.12) THEN   
 C...Z0 and W+/- scattering: store bosons and outgoing partons.  
         phi(1)=paru(2)*rlu(0)   
         phi(2)=phi(1)-phir  
         DO 420 jt=1,2   
         i=mint(84)+2+jt 
         k(i,1)=1    
         IF(iabs(mint(20+jt)).LE.10.OR.mint(20+jt).EQ.21) k(i,1)=3   
         k(i,2)=mint(20+jt)  
         k(i,3)=mint(83)+idoc+jt-2   
         p(i,5)=ulmass(k(i,2))   
         IF(0.5*shpr*z(jt).LE.p(i,5)) p(i,5)=0.  
         pabs=sqrt(max(0.,(0.5*shpr*z(jt))**2-p(i,5)**2))    
         ptabs=pabs*sqrt(max(0.,1.-cthe(jt)**2)) 
         p(i,1)=ptabs*cos(phi(jt))   
         p(i,2)=ptabs*sin(phi(jt))   
         p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)   
         p(i,4)=0.5*shpr*z(jt)   
         izw=mint(83)+6+jt   
         k(izw,1)=21 
         IF(mint(14+jt).EQ.mint(20+jt)) THEN 
           k(izw,2)=23   
         ELSE    
           k(izw,2)=isign(24,luchge(mint(14+jt))-luchge(mint(20+jt)))    
         ENDIF   
         k(izw,3)=izw-2  
         p(izw,1)=-p(i,1)    
         p(izw,2)=-p(i,2)    
         p(izw,3)=(0.5*shpr-pabs*cthe(jt))*(-1)**(jt+1)  
         p(izw,4)=0.5*shpr*(1.-z(jt))    
         p(izw,5)=-sqrt(max(0.,p(izw,3)**2+ptabs**2-p(izw,4)**2))    
         ipu=mint(84)+4+jt   
         k(ipu,1)=3  
         k(ipu,2)=kfpr(isub,jt)  
         k(ipu,3)=mint(83)+8+jt  
         IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN 
           p(ipu,5)=ulmass(k(ipu,2)) 
         ELSE    
           p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))  
         ENDIF   
         mint(22+jt)=k(izw,2)    
   420   CONTINUE    
         IF(isub.EQ.72) k(mint(84)+4+int(1.5+rlu(0)),2)=-24  
 C...Find rotation and boost for hard scattering subsystem.  
         i1=mint(83)+7   
         i2=mint(83)+8   
         bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))   
         beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))   
         bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))   
         gamcm=(p(i1,4)+p(i2,4))/shr 
         bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3) 
         px=p(i1,1)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*bexcm 
         py=p(i1,2)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*beycm 
         pz=p(i1,3)+gamcm*(gamcm/(1.+gamcm)*bepcm-p(i1,4))*bezcm 
         thecm=ulangl(pz,sqrt(px**2+py**2))  
         phicm=ulangl(px,py) 
 C...Store hard scattering subsystem. Rotate and boost it.   
         sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4.*p(ipu5,5)**2*    
      &  p(ipu6,5)**2    
         pabs=sqrt(max(0.,sqlam/(4.*sh)))    
         cthwz=vint(23)  
         sthwz=sqrt(max(0.,1.-cthwz**2)) 
         phiwz=vint(24)-phicm    
         p(ipu5,1)=pabs*sthwz*cos(phiwz) 
         p(ipu5,2)=pabs*sthwz*sin(phiwz) 
         p(ipu5,3)=pabs*cthwz    
         p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)    
         p(ipu6,1)=-p(ipu5,1)    
         p(ipu6,2)=-p(ipu5,2)    
         p(ipu6,3)=-p(ipu5,3)    
         p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)    
         CALL ludbrb(ipu5,ipu6,thecm,phicm,dble(bexcm),dble(beycm),  
      &  dble(bezcm))    
         DO 430 jt=1,2   
         i1=mint(83)+8+jt    
         i2=mint(84)+4+jt    
         k(i1,1)=21  
         k(i1,2)=k(i2,2) 
         DO 430 j=1,5    
   430   p(i1,j)=p(i2,j) 
         n=ipu6  
         mint(7)=mint(83)+9  
         mint(8)=mint(83)+10 
       ENDIF 
     
       IF(idoc.GE.8) THEN    
 C...Store colour connection indices.    
         DO 440 j=1,2    
         jc=j    
         IF(kcs.EQ.-1) jc=3-j    
         IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=    
      &  k(ipu1,j+3)+mint(84)+icol(kcc,1,jc) 
         IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=    
      &  k(ipu2,j+3)+mint(84)+icol(kcc,2,jc) 
         IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)= 
      &  mstu(5)*(mint(84)+icol(kcc,3,jc))   
   440   IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)= 
      &  mstu(5)*(mint(84)+icol(kcc,4,jc))   
     
 C...Copy outgoing partons to documentation lines.   
         DO 450 i=1,2    
         i1=mint(83)+idoc-2+i    
         i2=mint(84)+2+i 
         k(i1,1)=21  
         k(i1,2)=k(i2,2) 
         IF(idoc.LE.9) k(i1,3)=0 
         IF(idoc.GE.11) k(i1,3)=mint(83)+2+i 
         DO 450 j=1,5    
   450   p(i1,j)=p(i2,j) 
       ENDIF 
       mint(52)=n    
     
 C...Low-pT events: remove gluons used for string drawing purposes.  
       IF(isub.EQ.95) THEN   
         k(ipu3,1)=k(ipu3,1)+10  
         k(ipu4,1)=k(ipu4,1)+10  
         DO 460 j=41,66  
   460   vint(j)=0.  
         DO 470 i=mint(83)+5,mint(83)+8  
         DO 470 j=1,5    
   470   p(i,j)=0.   
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pysigh()

subroutine pysigh	(	NCHN,
		SIGS
	)

Definition at line 16170 of file hipyset1.35.f.

     
 C...Differential matrix elements for all included subprocesses. 
 C...Note that what is coded is (disregarding the COMFAC factor) 
 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,  
 C...when d(sigma-hat) is given in the zero-width limit, the delta   
 C...function in tau is replaced by a Breit-Wigner:  
 C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);   
 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);   
 C...i.e., dimensionless quantities. COMFAC contains the factor  
 C...pi/s and the conversion factor from GeV^-2 to mb.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
       SAVE /pyint3/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
       dimension x(2),xpq(-6:6),kfac(2,-40:40),wdtp(0:40),wdte(0:40,0:5) 
     
 C...Reset number of channels and cross-section. 
       nchn=0    
       sigs=0.   
     
 C...Read kinematical variables and limits.  
       isub=mint(1)  
       taumin=vint(11)   
       ystmin=vint(12)   
       ctnmin=vint(13)   
       ctpmin=vint(14)   
       xt2min=vint(15)   
       taupmn=vint(16)   
       tau=vint(21)  
       yst=vint(22)  
       cth=vint(23)  
       xt2=vint(25)  
       taup=vint(26) 
       taumax=vint(31)   
       ystmax=vint(32)   
       ctnmax=vint(33)   
       ctpmax=vint(34)   
       xt2max=vint(35)   
       taupmx=vint(36)   
     
 C...Derive kinematical quantities.  
       IF(iset(isub).LE.2.OR.iset(isub).EQ.5) THEN   
         x(1)=sqrt(tau)*exp(yst) 
         x(2)=sqrt(tau)*exp(-yst)    
       ELSE  
         x(1)=sqrt(taup)*exp(yst)    
         x(2)=sqrt(taup)*exp(-yst)   
       ENDIF 
       IF(mint(43).EQ.4.AND.iset(isub).GE.1.AND. 
      &(x(1).GT.0.999.OR.x(2).GT.0.999)) RETURN  
       sh=tau*vint(2)    
       sqm3=vint(63) 
       sqm4=vint(64) 
       rm3=sqm3/sh   
       rm4=sqm4/sh   
       be34=sqrt((1.-rm3-rm4)**2-4.*rm3*rm4) 
       rpts=4.*vint(71)**2/sh    
       be34l=sqrt(max(0.,(1.-rm3-rm4)**2-4.*rm3*rm4-rpts))   
       rm34=2.*rm3*rm4   
       rsqm=1.+rm34  
       rthm=(4.*rm3*rm4+rpts)/(1.-rm3-rm4+be34l) 
       th=-0.5*sh*max(rthm,1.-rm3-rm4-be34*cth)  
       uh=-0.5*sh*max(rthm,1.-rm3-rm4+be34*cth)  
       sqpth=0.25*sh*be34**2*(1.-cth**2) 
       sh2=sh**2 
       th2=th**2 
       uh2=uh**2 
     
 C...Choice of Q2 scale. 
       IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN   
         q2=sh   
       ELSEIF(mod(iset(isub),2).EQ.0.OR.iset(isub).EQ.5) THEN    
         IF(mstp(32).EQ.1) THEN  
           q2=2.*sh*th*uh/(sh**2+th**2+uh**2)    
         ELSEIF(mstp(32).EQ.2) THEN  
           q2=sqpth+0.5*(sqm3+sqm4)  
         ELSEIF(mstp(32).EQ.3) THEN  
           q2=min(-th,-uh)   
         ELSEIF(mstp(32).EQ.4) THEN  
           q2=sh 
         ENDIF   
         IF(iset(isub).EQ.5.AND.mstp(82).GE.2) q2=q2+parp(82)**2 
       ENDIF 
     
 C...Store derived kinematical quantities.   
       vint(41)=x(1) 
       vint(42)=x(2) 
       vint(44)=sh   
       vint(43)=sqrt(sh) 
       vint(45)=th   
       vint(46)=uh   
       vint(48)=sqpth    
       vint(47)=sqrt(sqpth)  
       vint(50)=taup*vint(2) 
       vint(49)=sqrt(max(0.,vint(50)))   
       vint(52)=q2   
       vint(51)=sqrt(q2) 
     
 C...Calculate parton structure functions.   
       IF(iset(isub).LE.0) GOTO 145  
       IF(mint(43).GE.2) THEN    
         q2sf=q2 
         IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN 
           q2sf=pmas(23,1)**2    
           IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77) q2sf=pmas(24,1)**2  
         ENDIF   
         DO 100 i=3-mint(41),mint(42)    
         xsf=x(i)    
         IF(iset(isub).EQ.5) xsf=x(i)/vint(142+i)    
         CALL pystfu(mint(10+i),xsf,q2sf,xpq,i)    
         DO 100 kfl=-6,6 
   100   xsfx(i,kfl)=xpq(kfl)
       ENDIF 
     
 C...Calculate alpha_strong and K-factor.    
       IF(mstp(33).NE.3) as=ulalps(q2)   
       fack=1.   
       faca=1.   
       IF(mstp(33).EQ.1) THEN    
         fack=parp(31)   
       ELSEIF(mstp(33).EQ.2) THEN    
         fack=parp(31)   
         faca=parp(32)/parp(31)  
       ELSEIF(mstp(33).EQ.3) THEN    
         q2as=parp(33)*q2    
         IF(iset(isub).EQ.5.AND.mstp(82).GE.2) q2as=q2as+    
      &  paru(112)*parp(82)  
         as=ulalps(q2as) 
       ENDIF 
       radc=1.+as/paru(1)    
     
 C...Set flags for allowed reacting partons/leptons. 
       DO 130 i=1,2  
       DO 110 j=-40,40   
   110 kfac(i,j)=0   
       IF(mint(40+i).EQ.1) THEN  
         kfac(i,mint(10+i))=1    
       ELSE  
         DO 120 j=-40,40 
         kfac(i,j)=kfin(i,j) 
         IF(abs(j).GT.mstp(54).AND.j.NE.21) kfac(i,j)=0  
         IF(abs(j).LE.6) THEN    
           IF(xsfx(i,j).LT.1.e-10) kfac(i,j)=0   
         ELSEIF(j.EQ.21) THEN    
           IF(xsfx(i,0).LT.1.e-10) kfac(i,21)=0  
         ENDIF   
   120   CONTINUE    
       ENDIF 
   130 CONTINUE  
     
 C...Lower and upper limit for flavour loops.    
       min1=0    
       max1=0    
       min2=0    
       max2=0    
       DO 140 j=-20,20   
       IF(kfac(1,-j).EQ.1) min1=-j   
       IF(kfac(1,j).EQ.1) max1=j 
       IF(kfac(2,-j).EQ.1) min2=-j   
       IF(kfac(2,j).EQ.1) max2=j 
   140 CONTINUE  
       mina=min(min1,min2)   
       maxa=max(max1,max2)   
     
 C...Common conversion factors (including Jacobian) for subprocesses.    
       sqmz=pmas(23,1)**2    
       gmmz=pmas(23,1)*pmas(23,2)    
       sqmw=pmas(24,1)**2    
       gmmw=pmas(24,1)*pmas(24,2)    
       sqmh=pmas(25,1)**2    
       gmmh=pmas(25,1)*pmas(25,2)    
       sqmzp=pmas(32,1)**2   
       gmmzp=pmas(32,1)*pmas(32,2)   
       sqmhc=pmas(37,1)**2   
       gmmhc=pmas(37,1)*pmas(37,2)   
       sqmr=pmas(40,1)**2    
       gmmr=pmas(40,1)*pmas(40,2)    
       aem=paru(101) 
       xw=paru(102)  
     
 C...Phase space integral in tau and y*. 
       comfac=paru(1)*paru(5)/vint(2)    
       IF(mint(43).EQ.4) comfac=comfac*fack  
       IF((mint(43).GE.2.OR.iset(isub).EQ.3.OR.iset(isub).EQ.4).AND. 
      &iset(isub).NE.5) THEN 
         atau0=log(taumax/taumin)    
         atau1=(taumax-taumin)/(taumax*taumin)   
         h1=coef(isub,1)+(atau0/atau1)*coef(isub,2)/tau  
         IF(mint(72).GE.1) THEN  
           taur1=vint(73)    
           gamr1=vint(74)    
           atau2=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1  
           atau3=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/    
      &    gamr1 
           h1=h1+(atau0/atau2)*coef(isub,3)/(tau+taur1)+ 
      &    (atau0/atau3)*coef(isub,4)*tau/((tau-taur1)**2+gamr1**2)  
         ENDIF   
         IF(mint(72).EQ.2) THEN  
           taur2=vint(75)    
           gamr2=vint(76)    
           atau4=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2  
           atau5=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/    
      &    gamr2 
           h1=h1+(atau0/atau4)*coef(isub,5)/(tau+taur2)+ 
      &    (atau0/atau5)*coef(isub,6)*tau/((tau-taur2)**2+gamr2**2)  
         ENDIF   
         comfac=comfac*atau0/(tau*h1)    
       ENDIF 
       IF(mint(43).EQ.4.AND.iset(isub).NE.5) THEN    
         ayst0=ystmax-ystmin 
         ayst1=0.5*(ystmax-ystmin)**2    
         ayst2=ayst1 
         ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))  
         h2=(ayst0/ayst1)*coef(isub,7)*(yst-ystmin)+(ayst0/ayst2)*   
      &  coef(isub,8)*(ystmax-yst)+(ayst0/ayst3)*coef(isub,9)/cosh(yst)  
         comfac=comfac*ayst0/h2  
       ENDIF 
     
 C...2 -> 1 processes: reduction in angular part of phase space integral 
 C...for case of decaying resonance. 
       acth0=ctnmax-ctnmin+ctpmax-ctpmin 
       IF((iset(isub).EQ.1.OR.iset(isub).EQ.3).AND.  
      &mdcy(kfpr(isub,1),1).EQ.1) THEN   
         IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37) THEN   
           comfac=comfac*0.5*acth0   
         ELSE    
           comfac=comfac*0.125*(3.*acth0+ctnmax**3-ctnmin**3+    
      &    ctpmax**3-ctpmin**3)  
         ENDIF   
     
 C...2 -> 2 processes: angular part of phase space integral. 
       ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN   
         acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/    
      &  (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))  
         acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/    
      &  (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))  
         acth3=1./max(rm34,rsqm-ctnmax)-1./max(rm34,rsqm-ctnmin)+    
      &  1./max(rm34,rsqm-ctpmax)-1./max(rm34,rsqm-ctpmin)   
         acth4=1./max(rm34,rsqm+ctnmin)-1./max(rm34,rsqm+ctnmax)+    
      &  1./max(rm34,rsqm+ctpmin)-1./max(rm34,rsqm+ctpmax)   
         h3=coef(isub,10)+   
      &  (acth0/acth1)*coef(isub,11)/max(rm34,rsqm-cth)+ 
      &  (acth0/acth2)*coef(isub,12)/max(rm34,rsqm+cth)+ 
      &  (acth0/acth3)*coef(isub,13)/max(rm34,rsqm-cth)**2+  
      &  (acth0/acth4)*coef(isub,14)/max(rm34,rsqm+cth)**2   
         comfac=comfac*acth0*0.5*be34/h3 
       ENDIF 
     
 C...2 -> 3, 4 processes: phace space integral in tau'.  
       IF(mint(43).GE.2.AND.(iset(isub).EQ.3.OR.iset(isub).EQ.4)) THEN   
         ataup0=log(taupmx/taupmn)   
         ataup1=((1.-tau/taupmx)**4-(1.-tau/taupmn)**4)/(4.*tau) 
         h4=coef(isub,15)+   
      &  ataup0/ataup1*coef(isub,16)/taup*(1.-tau/taup)**3   
         IF(1.-tau/taup.GT.1.e-4) THEN   
           fzw=(1.+tau/taup)*log(taup/tau)-2.*(1.-tau/taup)  
         ELSE    
           fzw=1./6.*(1.-tau/taup)**3*tau/taup   
         ENDIF   
         comfac=comfac*ataup0*fzw/h4 
       ENDIF 
     
 C...Phase space integral for low-pT and multiple interactions.  
       IF(iset(isub).EQ.5) THEN  
         comfac=paru(1)*paru(5)*fack*0.5*vint(2)/sh2 
         atau0=log(2.*(1.+sqrt(1.-xt2))/xt2-1.)  
         atau1=2.*atan(1./xt2-1.)/sqrt(xt2)  
         h1=coef(isub,1)+(atau0/atau1)*coef(isub,2)/sqrt(tau)    
         comfac=comfac*atau0/h1  
         ayst0=ystmax-ystmin 
         ayst1=0.5*(ystmax-ystmin)**2    
         ayst3=2.*(atan(exp(ystmax))-atan(exp(ystmin)))  
         h2=(ayst0/ayst1)*coef(isub,7)*(yst-ystmin)+(ayst0/ayst1)*   
      &  coef(isub,8)*(ystmax-yst)+(ayst0/ayst3)*coef(isub,9)/cosh(yst)  
         comfac=comfac*ayst0/h2  
         IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1./vint(149)-1.)    
 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is 
 C...introduced to make cross-section finite for xT2 -> 0.   
         IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*  
      &  (1.+vint(149))) 
       ENDIF 
     
 C...A: 2 -> 1, tree diagrams.   
     
   145 IF(isub.LE.10) THEN   
       IF(isub.EQ.1) THEN    
 C...f + fb -> gamma*/Z0.    
         mint(61)=2  
         CALL pywidt(23,sqrt(sh),wdtp,wdte)  
         facz=comfac*aem**2*4./3.    
         DO 150 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 150    
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         facf=1. 
         IF(iabs(i).LE.10) facf=faca/3.  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facf*facz*(ei**2*vint(111)+ei*vi/(8.*xw*(1.-xw))*    
      &  sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)*vint(112)+(vi**2+ai**2)/    
      &  (16.*xw*(1.-xw))**2*sh2/((sh-sqmz)**2+gmmz**2)*vint(114))   
   150   CONTINUE    
     
       ELSEIF(isub.EQ.2) THEN    
 C...f + fb' -> W+/-.    
         CALL pywidt(24,sqrt(sh),wdtp,wdte)  
         facw=comfac*(aem/xw)**2*1./24*sh2/((sh-sqmw)**2+gmmw**2)    
         DO 170 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 170   
         ia=iabs(i)  
         DO 160 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 160   
         ja=iabs(j)  
         IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 160  
         IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10)) GOTO 160 
         kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
         facf=1. 
         IF(ia.LE.10) facf=vckm((ia+1)/2,(ja+1)/2)*faca/3.   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=facf*facw*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))   
   160   CONTINUE    
   170   CONTINUE    
     
       ELSEIF(isub.EQ.3) THEN    
 C...f + fb -> H0.   
         CALL pywidt(25,sqrt(sh),wdtp,wdte)  
         fach=comfac*(aem/xw)**2*1./48.*(sh/sqmw)**2*    
      &  sh2/((sh-sqmh)**2+gmmh**2)*(wdte(0,1)+wdte(0,2)+wdte(0,4))  
         DO 180 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 180    
         rmq=pmas(iabs(i),1)**2/sh   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=fach*rmq*sqrt(max(0.,1.-4.*rmq)) 
   180   CONTINUE    
     
       ELSEIF(isub.EQ.4) THEN    
 C...gamma + W+/- -> W+/-.   
     
       ELSEIF(isub.EQ.5) THEN    
 C...Z0 + Z0 -> H0.  
         CALL pywidt(25,sqrt(sh),wdtp,wdte)  
         fach=comfac*1./(128.*paru(1)**2*16.*(1.-xw)**3)*(aem/xw)**4*    
      &  (sh/sqmw)**2*sh2/((sh-sqmh)**2+gmmh**2)*    
      &  (wdte(0,1)+wdte(0,2)+wdte(0,4)) 
         DO 200 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 200   
         DO 190 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 190   
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         ej=kchg(iabs(j),1)/3.   
         aj=sign(1.,ej)  
         vj=aj-4.*ej*xw  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fach*(vi**2+ai**2)*(vj**2+aj**2) 
   190   CONTINUE    
   200   CONTINUE    
     
       ELSEIF(isub.EQ.6) THEN    
 C...Z0 + W+/- -> W+/-.  
     
       ELSEIF(isub.EQ.7) THEN    
 C...W+ + W- -> Z0.  
     
       ELSEIF(isub.EQ.8) THEN    
 C...W+ + W- -> H0.  
         CALL pywidt(25,sqrt(sh),wdtp,wdte)  
         fach=comfac*1./(128*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2*   
      &  sh2/((sh-sqmh)**2+gmmh**2)*(wdte(0,1)+wdte(0,2)+wdte(0,4))  
         DO 220 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 220   
         ei=sign(1.,float(i))*kchg(iabs(i),1)    
         DO 210 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 210   
         ej=sign(1.,float(j))*kchg(iabs(j),1)    
         IF(ei*ej.GT.0.) GOTO 210    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fach*vint(180+i)*vint(180+j) 
   210   CONTINUE    
   220   CONTINUE    
       ENDIF 
     
 C...B: 2 -> 2, tree diagrams.   
     
       ELSEIF(isub.LE.20) THEN   
       IF(isub.EQ.11) THEN   
 C...f + f' -> f + f'.   
         facqq1=comfac*as**2*4./9.*(sh2+uh2)/th2 
         facqqb=comfac*as**2*4./9.*((sh2+uh2)/th2*faca-  
      &  mstp(34)*2./3.*uh2/(sh*th)) 
         facqq2=comfac*as**2*4./9.*((sh2+th2)/uh2-   
      &  mstp(34)*2./3.*sh2/(th*uh)) 
         DO 240 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 240   
         DO 230 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 230   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=facqq1   
         IF(i.EQ.-j) sigh(nchn)=facqqb   
         IF(i.EQ.j) THEN 
           sigh(nchn)=0.5*sigh(nchn) 
           nchn=nchn+1   
           isig(nchn,1)=i    
           isig(nchn,2)=j    
           isig(nchn,3)=2    
           sigh(nchn)=0.5*facqq2 
         ENDIF   
   230   CONTINUE    
   240   CONTINUE    
     
       ELSEIF(isub.EQ.12) THEN   
 C...f + fb -> f' + fb' (q + qb -> q' + qb' only).   
         CALL pywidt(21,sqrt(sh),wdtp,wdte)  
         facqqb=comfac*as**2*4./9.*(th2+uh2)/sh2*(wdte(0,1)+wdte(0,2)+   
      &  wdte(0,3)+wdte(0,4))    
         DO 250 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 250    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facqqb   
   250   CONTINUE    
     
       ELSEIF(isub.EQ.13) THEN   
 C...f + fb -> g + g (q + qb -> g + g only). 
         facgg1=comfac*as**2*32./27.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2) 
         facgg2=comfac*as**2*32./27.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2) 
         DO 260 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 260    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=0.5*facgg1   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=2  
         sigh(nchn)=0.5*facgg2   
   260   CONTINUE    
     
       ELSEIF(isub.EQ.14) THEN   
 C...f + fb -> g + gamma (q + qb -> g + gamma only). 
         facgg=comfac*as*aem*8./9.*(th2+uh2)/(th*uh) 
         DO 270 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 270    
         ei=kchg(iabs(i),1)/3.   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facgg*ei**2  
   270   CONTINUE    
     
       ELSEIF(isub.EQ.15) THEN   
 C...f + fb -> g + Z0 (q + qb -> g + Z0 only).   
         faczg=comfac*as*aem/(xw*(1.-xw))*1./18.*    
      &  (th2+uh2+2.*sqm4*sh)/(th*uh)    
         faczg=faczg*wids(23,2)  
         DO 280 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 280    
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=faczg*(vi**2+ai**2)  
   280   CONTINUE    
     
       ELSEIF(isub.EQ.16) THEN   
 C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only). 
         facwg=comfac*as*aem/xw*2./9.*(th2+uh2+2.*sqm4*sh)/(th*uh)   
         DO 300 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 300   
         ia=iabs(i)  
         DO 290 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 290   
         ja=iabs(j)  
         IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 290  
         kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
         fckm=1. 
         IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=facwg*fckm*wids(24,(5-kchw)/2)   
   290   CONTINUE    
   300   CONTINUE    
     
       ELSEIF(isub.EQ.17) THEN   
 C...f + fb -> g + H0 (q + qb -> g + H0 only).   
     
       ELSEIF(isub.EQ.18) THEN   
 C...f + fb -> gamma + gamma.    
         facgg=comfac*faca*aem**2*1./3.*(th2+uh2)/(th*uh)    
         DO 310 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 310    
         ei=kchg(iabs(i),1)/3.   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facgg*ei**4  
   310   CONTINUE    
     
       ELSEIF(isub.EQ.19) THEN   
 C...f + fb -> gamma + Z0.   
         facgz=comfac*faca*aem**2/(xw*(1.-xw))*1./24.*   
      &  (th2+uh2+2.*sqm4*sh)/(th*uh)    
         facgz=facgz*wids(23,2)  
         DO 320 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 320    
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facgz*ei**2*(vi**2+ai**2)    
   320   CONTINUE    
     
       ELSEIF(isub.EQ.20) THEN   
 C...f + fb' -> gamma + W+/-.    
         facgw=comfac*faca*aem**2/xw*1./6.*  
      &  ((2.*uh-th)/(3.*(sh-sqm4)))**2*(th2+uh2+2.*sqm4*sh)/(th*uh) 
         DO 340 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 340   
         ia=iabs(i)  
         DO 330 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 330   
         ja=iabs(j)  
         IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 330  
         kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
         fckm=1. 
         IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=facgw*fckm*wids(24,(5-kchw)/2)   
   330   CONTINUE    
   340   CONTINUE    
       ENDIF 
     
       ELSEIF(isub.LE.30) THEN   
       IF(isub.EQ.21) THEN   
 C...f + fb -> gamma + H0.   
     
       ELSEIF(isub.EQ.22) THEN   
 C...f + fb -> Z0 + Z0.  
         faczz=comfac*faca*(aem/(xw*(1.-xw)))**2*1./768.*    
      &  (uh/th+th/uh+2.*(sqm3+sqm4)*sh/(th*uh)- 
      &  sqm3*sqm4*(1./th2+1./uh2))  
         faczz=faczz*wids(23,1)  
         DO 350 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 350    
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=faczz*(vi**4+6.*vi**2*ai**2+ai**4)   
   350   CONTINUE    
     
       ELSEIF(isub.EQ.23) THEN   
 C...f + fb' -> Z0 + W+/-.   
         faczw=comfac*faca*(aem/xw)**2*1./6. 
         faczw=faczw*wids(23,2)  
         thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
         DO 370 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 370   
         ia=iabs(i)  
         DO 360 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 360   
         ja=iabs(j)  
         IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 360  
         kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
         ei=kchg(ia,1)/3.    
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         ej=kchg(ja,1)/3.    
         aj=sign(1.,ej)  
         vj=aj-4.*ej*xw  
         IF(vi+ai.GT.0) THEN 
           visav=vi  
           aisav=ai  
           vi=vj 
           ai=aj 
           vj=visav  
           aj=aisav  
         ENDIF   
         fckm=1. 
         IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=faczw*fckm*(1./(sh-sqmw)**2* 
      &  ((9.-8.*xw)/4.*thuh+(8.*xw-6.)/4.*sh*(sqm3+sqm4))+  
      &  (thuh-sh*(sqm3+sqm4))/(2.*(sh-sqmw))*((vj+aj)/th-(vi+ai)/uh)+   
      &  thuh/(16.*(1.-xw))*((vj+aj)**2/th2+(vi+ai)**2/uh2)+ 
      &  sh*(sqm3+sqm4)/(8.*(1.-xw))*(vi+ai)*(vj+aj)/(th*uh))*   
      &  wids(24,(5-kchw)/2) 
   360   CONTINUE    
   370   CONTINUE    
     
       ELSEIF(isub.EQ.24) THEN   
 C...f + fb -> Z0 + H0.  
         thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
         fachz=comfac*faca*(aem/(xw*(1.-xw)))**2*1./96.* 
      &  (thuh+2.*sh*sqmz)/(sh-sqmz)**2  
         fachz=fachz*wids(23,2)*wids(25,2)   
         DO 380 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 380    
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=fachz*(vi**2+ai**2)  
   380   CONTINUE    
     
       ELSEIF(isub.EQ.25) THEN   
 C...f + fb -> W+ + W-.  
         facww=comfac*faca*(aem/xw)**2*1./12.    
         facww=facww*wids(24,1)  
         thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
         DO 390 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 390    
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         dsigww=thuh/sh2*(3.-(sh-3.*(sqm3+sqm4))/(sh-sqmz)*  
      &  (vi+ai)/(2.*ai*(1.-xw))+(sh/(sh-sqmz))**2*  
      &  (1.-2.*(sqm3+sqm4)/sh+12.*sqm3*sqm4/sh2)*(vi**2+ai**2)/ 
      &  (8.*(1.-xw)**2))-2.*sqmz/(sh-sqmz)*(vi+ai)/ai+  
      &  sqmz*sh/(sh-sqmz)**2*(1.-2.*(sqm3+sqm4)/sh)*(vi**2+ai**2)/  
      &  (2.*(1.-xw))    
         IF(kchg(iabs(i),1).LT.0) THEN   
           dsigww=dsigww+2.*(1.+sqmz/(sh-sqmz)*(vi+ai)/(2.*ai))* 
      &    (thuh/(sh*th)-(sqm3+sqm4)/th)+thuh/th2    
         ELSE    
           dsigww=dsigww+2.*(1.+sqmz/(sh-sqmz)*(vi+ai)/(2.*ai))* 
      &    (thuh/(sh*uh)-(sqm3+sqm4)/uh)+thuh/uh2    
         ENDIF   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facww*dsigww 
   390   CONTINUE    
     
       ELSEIF(isub.EQ.26) THEN   
 C...f + fb' -> W+/- + H0.   
         thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2) 
         fachw=comfac*faca*(aem/xw)**2*1./24.*(thuh+2.*sh*sqmw)/ 
      &  (sh-sqmw)**2    
         fachw=fachw*wids(25,2)  
         DO 410 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 410   
         ia=iabs(i)  
         DO 400 j=min2,max2  
         IF(j.EQ.0.OR.kfac(1,j).EQ.0) GOTO 400   
         ja=iabs(j)  
         IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 400  
         kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3    
         fckm=1. 
         IF(mint(43).EQ.4) fckm=vckm((ia+1)/2,(ja+1)/2)  
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fachw*fckm*wids(24,(5-kchw)/2)   
   400   CONTINUE    
   410   CONTINUE    
     
       ELSEIF(isub.EQ.27) THEN   
 C...f + fb -> H0 + H0.  
     
       ELSEIF(isub.EQ.28) THEN   
 C...f + g -> f + g (q + g -> q + g only).   
         facqg1=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*uh2/th2-uh/sh)*  
      &  faca    
         facqg2=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*sh2/th2-sh/uh)   
         DO 430 i=mina,maxa  
         IF(i.EQ.0) GOTO 430 
         DO 420 isde=1,2 
         IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 420    
         IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 420    
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=1  
         sigh(nchn)=facqg1   
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=2  
         sigh(nchn)=facqg2   
   420   CONTINUE    
   430   CONTINUE    
     
       ELSEIF(isub.EQ.29) THEN   
 C...f + g -> f + gamma (q + g -> q + gamma only).   
         fgq=comfac*faca*as*aem*1./3.*(sh2+uh2)/(-sh*uh) 
         DO 450 i=mina,maxa  
         IF(i.EQ.0) GOTO 450 
         ei=kchg(iabs(i),1)/3.   
         facgq=fgq*ei**2 
         DO 440 isde=1,2 
         IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 440    
         IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 440    
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=1  
         sigh(nchn)=facgq    
   440   CONTINUE    
   450   CONTINUE    
     
       ELSEIF(isub.EQ.30) THEN   
 C...f + g -> f + Z0 (q + g -> q + Z0 only). 
         fzq=comfac*faca*as*aem/(xw*(1.-xw))*1./48.* 
      &  (sh2+uh2+2.*sqm4*th)/(-sh*uh)   
         fzq=fzq*wids(23,2)  
         DO 470 i=mina,maxa  
         IF(i.EQ.0) GOTO 470 
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         faczq=fzq*(vi**2+ai**2) 
         DO 460 isde=1,2 
         IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 460    
         IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 460    
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=1  
         sigh(nchn)=faczq    
   460   CONTINUE    
   470   CONTINUE    
       ENDIF 
     
       ELSEIF(isub.LE.40) THEN   
       IF(isub.EQ.31) THEN   
 C...f + g -> f' + W+/- (q + g -> q' + W+/- only).   
         facwq=comfac*faca*as*aem/xw*1./12.* 
      &  (sh2+uh2+2.*sqm4*th)/(-sh*uh)   
         DO 490 i=mina,maxa  
         IF(i.EQ.0) GOTO 490 
         ia=iabs(i)  
         kchw=isign(1,kchg(ia,1)*isign(1,i)) 
         DO 480 isde=1,2 
         IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 480    
         IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 480    
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=1  
         sigh(nchn)=facwq*vint(180+i)*wids(24,(5-kchw)/2)    
   480   CONTINUE    
   490   CONTINUE    
     
       ELSEIF(isub.EQ.32) THEN   
 C...f + g -> f + H0 (q + g -> q + H0 only). 
     
       ELSEIF(isub.EQ.33) THEN   
 C...f + gamma -> f + g (q + gamma -> q + g only).   
     
       ELSEIF(isub.EQ.34) THEN   
 C...f + gamma -> f + gamma. 
     
       ELSEIF(isub.EQ.35) THEN   
 C...f + gamma -> f + Z0.    
     
       ELSEIF(isub.EQ.36) THEN   
 C...f + gamma -> f' + W+/-. 
     
       ELSEIF(isub.EQ.37) THEN   
 C...f + gamma -> f + H0.    
     
       ELSEIF(isub.EQ.38) THEN   
 C...f + Z0 -> f + g (q + Z0 -> q + g only). 
     
       ELSEIF(isub.EQ.39) THEN   
 C...f + Z0 -> f + gamma.    
     
       ELSEIF(isub.EQ.40) THEN   
 C...f + Z0 -> f + Z0.   
       ENDIF 
     
       ELSEIF(isub.LE.50) THEN   
       IF(isub.EQ.41) THEN   
 C...f + Z0 -> f' + W+/-.    
     
       ELSEIF(isub.EQ.42) THEN   
 C...f + Z0 -> f + H0.   
     
       ELSEIF(isub.EQ.43) THEN   
 C...f + W+/- -> f' + g (q + W+/- -> q' + g only).   
     
       ELSEIF(isub.EQ.44) THEN   
 C...f + W+/- -> f' + gamma. 
     
       ELSEIF(isub.EQ.45) THEN   
 C...f + W+/- -> f' + Z0.    
     
       ELSEIF(isub.EQ.46) THEN   
 C...f + W+/- -> f' + W+/-.  
     
       ELSEIF(isub.EQ.47) THEN   
 C...f + W+/- -> f' + H0.    
     
       ELSEIF(isub.EQ.48) THEN   
 C...f + H0 -> f + g (q + H0 -> q + g only). 
     
       ELSEIF(isub.EQ.49) THEN   
 C...f + H0 -> f + gamma.    
     
       ELSEIF(isub.EQ.50) THEN   
 C...f + H0 -> f + Z0.   
       ENDIF 
     
       ELSEIF(isub.LE.60) THEN   
       IF(isub.EQ.51) THEN   
 C...f + H0 -> f' + W+/-.    
     
       ELSEIF(isub.EQ.52) THEN   
 C...f + H0 -> f + H0.   
     
       ELSEIF(isub.EQ.53) THEN   
 C...g + g -> f + fb (g + g -> q + qb only). 
         CALL pywidt(21,sqrt(sh),wdtp,wdte)  
         facqq1=comfac*as**2*1./6.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)*  
      &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
         facqq2=comfac*as**2*1./6.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)*  
      &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
         IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 500 
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=facqq1   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=2  
         sigh(nchn)=facqq2   
   500   CONTINUE    
     
       ELSEIF(isub.EQ.54) THEN   
 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
     
       ELSEIF(isub.EQ.55) THEN   
 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
     
       ELSEIF(isub.EQ.56) THEN   
 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
     
       ELSEIF(isub.EQ.57) THEN   
 C...g + gamma -> f + fb (g + gamma -> q + qb only). 
     
       ELSEIF(isub.EQ.58) THEN   
 C...gamma + gamma -> f + fb.    
     
       ELSEIF(isub.EQ.59) THEN   
 C...gamma + Z0 -> f + fb.   
     
       ELSEIF(isub.EQ.60) THEN   
 C...gamma + W+/- -> f + fb'.    
       ENDIF 
     
       ELSEIF(isub.LE.70) THEN   
       IF(isub.EQ.61) THEN   
 C...gamma + H0 -> f + fb.   
     
       ELSEIF(isub.EQ.62) THEN   
 C...Z0 + Z0 -> f + fb.  
     
       ELSEIF(isub.EQ.63) THEN   
 C...Z0 + W+/- -> f + fb'.   
     
       ELSEIF(isub.EQ.64) THEN   
 C...Z0 + H0 -> f + fb.  
     
       ELSEIF(isub.EQ.65) THEN   
 C...W+ + W- -> f + fb.  
     
       ELSEIF(isub.EQ.66) THEN   
 C...W+/- + H0 -> f + fb'.   
     
       ELSEIF(isub.EQ.67) THEN   
 C...H0 + H0 -> f + fb.  
     
       ELSEIF(isub.EQ.68) THEN   
 C...g + g -> g + g. 
         facgg1=comfac*as**2*9./4.*(sh2/th2+2.*sh/th+3.+2.*th/sh+    
      &  th2/sh2)*faca   
         facgg2=comfac*as**2*9./4.*(uh2/sh2+2.*uh/sh+3.+2.*sh/uh+    
      &  sh2/uh2)*faca   
         facgg3=comfac*as**2*9./4.*(th2/uh2+2.*th/uh+3+2.*uh/th+uh2/th2) 
         IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 510 
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=0.5*facgg1   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=2  
         sigh(nchn)=0.5*facgg2   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=3  
         sigh(nchn)=0.5*facgg3   
   510   CONTINUE    
     
       ELSEIF(isub.EQ.69) THEN   
 C...gamma + gamma -> W+ + W-.   
     
       ELSEIF(isub.EQ.70) THEN   
 C...gamma + W+/- -> gamma + W+/-.   
       ENDIF 
     
       ELSEIF(isub.LE.80) THEN   
       IF(isub.EQ.71) THEN   
 C...Z0 + Z0 -> Z0 + Z0. 
         be2=1.-4.*sqmz/sh   
         th=-0.5*sh*be2*(1.-cth) 
         uh=-0.5*sh*be2*(1.+cth) 
         shang=1./(1.-xw)*sqmw/sqmz*(1.+be2)**2  
         ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
         ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
         thang=1./(1.-xw)*sqmw/sqmz*(be2-cth)**2 
         athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang    
         athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang    
         uhang=1./(1.-xw)*sqmw/sqmz*(be2+cth)**2 
         auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang    
         auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang    
         fach=0.5*comfac*1./(4096.*paru(1)**2*16.*(1.-xw)**2)*   
      &  (aem/xw)**4*(sh/sqmw)**2*((ashre+athre+auhre)**2+   
      &  (ashim+athim+auhim)**2)*sqmz/sqmw   
         DO 530 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 530   
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         avi=ai**2+vi**2 
         DO 520 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 520   
         ej=kchg(iabs(j),1)/3.   
         aj=sign(1.,ej)  
         vj=aj-4.*ej*xw  
         avj=aj**2+vj**2 
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fach*avi*avj 
   520   CONTINUE    
   530   CONTINUE    
     
       ELSEIF(isub.EQ.72) THEN   
 C...Z0 + Z0 -> W+ + W-. 
         be2=sqrt((1.-4.*sqmw/sh)*(1.-4.*sqmz/sh))   
         cth2=cth**2 
         th=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh-be2*cth)   
         uh=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh+be2*cth)   
         shang=4.*sqrt(sqmw/(sqmz*(1.-xw)))*(1.-2.*sqmw/sh)* 
      &  (1.-2.*sqmz/sh) 
         ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
         ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
         atwre=(1.-xw)/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3./2.+be2/2.*cth-    
      &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
      &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
      &  4.*(sqmw**2+sqmz**2)/sh2*cth2+2.*(sqmw+sqmz)/sh*be2*cth))   
         atwim=0.    
         auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3./2.-be2/2.*cth-    
      &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
      &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
      &  4.*(sqmw**2+sqmz**2)/sh2*cth2-2.*(sqmw+sqmz)/sh*be2*cth))   
         auwim=0.    
         a4re=2.*(1.-xw)/sqmz*(3.-cth2-4.*(sqmw+sqmz)/sh)    
         a4im=0. 
         fach=comfac*1./(4096.*paru(1)**2*16.*(1.-xw)**2)*(aem/xw)**4*   
      &  (sh/sqmw)**2*((ashre+atwre+auwre+a4re)**2+  
      &  (ashim+atwim+auwim+a4im)**2)*sqmz/sqmw  
         DO 550 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 550   
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         avi=ai**2+vi**2 
         DO 540 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 540   
         ej=kchg(iabs(j),1)/3.   
         aj=sign(1.,ej)  
         vj=aj-4.*ej*xw  
         avj=aj**2+vj**2 
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fach*avi*avj 
   540   CONTINUE    
   550   CONTINUE    
     
       ELSEIF(isub.EQ.73) THEN   
 C...Z0 + W+/- -> Z0 + W+/-. 
         be2=1.-2.*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2    
         ep1=1.+(sqmz-sqmw)/sh   
         ep2=1.-(sqmz-sqmw)/sh   
         th=-0.5*sh*be2*(1.-cth) 
         uh=(sqmz-sqmw)**2/sh-0.5*sh*be2*(1.+cth)    
         thang=sqrt(sqmw/(sqmz*(1.-xw)))*(be2-ep1*cth)*(be2-ep2*cth) 
         athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang    
         athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang    
         aswre=(1.-xw)/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+ 
      &  1./4.*(be2+ep1*ep2)**2*((ep1-ep2)**2-4.*be2*cth)+   
      &  2.*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-  
      &  1./16.*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2) 
         aswim=0.    
         auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*    
      &  (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*  
      &  (be2+ep1*ep2*cth)*(2.*ep2-ep2*cth+ep1)-be2*(ep2+ep1*cth)**2*    
      &  (be2-ep2**2*cth)-1./8.*(be2+ep1*ep2*cth)**2*((ep1+ep2)**2+  
      &  2.*be2*(1.-cth))+1./32.*sh/sqmw*(be2+ep1*ep2*cth)**2*   
      &  (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)* 
      &  (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*  
      &  (2.*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*(be2-ep1**2*cth)- 
      &  1./8.*(be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2.*be2*(1.-cth))+  
      &  1./32.*sh/sqmw*(be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2) 
         auwim=0.    
         a4re=(1.-xw)/sqmz*(ep1**2*ep2**2*(cth**2-1.)-   
      &  2.*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2.*be2*ep1*ep2)  
         a4im=0. 
         fach=comfac*1./(4096.*paru(1)**2*4.*(1.-xw))*(aem/xw)**4*   
      &  (sh/sqmw)**2*((athre+aswre+auwre+a4re)**2+  
      &  (athim+aswim+auwim+a4im)**2)*sqrt(sqmz/sqmw)    
         DO 570 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 570   
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         avi=ai**2+vi**2 
         DO 560 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 560   
         ej=kchg(iabs(j),1)/3.   
         aj=sign(1.,ej)  
         vj=ai-4.*ej*xw  
         avj=aj**2+vj**2 
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fach*(avi*vint(180+j)+vint(180+i)*avj)   
   560   CONTINUE    
   570   CONTINUE    
     
       ELSEIF(isub.EQ.75) THEN   
 C...W+ + W- -> gamma + gamma.   
     
       ELSEIF(isub.EQ.76) THEN   
 C...W+ + W- -> Z0 + Z0. 
         be2=sqrt((1.-4.*sqmw/sh)*(1.-4.*sqmz/sh))   
         cth2=cth**2 
         th=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh-be2*cth)   
         uh=-0.5*sh*(1.-2.*(sqmw+sqmz)/sh+be2*cth)   
         shang=4.*sqrt(sqmw/(sqmz*(1.-xw)))*(1.-2.*sqmw/sh)* 
      &  (1.-2.*sqmz/sh) 
         ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
         ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
         atwre=(1.-xw)/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3./2.+be2/2.*cth-    
      &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
      &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
      &  4.*(sqmw**2+sqmz**2)/sh2*cth2+2.*(sqmw+sqmz)/sh*be2*cth))   
         atwim=0.    
         auwre=(1.-xw)/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3./2.-be2/2.*cth-    
      &  (sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4.*((sqmw+sqmz)/sh*    
      &  (1.-3.*cth2)+8.*sqmw*sqmz/sh2*(2.*cth2-1.)+ 
      &  4.*(sqmw**2+sqmz**2)/sh2*cth2-2.*(sqmw+sqmz)/sh*be2*cth))   
         auwim=0.    
         a4re=2.*(1.-xw)/sqmz*(3.-cth2-4.*(sqmw+sqmz)/sh)    
         a4im=0. 
         fach=0.5*comfac*1./(4096.*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2* 
      &  ((ashre+atwre+auwre+a4re)**2+(ashim+atwim+auwim+a4im)**2)   
         DO 590 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 590   
         ei=sign(1.,float(i))*kchg(iabs(i),1)    
         DO 580 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 580   
         ej=sign(1.,float(j))*kchg(iabs(j),1)    
         IF(ei*ej.GT.0.) GOTO 580    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fach*vint(180+i)*vint(180+j) 
   580   CONTINUE    
   590   CONTINUE    
     
       ELSEIF(isub.EQ.77) THEN   
 C...W+/- + W+/- -> W+/- + W+/-. 
         be2=1.-4.*sqmw/sh   
         be4=be2**2  
         cth2=cth**2 
         cth3=cth**3 
         th=-0.5*sh*be2*(1.-cth) 
         uh=-0.5*sh*be2*(1.+cth) 
         shang=(1.+be2)**2   
         ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang    
         ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang    
         thang=(be2-cth)**2  
         athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang    
         athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang    
         sgzang=1./sqmw*be2*(3.-be2)**2*cth  
         asgre=xw*sgzang 
         asgim=0.    
         aszre=(1.-xw)*sh/(sh-sqmz)*sgzang   
         aszim=0.    
         tgzang=1./sqmw*(be2*(4.-2.*be2+be4)+be2*(4.-10.*be2+be4)*cth+   
      &  (2.-11.*be2+10.*be4)*cth2+be2*cth3) 
         atgre=0.5*xw*sh/th*tgzang   
         atgim=0.    
         atzre=0.5*(1.-xw)*sh/(th-sqmz)*tgzang   
         atzim=0.    
         a4re=1./sqmw*(1.+2.*be2-6.*be2*cth-cth2)    
         a4im=0. 
         fach=comfac*1./(4096.*paru(1)**2)*(aem/xw)**4*(sh/sqmw)**2* 
      &  ((ashre+athre+asgre+aszre+atgre+atzre+a4re)**2+ 
      &  (ashim+athim+asgim+aszim+atgim+atzim+a4im)**2)  
         DO 610 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 610   
         ei=sign(1.,float(i))*kchg(iabs(i),1)    
         DO 600 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 600   
         ej=sign(1.,float(j))*kchg(iabs(j),1)    
         IF(ei*ej.GT.0.) GOTO 600    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=fach*vint(180+i)*vint(180+j) 
   600   CONTINUE    
   610   CONTINUE    
     
       ELSEIF(isub.EQ.78) THEN   
 C...W+/- + H0 -> W+/- + H0. 
     
       ELSEIF(isub.EQ.79) THEN   
 C...H0 + H0 -> H0 + H0. 
     
       ENDIF 
     
 C...C: 2 -> 2, tree diagrams with masses.   
     
       ELSEIF(isub.LE.90) THEN   
       IF(isub.EQ.81) THEN   
 C...q + qb -> Q + QB.   
         facqqb=comfac*as**2*4./9.*(((th-sqm3)**2+   
      &  (uh-sqm3)**2)/sh2+2.*sqm3/sh)   
         IF(mstp(35).GE.1) THEN  
           IF(mstp(35).EQ.1) THEN    
             alssg=parp(35)  
           ELSE  
             mst115=mstu(115)    
             mstu(115)=mstp(36)  
             q2bn=sqrt(sqm3*((sqrt(sh)-2.*sqrt(sqm3))**2+parp(36)**2))   
             alssg=ulalps(q2bn)  
             mstu(115)=mst115    
           ENDIF 
           xrepu=paru(1)*alssg/(6.*sqrt(max(1e-20,1.-4.*sqm3/sh)))   
           frepu=xrepu/(exp(min(100.,xrepu))-1.) 
           pari(81)=frepu    
           facqqb=facqqb*frepu   
         ENDIF   
         DO 620 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 620    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facqqb   
   620   CONTINUE    
     
       ELSEIF(isub.EQ.82) THEN   
 C...g + g -> Q + QB.    
         facqq1=comfac*faca*as**2*1./6.*((uh-sqm3)/(th-sqm3)-    
      &  2.*(uh-sqm3)**2/sh2+4.*sqm3/sh*(th*uh-sqm3**2)/(th-sqm3)**2)    
         facqq2=comfac*faca*as**2*1./6.*((th-sqm3)/(uh-sqm3)-    
      &  2.*(th-sqm3)**2/sh2+4.*sqm3/sh*(th*uh-sqm3**2)/(uh-sqm3)**2)    
         IF(mstp(35).GE.1) THEN  
           IF(mstp(35).EQ.1) THEN    
             alssg=parp(35)  
           ELSE  
             mst115=mstu(115)    
             mstu(115)=mstp(36)  
             q2bn=sqrt(sqm3*((sqrt(sh)-2.*sqrt(sqm3))**2+parp(36)**2))   
             alssg=ulalps(q2bn)  
             mstu(115)=mst115    
           ENDIF 
           xattr=4.*paru(1)*alssg/(3.*sqrt(max(1e-20,1.-4.*sqm3/sh)))    
           fattr=xattr/(1.-exp(-min(100.,xattr)))    
           xrepu=paru(1)*alssg/(6.*sqrt(max(1e-20,1.-4.*sqm3/sh)))   
           frepu=xrepu/(exp(min(100.,xrepu))-1.) 
           fatre=(2.*fattr+5.*frepu)/7.  
           pari(81)=fatre    
           facqq1=facqq1*fatre   
           facqq2=facqq2*fatre   
         ENDIF   
         IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 630 
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=facqq1   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=2  
         sigh(nchn)=facqq2   
   630   CONTINUE    
     
       ENDIF 
     
 C...D: Mimimum bias processes.  
     
       ELSEIF(isub.LE.100) THEN  
       IF(isub.EQ.91) THEN   
 C...Elastic scattering. 
         sigs=xsec(isub,1)   
     
       ELSEIF(isub.EQ.92) THEN   
 C...Single diffractive scattering.  
         sigs=xsec(isub,1)   
     
       ELSEIF(isub.EQ.93) THEN   
 C...Double diffractive scattering.  
         sigs=xsec(isub,1)   
     
       ELSEIF(isub.EQ.94) THEN   
 C...Central diffractive scattering. 
         sigs=xsec(isub,1)   
     
       ELSEIF(isub.EQ.95) THEN   
 C...Low-pT scattering.  
         sigs=xsec(isub,1)   
     
       ELSEIF(isub.EQ.96) THEN   
 C...Multiple interactions: sum of QCD processes.    
         CALL pywidt(21,sqrt(sh),wdtp,wdte)  
     
 C...q + q' -> q + q'.   
         facqq1=comfac*as**2*4./9.*(sh2+uh2)/th2 
         facqqb=comfac*as**2*4./9.*((sh2+uh2)/th2*faca-  
      &  mstp(34)*2./3.*uh2/(sh*th)) 
         facqq2=comfac*as**2*4./9.*((sh2+th2)/uh2-   
      &  mstp(34)*2./3.*sh2/(th*uh)) 
         DO 650 i=-3,3   
         IF(i.EQ.0) GOTO 650 
         DO 640 j=-3,3   
         IF(j.EQ.0) GOTO 640 
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=111    
         sigh(nchn)=facqq1   
         IF(i.EQ.-j) sigh(nchn)=facqqb   
         IF(i.EQ.j) THEN 
           sigh(nchn)=0.5*sigh(nchn) 
           nchn=nchn+1   
           isig(nchn,1)=i    
           isig(nchn,2)=j    
           isig(nchn,3)=112  
           sigh(nchn)=0.5*facqq2 
         ENDIF   
   640   CONTINUE    
   650   CONTINUE    
     
 C...q + qb -> q' + qb' or g + g.    
         facqqb=comfac*as**2*4./9.*(th2+uh2)/sh2*(wdte(0,1)+wdte(0,2)+   
      &  wdte(0,3)+wdte(0,4))    
         facgg1=comfac*as**2*32./27.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2) 
         facgg2=comfac*as**2*32./27.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2) 
         DO 660 i=-3,3   
         IF(i.EQ.0) GOTO 660 
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=121    
         sigh(nchn)=facqqb   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=131    
         sigh(nchn)=0.5*facgg1   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=132    
         sigh(nchn)=0.5*facgg2   
   660   CONTINUE    
     
 C...q + g -> q + g. 
         facqg1=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*uh2/th2-uh/sh)*  
      &  faca    
         facqg2=comfac*as**2*4./9.*((2.+mstp(34)*1./4.)*sh2/th2-sh/uh)   
         DO 680 i=-3,3   
         IF(i.EQ.0) GOTO 680 
         DO 670 isde=1,2 
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=281    
         sigh(nchn)=facqg1   
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=282    
         sigh(nchn)=facqg2   
   670   CONTINUE    
   680   CONTINUE    
     
 C...g + g -> q + qb or g + g.   
         facqq1=comfac*as**2*1./6.*(uh/th-(2.+mstp(34)*1./4.)*uh2/sh2)*  
      &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
         facqq2=comfac*as**2*1./6.*(th/uh-(2.+mstp(34)*1./4.)*th2/sh2)*  
      &  (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca  
         facgg1=comfac*as**2*9./4.*(sh2/th2+2.*sh/th+3.+2.*th/sh+    
      &  th2/sh2)*faca   
         facgg2=comfac*as**2*9./4.*(uh2/sh2+2.*uh/sh+3.+2.*sh/uh+    
      &  sh2/uh2)*faca   
         facgg3=comfac*as**2*9./4.*(th2/uh2+2.*th/uh+3+2.*uh/th+uh2/th2) 
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=531    
         sigh(nchn)=facqq1   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=532    
         sigh(nchn)=facqq2   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=681    
         sigh(nchn)=0.5*facgg1   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=682    
         sigh(nchn)=0.5*facgg2   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=683    
         sigh(nchn)=0.5*facgg3   
       ENDIF 
     
 C...E: 2 -> 1, loop diagrams.   
     
       ELSEIF(isub.LE.110) THEN  
       IF(isub.EQ.101) THEN  
 C...g + g -> gamma*/Z0. 
     
       ELSEIF(isub.EQ.102) THEN  
 C...g + g -> H0.    
         CALL pywidt(25,sqrt(sh),wdtp,wdte)  
         etare=0.    
         etaim=0.    
         DO 690 i=1,2*mstp(1)    
         eps=4.*pmas(i,1)**2/sh  
         IF(eps.LE.1.) THEN  
           IF(eps.GT.1.e-4) THEN 
             root=sqrt(1.-eps)   
             rln=log((1.+root)/(1.-root))    
           ELSE  
             rln=log(4./eps-2.)  
           ENDIF 
           phire=0.25*(rln**2-paru(1)**2)    
           phiim=0.5*paru(1)*rln 
         ELSE    
           phire=-(asin(1./sqrt(eps)))**2    
           phiim=0.  
         ENDIF   
         etare=etare+0.5*eps*(1.+(eps-1.)*phire) 
         etaim=etaim+0.5*eps*(eps-1.)*phiim  
   690   CONTINUE    
         eta2=etare**2+etaim**2  
         fach=comfac*faca*(as/paru(1)*aem/xw)**2*1./512.*    
      &  (sh/sqmw)**2*eta2*sh2/((sh-sqmh)**2+gmmh**2)*   
      &  (wdte(0,1)+wdte(0,2)+wdte(0,4)) 
         IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 700 
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=fach 
   700   CONTINUE    
     
       ENDIF 
     
 C...F: 2 -> 2, box diagrams.    
     
       ELSEIF(isub.LE.120) THEN  
       IF(isub.EQ.111) THEN  
 C...f + fb -> g + H0 (q + qb -> g + H0 only).   
         a5stur=0.   
         a5stui=0.   
         DO 710 i=1,2*mstp(1)    
         sqmq=pmas(i,1)**2   
         epss=4.*sqmq/sh 
         epsh=4.*sqmq/sqmh   
         a5stur=a5stur+sqmq/sqmh*(4.+4.*sh/(th+uh)*(pyw1au(epss,1)-  
      &  pyw1au(epsh,1))+(1.-4.*sqmq/(th+uh))*(pyw2au(epss,1)-   
      &  pyw2au(epsh,1)))    
         a5stui=a5stui+sqmq/sqmh*(4.*sh/(th+uh)*(pyw1au(epss,2)- 
      &  pyw1au(epsh,2))+(1.-4.*sqmq/(th+uh))*(pyw2au(epss,2)-   
      &  pyw2au(epsh,2)))    
   710   CONTINUE    
         facgh=comfac*faca/(144.*paru(1)**2)*aem/xw*as**3*sqmh/sqmw* 
      &  sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)  
         facgh=facgh*wids(25,2)  
         DO 720 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 720    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=facgh    
   720   CONTINUE    
     
       ELSEIF(isub.EQ.112) THEN  
 C...f + g -> f + H0 (q + g -> q + H0 only). 
         a5tsur=0.   
         a5tsui=0.   
         DO 730 i=1,2*mstp(1)    
         sqmq=pmas(i,1)**2   
         epst=4.*sqmq/th 
         epsh=4.*sqmq/sqmh   
         a5tsur=a5tsur+sqmq/sqmh*(4.+4.*th/(sh+uh)*(pyw1au(epst,1)-  
      &  pyw1au(epsh,1))+(1.-4.*sqmq/(sh+uh))*(pyw2au(epst,1)-   
      &  pyw2au(epsh,1)))    
         a5tsui=a5tsui+sqmq/sqmh*(4.*th/(sh+uh)*(pyw1au(epst,2)- 
      &  pyw1au(epsh,2))+(1.-4.*sqmq/(sh+uh))*(pyw2au(epst,2)-   
      &  pyw2au(epsh,2)))    
   730   CONTINUE    
         facqh=comfac*faca/(384.*paru(1)**2)*aem/xw*as**3*sqmh/sqmw* 
      &  sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)   
         facqh=facqh*wids(25,2)  
         DO 750 i=mina,maxa  
         IF(i.EQ.0) GOTO 750 
         DO 740 isde=1,2 
         IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 740    
         IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 740    
         nchn=nchn+1 
         isig(nchn,isde)=i   
         isig(nchn,3-isde)=21    
         isig(nchn,3)=1  
         sigh(nchn)=facqh    
   740   CONTINUE    
   750   CONTINUE    
     
       ELSEIF(isub.EQ.113) THEN  
 C...g + g -> g + H0.    
         a2stur=0.   
         a2stui=0.   
         a2ustr=0.   
         a2usti=0.   
         a2tusr=0.   
         a2tusi=0.   
         a4stur=0.   
         a4stui=0.   
         DO 760 i=6,2*mstp(1)    
 C'''Only t-quarks yet included  
         sqmq=pmas(i,1)**2   
         epss=4.*sqmq/sh 
         epst=4.*sqmq/th 
         epsu=4.*sqmq/uh 
         epsh=4.*sqmq/sqmh   
         IF(epsh.LT.1.e-6) GOTO 760  
         bestu=0.5*(1.+sqrt(1.+epss*th/uh))  
         beust=0.5*(1.+sqrt(1.+epsu*sh/th))  
         betus=0.5*(1.+sqrt(1.+epst*uh/sh))  
         beuts=bestu 
         betsu=beust 
         besut=betus 
         w3stur=pyi3au(bestu,epsh,1)-pyi3au(bestu,epss,1)-   
      &  pyi3au(bestu,epsu,1)    
         w3stui=pyi3au(bestu,epsh,2)-pyi3au(bestu,epss,2)-   
      &  pyi3au(bestu,epsu,2)    
         w3sutr=pyi3au(besut,epsh,1)-pyi3au(besut,epss,1)-   
      &  pyi3au(besut,epst,1)    
         w3suti=pyi3au(besut,epsh,2)-pyi3au(besut,epss,2)-   
      &  pyi3au(besut,epst,2)    
         w3tsur=pyi3au(betsu,epsh,1)-pyi3au(betsu,epst,1)-   
      &  pyi3au(betsu,epsu,1)    
         w3tsui=pyi3au(betsu,epsh,2)-pyi3au(betsu,epst,2)-   
      &  pyi3au(betsu,epsu,2)    
         w3tusr=pyi3au(betus,epsh,1)-pyi3au(betus,epst,1)-   
      &  pyi3au(betus,epss,1)    
         w3tusi=pyi3au(betus,epsh,2)-pyi3au(betus,epst,2)-   
      &  pyi3au(betus,epss,2)    
         w3ustr=pyi3au(beust,epsh,1)-pyi3au(beust,epsu,1)-   
      &  pyi3au(beust,epst,1)    
         w3usti=pyi3au(beust,epsh,2)-pyi3au(beust,epsu,2)-   
      &  pyi3au(beust,epst,2)    
         w3utsr=pyi3au(beuts,epsh,1)-pyi3au(beuts,epsu,1)-   
      &  pyi3au(beuts,epss,1)    
         w3utsi=pyi3au(beuts,epsh,2)-pyi3au(beuts,epsu,2)-   
      &  pyi3au(beuts,epss,2)    
         b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2.*th*uh*(uh+2.*sh)/    
      &  (sh+uh)**2*(pyw1au(epst,1)-pyw1au(epsh,1))+(sqmq-sh/4.)*    
      &  (0.5*pyw2au(epss,1)+0.5*pyw2au(epsh,1)-pyw2au(epst,1)+w3stur)+  
      &  sh**2*(2.*sqmq/(sh+uh)**2-0.5/(sh+uh))*(pyw2au(epst,1)- 
      &  pyw2au(epsh,1))+0.5*th*uh/sh*(pyw2au(epsh,1)-2.*pyw2au(epst,1))+    
      &  0.125*(sh-12.*sqmq-4.*th*uh/sh)*w3tsur) 
         b2stui=sqmq/sqmh**2*(2.*th*uh*(uh+2.*sh)/(sh+uh)**2*    
      &  (pyw1au(epst,2)-pyw1au(epsh,2))+(sqmq-sh/4.)*   
      &  (0.5*pyw2au(epss,2)+0.5*pyw2au(epsh,2)-pyw2au(epst,2)+w3stui)+  
      &  sh**2*(2.*sqmq/(sh+uh)**2-0.5/(sh+uh))*(pyw2au(epst,2)- 
      &  pyw2au(epsh,2))+0.5*th*uh/sh*(pyw2au(epsh,2)-2.*pyw2au(epst,2))+    
      &  0.125*(sh-12.*sqmq-4.*th*uh/sh)*w3tsui) 
         b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2.*uh*th*(th+2.*sh)/    
      &  (sh+th)**2*(pyw1au(epsu,1)-pyw1au(epsh,1))+(sqmq-sh/4.)*    
      &  (0.5*pyw2au(epss,1)+0.5*pyw2au(epsh,1)-pyw2au(epsu,1)+w3sutr)+  
      &  sh**2*(2.*sqmq/(sh+th)**2-0.5/(sh+th))*(pyw2au(epsu,1)- 
      &  pyw2au(epsh,1))+0.5*uh*th/sh*(pyw2au(epsh,1)-2.*pyw2au(epsu,1))+    
      &  0.125*(sh-12.*sqmq-4.*uh*th/sh)*w3ustr) 
         b2suti=sqmq/sqmh**2*(2.*uh*th*(th+2.*sh)/(sh+th)**2*    
      &  (pyw1au(epsu,2)-pyw1au(epsh,2))+(sqmq-sh/4.)*   
      &  (0.5*pyw2au(epss,2)+0.5*pyw2au(epsh,2)-pyw2au(epsu,2)+w3suti)+  
      &  sh**2*(2.*sqmq/(sh+th)**2-0.5/(sh+th))*(pyw2au(epsu,2)- 
      &  pyw2au(epsh,2))+0.5*uh*th/sh*(pyw2au(epsh,2)-2.*pyw2au(epsu,2))+    
      &  0.125*(sh-12.*sqmq-4.*uh*th/sh)*w3usti) 
         b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2.*sh*uh*(uh+2.*th)/    
      &  (th+uh)**2*(pyw1au(epss,1)-pyw1au(epsh,1))+(sqmq-th/4.)*    
      &  (0.5*pyw2au(epst,1)+0.5*pyw2au(epsh,1)-pyw2au(epss,1)+w3tsur)+  
      &  th**2*(2.*sqmq/(th+uh)**2-0.5/(th+uh))*(pyw2au(epss,1)- 
      &  pyw2au(epsh,1))+0.5*sh*uh/th*(pyw2au(epsh,1)-2.*pyw2au(epss,1))+    
      &  0.125*(th-12.*sqmq-4.*sh*uh/th)*w3stur) 
         b2tsui=sqmq/sqmh**2*(2.*sh*uh*(uh+2.*th)/(th+uh)**2*    
      &  (pyw1au(epss,2)-pyw1au(epsh,2))+(sqmq-th/4.)*   
      &  (0.5*pyw2au(epst,2)+0.5*pyw2au(epsh,2)-pyw2au(epss,2)+w3tsui)+  
      &  th**2*(2.*sqmq/(th+uh)**2-0.5/(th+uh))*(pyw2au(epss,2)- 
      &  pyw2au(epsh,2))+0.5*sh*uh/th*(pyw2au(epsh,2)-2.*pyw2au(epss,2))+    
      &  0.125*(th-12.*sqmq-4.*sh*uh/th)*w3stui) 
         b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2.*uh*sh*(sh+2.*th)/    
      &  (th+sh)**2*(pyw1au(epsu,1)-pyw1au(epsh,1))+(sqmq-th/4.)*    
      &  (0.5*pyw2au(epst,1)+0.5*pyw2au(epsh,1)-pyw2au(epsu,1)+w3tusr)+  
      &  th**2*(2.*sqmq/(th+sh)**2-0.5/(th+sh))*(pyw2au(epsu,1)- 
      &  pyw2au(epsh,1))+0.5*uh*sh/th*(pyw2au(epsh,1)-2.*pyw2au(epsu,1))+    
      &  0.125*(th-12.*sqmq-4.*uh*sh/th)*w3utsr) 
         b2tusi=sqmq/sqmh**2*(2.*uh*sh*(sh+2.*th)/(th+sh)**2*    
      &  (pyw1au(epsu,2)-pyw1au(epsh,2))+(sqmq-th/4.)*   
      &  (0.5*pyw2au(epst,2)+0.5*pyw2au(epsh,2)-pyw2au(epsu,2)+w3tusi)+  
      &  th**2*(2.*sqmq/(th+sh)**2-0.5/(th+sh))*(pyw2au(epsu,2)- 
      &  pyw2au(epsh,2))+0.5*uh*sh/th*(pyw2au(epsh,2)-2.*pyw2au(epsu,2))+    
      &  0.125*(th-12.*sqmq-4.*uh*sh/th)*w3utsi) 
         b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2.*sh*th*(th+2.*uh)/    
      &  (uh+th)**2*(pyw1au(epss,1)-pyw1au(epsh,1))+(sqmq-uh/4.)*    
      &  (0.5*pyw2au(epsu,1)+0.5*pyw2au(epsh,1)-pyw2au(epss,1)+w3ustr)+  
      &  uh**2*(2.*sqmq/(uh+th)**2-0.5/(uh+th))*(pyw2au(epss,1)- 
      &  pyw2au(epsh,1))+0.5*sh*th/uh*(pyw2au(epsh,1)-2.*pyw2au(epss,1))+    
      &  0.125*(uh-12.*sqmq-4.*sh*th/uh)*w3sutr) 
         b2usti=sqmq/sqmh**2*(2.*sh*th*(th+2.*uh)/(uh+th)**2*    
      &  (pyw1au(epss,2)-pyw1au(epsh,2))+(sqmq-uh/4.)*   
      &  (0.5*pyw2au(epsu,2)+0.5*pyw2au(epsh,2)-pyw2au(epss,2)+w3usti)+  
      &  uh**2*(2.*sqmq/(uh+th)**2-0.5/(uh+th))*(pyw2au(epss,2)- 
      &  pyw2au(epsh,2))+0.5*sh*th/uh*(pyw2au(epsh,2)-2.*pyw2au(epss,2))+    
      &  0.125*(uh-12.*sqmq-4.*sh*th/uh)*w3suti) 
         b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2.*th*sh*(sh+2.*uh)/    
      &  (uh+sh)**2*(pyw1au(epst,1)-pyw1au(epsh,1))+(sqmq-uh/4.)*    
      &  (0.5*pyw2au(epsu,1)+0.5*pyw2au(epsh,1)-pyw2au(epst,1)+w3utsr)+  
      &  uh**2*(2.*sqmq/(uh+sh)**2-0.5/(uh+sh))*(pyw2au(epst,1)- 
      &  pyw2au(epsh,1))+0.5*th*sh/uh*(pyw2au(epsh,1)-2.*pyw2au(epst,1))+    
      &  0.125*(uh-12.*sqmq-4.*th*sh/uh)*w3tusr) 
         b2utsi=sqmq/sqmh**2*(2.*th*sh*(sh+2.*uh)/(uh+sh)**2*    
      &  (pyw1au(epst,2)-pyw1au(epsh,2))+(sqmq-uh/4.)*   
      &  (0.5*pyw2au(epsu,2)+0.5*pyw2au(epsh,2)-pyw2au(epst,2)+w3utsi)+  
      &  uh**2*(2.*sqmq/(uh+sh)**2-0.5/(uh+sh))*(pyw2au(epst,2)- 
      &  pyw2au(epsh,2))+0.5*th*sh/uh*(pyw2au(epsh,2)-2.*pyw2au(epst,2))+    
      &  0.125*(uh-12.*sqmq-4.*th*sh/uh)*w3tusi) 
         b4stur=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epss,1)- 
      &  pyw2au(epsh,1)+w3stur)) 
         b4stui=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epss,2)- 
      &  pyw2au(epsh,2)+w3stui)  
         b4tusr=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epst,1)- 
      &  pyw2au(epsh,1)+w3tusr)) 
         b4tusi=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epst,2)- 
      &  pyw2au(epsh,2)+w3tusi)  
         b4ustr=sqmq/sqmh*(-2./3.+(sqmq/sqmh-1./4.)*(pyw2au(epsu,1)- 
      &  pyw2au(epsh,1)+w3ustr)) 
         b4usti=sqmq/sqmh*(sqmq/sqmh-1./4.)*(pyw2au(epsu,2)- 
      &  pyw2au(epsh,2)+w3usti)  
         a2stur=a2stur+b2stur+b2sutr 
         a2stui=a2stui+b2stui+b2suti 
         a2ustr=a2ustr+b2ustr+b2utsr 
         a2usti=a2usti+b2usti+b2utsi 
         a2tusr=a2tusr+b2tusr+b2tsur 
         a2tusi=a2tusi+b2tusi+b2tsui 
         a4stur=a4stur+b4stur+b4ustr+b4tusr  
         a4stui=a4stui+b4stui+b4usti+b4tusi  
   760   CONTINUE    
         facgh=comfac*faca*3./(128.*paru(1)**2)*aem/xw*as**3*    
      &  sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+    
      &  a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)  
         facgh=facgh*wids(25,2)  
         IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 770 
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=facgh    
   770   CONTINUE    
     
       ELSEIF(isub.EQ.114) THEN  
 C...g + g -> gamma + gamma. 
         asre=0. 
         asim=0. 
         DO 780 i=1,2*mstp(1)    
         ei=kchg(iabs(i),1)/3.   
         sqmq=pmas(i,1)**2   
         epss=4.*sqmq/sh 
         epst=4.*sqmq/th 
         epsu=4.*sqmq/uh 
         IF(epss+abs(epst)+abs(epsu).LT.3.e-6) THEN  
           a0stur=1.+(th-uh)/sh*log(th/uh)+0.5*(th2+uh2)/sh2*    
      &    (log(th/uh)**2+paru(1)**2)    
           a0stui=0. 
           a0tsur=1.+(sh-uh)/th*log(-sh/uh)+0.5*(sh2+uh2)/th2*   
      &    log(-sh/uh)**2    
           a0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*log(-sh/uh))    
           a0utsr=1.+(th-sh)/uh*log(-th/sh)+0.5*(th2+sh2)/uh2*   
      &    log(-th/sh)**2    
           a0utsi=paru(1)*((th-sh)/uh+(th2+sh2)/uh2*log(-th/sh)) 
           a1stur=-1.    
           a1stui=0. 
           a2stur=-1.    
           a2stui=0. 
         ELSE    
           bestu=0.5*(1.+sqrt(1.+epss*th/uh))    
           beust=0.5*(1.+sqrt(1.+epsu*sh/th))    
           betus=0.5*(1.+sqrt(1.+epst*uh/sh))    
           beuts=bestu   
           betsu=beust   
           besut=betus   
           a0stur=1.+(1.+2.*th/sh)*pyw1au(epst,1)+(1.+2.*uh/sh)* 
      &    pyw1au(epsu,1)+0.5*((th2+uh2)/sh2-epss)*(pyw2au(epst,1)+  
      &    pyw2au(epsu,1))-0.25*epst*(1.-0.5*epss)*(pyi3au(besut,epss,1)+    
      &    pyi3au(besut,epst,1))-0.25*epsu*(1.-0.5*epss)*    
      &    (pyi3au(bestu,epss,1)+pyi3au(bestu,epsu,1))+  
      &    0.25*(-2.*(th2+uh2)/sh2+4.*epss+epst+epsu+0.5*epst*epsu)* 
      &    (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))   
           a0stui=(1.+2.*th/sh)*pyw1au(epst,2)+(1.+2.*uh/sh)*    
      &    pyw1au(epsu,2)+0.5*((th2+uh2)/sh2-epss)*(pyw2au(epst,2)+  
      &    pyw2au(epsu,2))-0.25*epst*(1.-0.5*epss)*(pyi3au(besut,epss,2)+    
      &    pyi3au(besut,epst,2))-0.25*epsu*(1.-0.5*epss)*    
      &    (pyi3au(bestu,epss,2)+pyi3au(bestu,epsu,2))+  
      &    0.25*(-2.*(th2+uh2)/sh2+4.*epss+epst+epsu+0.5*epst*epsu)* 
      &    (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))   
           a0tsur=1.+(1.+2.*sh/th)*pyw1au(epss,1)+(1.+2.*uh/th)* 
      &    pyw1au(epsu,1)+0.5*((sh2+uh2)/th2-epst)*(pyw2au(epss,1)+  
      &    pyw2au(epsu,1))-0.25*epss*(1.-0.5*epst)*(pyi3au(betus,epst,1)+    
      &    pyi3au(betus,epss,1))-0.25*epsu*(1.-0.5*epst)*    
      &    (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))+  
      &    0.25*(-2.*(sh2+uh2)/th2+4.*epst+epss+epsu+0.5*epss*epsu)* 
      &    (pyi3au(bestu,epss,1)+pyi3au(bestu,epsu,1))   
           a0tsui=(1.+2.*sh/th)*pyw1au(epss,2)+(1.+2.*uh/th)*    
      &    pyw1au(epsu,2)+0.5*((sh2+uh2)/th2-epst)*(pyw2au(epss,2)+  
      &    pyw2au(epsu,2))-0.25*epss*(1.-0.5*epst)*(pyi3au(betus,epst,2)+    
      &    pyi3au(betus,epss,2))-0.25*epsu*(1.-0.5*epst)*    
      &    (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))+  
      &    0.25*(-2.*(sh2+uh2)/th2+4.*epst+epss+epsu+0.5*epss*epsu)* 
      &    (pyi3au(bestu,epss,2)+pyi3au(bestu,epsu,2))   
           a0utsr=1.+(1.+2.*th/uh)*pyw1au(epst,1)+(1.+2.*sh/uh)* 
      &    pyw1au(epss,1)+0.5*((th2+sh2)/uh2-epsu)*(pyw2au(epst,1)+  
      &    pyw2au(epss,1))-0.25*epst*(1.-0.5*epsu)*(pyi3au(beust,epsu,1)+    
      &    pyi3au(beust,epst,1))-0.25*epss*(1.-0.5*epsu)*    
      &    (pyi3au(beuts,epsu,1)+pyi3au(beuts,epss,1))+  
      &    0.25*(-2.*(th2+sh2)/uh2+4.*epsu+epst+epss+0.5*epst*epss)* 
      &    (pyi3au(betus,epst,1)+pyi3au(betus,epss,1))   
           a0utsi=(1.+2.*th/uh)*pyw1au(epst,2)+(1.+2.*sh/uh)*    
      &    pyw1au(epss,2)+0.5*((th2+sh2)/uh2-epsu)*(pyw2au(epst,2)+  
      &    pyw2au(epss,2))-0.25*epst*(1.-0.5*epsu)*(pyi3au(beust,epsu,2)+    
      &    pyi3au(beust,epst,2))-0.25*epss*(1.-0.5*epsu)*    
      &    (pyi3au(beuts,epsu,2)+pyi3au(beuts,epss,2))+  
      &    0.25*(-2.*(th2+sh2)/uh2+4.*epsu+epst+epss+0.5*epst*epss)* 
      &    (pyi3au(betus,epst,2)+pyi3au(betus,epss,2))   
           a1stur=-1.-0.25*(epss+epst+epsu)*(pyw2au(epss,1)+ 
      &    pyw2au(epst,1)+pyw2au(epsu,1))+0.25*(epsu+0.5*epss*epst)* 
      &    (pyi3au(besut,epss,1)+pyi3au(besut,epst,1))+  
      &    0.25*(epst+0.5*epss*epsu)*(pyi3au(bestu,epss,1)+  
      &    pyi3au(bestu,epsu,1))+0.25*(epss+0.5*epst*epsu)*  
      &    (pyi3au(betsu,epst,1)+pyi3au(betsu,epsu,1))   
           a1stui=-0.25*(epss+epst+epsu)*(pyw2au(epss,2)+pyw2au(epst,2)+ 
      &    pyw2au(epsu,2))+0.25*(epsu+0.5*epss*epst)*    
      &    (pyi3au(besut,epss,2)+pyi3au(besut,epst,2))+  
      &    0.25*(epst+0.5*epss*epsu)*(pyi3au(bestu,epss,2)+  
      &    pyi3au(bestu,epsu,2))+0.25*(epss+0.5*epst*epsu)*  
      &    (pyi3au(betsu,epst,2)+pyi3au(betsu,epsu,2))   
           a2stur=-1.+0.125*epss*epst*(pyi3au(besut,epss,1)+ 
      &    pyi3au(besut,epst,1))+0.125*epss*epsu*(pyi3au(bestu,epss,1)+  
      &    pyi3au(bestu,epsu,1))+0.125*epst*epsu*(pyi3au(betsu,epst,1)+  
      &    pyi3au(betsu,epsu,1)) 
           a2stui=0.125*epss*epst*(pyi3au(besut,epss,2)+ 
      &    pyi3au(besut,epst,2))+0.125*epss*epsu*(pyi3au(bestu,epss,2)+  
      &    pyi3au(bestu,epsu,2))+0.125*epst*epsu*(pyi3au(betsu,epst,2)+  
      &    pyi3au(betsu,epsu,2)) 
         ENDIF   
         asre=asre+ei**2*(a0stur+a0tsur+a0utsr+4.*a1stur+a2stur) 
         asim=asim+ei**2*(a0stui+a0tsui+a0utsi+4.*a1stui+a2stui) 
   780   CONTINUE    
         facgg=comfac*faca/(8.*paru(1)**2)*as**2*aem**2*(asre**2+asim**2)    
         IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 790 
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=facgg    
   790   CONTINUE    
     
       ELSEIF(isub.EQ.115) THEN  
 C...g + g -> gamma + Z0.    
     
       ELSEIF(isub.EQ.116) THEN  
 C...g + g -> Z0 + Z0.   
     
       ELSEIF(isub.EQ.117) THEN  
 C...g + g -> W+ + W-.   
     
       ENDIF 
     
 C...G: 2 -> 3, tree diagrams.   
     
       ELSEIF(isub.LE.140) THEN  
       IF(isub.EQ.121) THEN  
 C...g + g -> f + fb + H0.   
     
       ENDIF 
     
 C...H: 2 -> 1, tree diagrams, non-standard model processes. 
     
       ELSEIF(isub.LE.160) THEN  
       IF(isub.EQ.141) THEN  
 C...f + fb -> gamma*/Z0/Z'0.    
         mint(61)=2  
         CALL pywidt(32,sqrt(sh),wdtp,wdte)  
         faczp=comfac*aem**2*4./9.   
         DO 800 i=mina,maxa  
         IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 800    
         ei=kchg(iabs(i),1)/3.   
         ai=sign(1.,ei)  
         vi=ai-4.*ei*xw  
         api=sign(1.,ei) 
         vpi=api-4.*ei*xw    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=faczp*(ei**2*vint(111)+ei*vi/(8.*xw*(1.-xw))*    
      &  sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)*vint(112)+ei*vpi/(8.*xw*    
      &  (1.-xw))*sh*(sh-sqmzp)/((sh-sqmzp)**2+gmmzp**2)*vint(113)+  
      &  (vi**2+ai**2)/(16.*xw*(1.-xw))**2*sh2/((sh-sqmz)**2+gmmz**2)*   
      &  vint(114)+2.*(vi*vpi+ai*api)/(16.*xw*(1.-xw))**2*sh2*   
      &  ((sh-sqmz)*(sh-sqmzp)+gmmz*gmmzp)/(((sh-sqmz)**2+gmmz**2)*  
      &  ((sh-sqmzp)**2+gmmzp**2))*vint(115)+(vpi**2+api**2)/    
      &  (16.*xw*(1.-xw))**2*sh2/((sh-sqmzp)**2+gmmzp**2)*vint(116)) 
   800   CONTINUE    
     
       ELSEIF(isub.EQ.142) THEN  
 C...f + fb' -> H+/-.    
         CALL pywidt(37,sqrt(sh),wdtp,wdte)  
         fhc=comfac*(aem/xw)**2*1./48.*(sh/sqmw)**2*sh2/ 
      &  ((sh-sqmhc)**2+gmmhc**2)    
 C'''No construction yet for leptons 
         DO 840 i=1,mstp(54)/2   
         il=2*i-1    
         iu=2*i  
         rmql=pmas(il,1)**2/sh   
         rmqu=pmas(iu,1)**2/sh   
         fachc=fhc*((rmql*paru(121)+rmqu/paru(121))*(1.-rmql-rmqu)-  
      &  4.*rmql*rmqu)/sqrt(max(0.,(1.-rmql-rmqu)**2-4.*rmql*rmqu))  
         IF(kfac(1,il)*kfac(2,-iu).EQ.0) GOTO 810    
         kchhc=(kchg(il,1)-kchg(iu,1))/3 
         nchn=nchn+1 
         isig(nchn,1)=il 
         isig(nchn,2)=-iu    
         isig(nchn,3)=1  
         sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
   810   IF(kfac(1,-il)*kfac(2,iu).EQ.0) GOTO 820    
         kchhc=(-kchg(il,1)+kchg(iu,1))/3    
         nchn=nchn+1 
         isig(nchn,1)=-il    
         isig(nchn,2)=iu 
         isig(nchn,3)=1  
         sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
   820   IF(kfac(1,iu)*kfac(2,-il).EQ.0) GOTO 830    
         kchhc=(kchg(iu,1)-kchg(il,1))/3 
         nchn=nchn+1 
         isig(nchn,1)=iu 
         isig(nchn,2)=-il    
         isig(nchn,3)=1  
         sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
   830   IF(kfac(1,-iu)*kfac(2,il).EQ.0) GOTO 840    
         kchhc=(-kchg(iu,1)+kchg(il,1))/3    
         nchn=nchn+1 
         isig(nchn,1)=-iu    
         isig(nchn,2)=il 
         isig(nchn,3)=1  
         sigh(nchn)=fachc*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))  
   840   CONTINUE    
     
       ELSEIF(isub.EQ.143) THEN  
 C...f + fb -> R.    
         CALL pywidt(40,sqrt(sh),wdtp,wdte)  
         facr=comfac*(aem/xw)**2*1./9.*sh2/((sh-sqmr)**2+gmmr**2)    
         DO 860 i=min1,max1  
         IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 860   
         ia=iabs(i)  
         DO 850 j=min2,max2  
         IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 850   
         ja=iabs(j)  
         IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) GOTO 850   
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=j  
         isig(nchn,3)=1  
         sigh(nchn)=facr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))  
   850   CONTINUE    
   860   CONTINUE    
     
       ENDIF 
     
 C...I: 2 -> 2, tree diagrams, non-standard model processes. 
     
       ELSE  
       IF(isub.EQ.161) THEN  
 C...f + g -> f' + H+/- (q + g -> q' + H+/- only).   
         fhcq=comfac*faca*as*aem/xw*1./24    
         DO 900 i=1,mstp(54) 
         iu=i+mod(i,2)   
         sqmq=pmas(iu,1)**2  
         fachcq=fhcq/paru(121)*sqmq/sqmw*(sh/(sqmq-uh)+  
      &  2.*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh+   
      &  2.*sqmq/(sqmq-uh)+2.*(sqmhc-uh)/(sqmq-uh)*(sqmhc-sqmq-sh)/sh)   
         IF(kfac(1,-i)*kfac(2,21).EQ.0) GOTO 870 
         kchhc=isign(1,-kchg(i,1))   
         nchn=nchn+1 
         isig(nchn,1)=-i 
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
   870   IF(kfac(1,i)*kfac(2,21).EQ.0) GOTO 880  
         kchhc=isign(1,kchg(i,1))    
         nchn=nchn+1 
         isig(nchn,1)=i  
         isig(nchn,2)=21 
         isig(nchn,3)=1  
         sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
   880   IF(kfac(1,21)*kfac(2,-i).EQ.0) GOTO 890 
         kchhc=isign(1,-kchg(i,1))   
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=-i 
         isig(nchn,3)=1  
         sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
   890   IF(kfac(1,21)*kfac(2,i).EQ.0) GOTO 900  
         kchhc=isign(1,kchg(i,1))    
         nchn=nchn+1 
         isig(nchn,1)=21 
         isig(nchn,2)=i  
         isig(nchn,3)=1  
         sigh(nchn)=fachcq*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4)) 
   900   CONTINUE    
     
       ENDIF 
       ENDIF 
     
 C...Multiply with structure functions.  
       IF(isub.LE.90.OR.isub.GE.96) THEN 
         DO 910 ichn=1,nchn  
         IF(mint(41).EQ.2) THEN  
           kfl1=isig(ichn,1) 
           IF(kfl1.EQ.21) kfl1=0 
           sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)    
         ENDIF   
         IF(mint(42).EQ.2) THEN  
           kfl2=isig(ichn,2) 
           IF(kfl2.EQ.21) kfl2=0 
           sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)    
         ENDIF   
   910   sigs=sigs+sigh(ichn)    
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyspen()

function pyspen	(	XREIN,
		XIMIN,
		IREIM
	)

Definition at line 18944 of file hipyset1.35.f.

     
 C...Calculates real and imaginary part of Spence function; see  
 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       dimension b(0:14) 
     
       DATA b/   
      & 1.000000e+00,        -5.000000e-01,         1.666667e-01,    
      & 0.000000e+00,        -3.333333e-02,         0.000000e+00,    
      & 2.380952e-02,         0.000000e+00,        -3.333333e-02,    
      & 0.000000e+00,         7.575757e-02,         0.000000e+00,    
      &-2.531135e-01,         0.000000e+00,         1.166667e+00/    
     
       xre=xrein 
       xim=ximin 
       IF(abs(1.-xre).LT.1.e-6.AND.abs(xim).LT.1.e-6) THEN   
         IF(ireim.EQ.1) pyspen=paru(1)**2/6. 
         IF(ireim.EQ.2) pyspen=0.    
         RETURN  
       ENDIF 
     
       xmod=sqrt(xre**2+xim**2)  
       IF(xmod.LT.1.e-6) THEN    
         IF(ireim.EQ.1) pyspen=0.    
         IF(ireim.EQ.2) pyspen=0.    
         RETURN  
       ENDIF 
     
       xarg=sign(acos(xre/xmod),xim) 
       sp0re=0.  
       sp0im=0.  
       sgn=1.    
       IF(xmod.GT.1.) THEN   
         algxre=log(xmod)    
         algxim=xarg-sign(paru(1),xarg)  
         sp0re=-paru(1)**2/6.-(algxre**2-algxim**2)/2.   
         sp0im=-algxre*algxim    
         sgn=-1. 
         xmod=1./xmod    
         xarg=-xarg  
         xre=xmod*cos(xarg)  
         xim=xmod*sin(xarg)  
       ENDIF 
       IF(xre.GT.0.5) THEN   
         algxre=log(xmod)    
         algxim=xarg 
         xre=1.-xre  
         xim=-xim    
         xmod=sqrt(xre**2+xim**2)    
         xarg=sign(acos(xre/xmod),xim)   
         algyre=log(xmod)    
         algyim=xarg 
         sp0re=sp0re+sgn*(paru(1)**2/6.-(algxre*algyre-algxim*algyim))   
         sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)   
         sgn=-sgn    
       ENDIF 
     
       xre=1.-xre    
       xim=-xim  
       xmod=sqrt(xre**2+xim**2)  
       xarg=sign(acos(xre/xmod),xim) 
       zre=-log(xmod)    
       zim=-xarg 
     
       spre=0.   
       spim=0.   
       savere=1. 
       saveim=0. 
       DO 100 i=0,14 
       termre=(savere*zre-saveim*zim)/float(i+1) 
       termim=(savere*zim+saveim*zre)/float(i+1) 
       savere=termre 
       saveim=termim 
       spre=spre+b(i)*termre 
   100 spim=spim+b(i)*termim 
     
       IF(ireim.EQ.1) pyspen=sp0re+sgn*spre  
       IF(ireim.EQ.2) pyspen=sp0im+sgn*spim  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyspli()

subroutine pyspli	(	KF,
		KFLIN,
		KFLCH,
		KFLSP
	)

Definition at line 18728 of file hipyset1.35.f.

     
 C...In case of a hadron remnant which is more complicated than just a   
 C...quark or a diquark, split it into two (partons or hadron + parton). 
       dimension kfl(3)  
     
 C...Preliminaries. Parton composition.  
       kfa=iabs(kf)  
       kfs=isign(1,kf)   
       kfl(1)=mod(kfa/1000,10)   
       kfl(2)=mod(kfa/100,10)    
       kfl(3)=mod(kfa/10,10) 
       kflr=kflin*kfs    
       kflch=0   
     
 C...Subdivide meson.    
       IF(kfl(1).EQ.0) THEN  
         kfl(2)=kfl(2)*(-1)**kfl(2)  
         kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))   
         IF(kflr.EQ.kfl(2)) THEN 
           kflsp=kfl(3)  
         ELSEIF(kflr.EQ.kfl(3)) THEN 
           kflsp=kfl(2)  
         ELSEIF(iabs(kflr).EQ.21.AND.rlu(0).GT.0.5) THEN 
           kflsp=kfl(2)  
           kflch=kfl(3)  
         ELSEIF(iabs(kflr).EQ.21) THEN   
           kflsp=kfl(3)  
           kflch=kfl(2)  
         ELSEIF(kflr*kfl(2).GT.0) THEN   
           CALL lukfdi(-kflr,kfl(2),kfdump,kflch)    
           kflsp=kfl(3)  
         ELSE    
           CALL lukfdi(-kflr,kfl(3),kfdump,kflch)    
           kflsp=kfl(2)  
         ENDIF   
     
 C...Subdivide baryon.   
       ELSE  
         nagr=0  
         DO 100 j=1,3    
   100   IF(kflr.EQ.kfl(j)) nagr=nagr+1  
         IF(nagr.GE.1) THEN  
           ragr=0.00001+(nagr-0.00002)*rlu(0)    
           iagr=0    
           DO 110 j=1,3  
           IF(kflr.EQ.kfl(j)) ragr=ragr-1.   
   110     IF(iagr.EQ.0.AND.ragr.LE.0.) iagr=j   
         ELSE    
           iagr=1.00001+2.99998*rlu(0)   
         ENDIF   
         id1=1   
         IF(iagr.EQ.1) id1=2 
         IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3    
         id2=6-iagr-id1  
         ksp=3   
         IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN  
           IF(iagr.NE.3.AND.rlu(0).GT.0.25) ksp=1    
         ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN  
           IF(iagr.NE.1.AND.rlu(0).GT.0.25) ksp=1    
         ELSEIF(mod(kfa,10).EQ.2) THEN   
           IF(iagr.EQ.1) ksp=1   
           IF(iagr.NE.1.AND.rlu(0).GT.0.75) ksp=1    
         ENDIF   
         kflsp=1000*kfl(id1)+100*kfl(id2)+ksp    
         IF(kflin.EQ.21) THEN    
           kflch=kfl(iagr)   
         ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN    
           CALL lukfdi(-kflr,kfl(iagr),kfdump,kflch) 
         ELSEIF(nagr.EQ.0) THEN  
           CALL lukfdi(10000+kflsp,-kflr,kfdump,kflch)   
           kflsp=kfl(iagr)   
         ENDIF   
       ENDIF 
     
 C...Add on correct sign for result. 
       kflch=kflch*kfs   
       kflsp=kflsp*kfs   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pysspa()

subroutine pysspa	(	IPU1,
		IPU2
	)

Definition at line 13260 of file hipyset1.35.f.

     
 C...Generates spacelike parton showers. 
       IMPLICIT DOUBLE PRECISION(d)  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)  
       SAVE /pyint3/ 
       dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevs(2),robo(5),   
      &xfs(2,-6:6),xfa(-6:6),xfb(-6:6),xfn(-6:6),wtap(-6:6),wtsf(-6:6),  
      &the2(2),alam(2),dq2(3),dpc(3),dpd(4),dpb(4)   
     
 C...Calculate maximum virtuality and check that evolution possible. 
       ipus1=ipu1    
       ipus2=ipu2    
       isub=mint(1)  
       q2e=vint(52)  
       IF(iset(isub).EQ.1) THEN  
         q2e=q2e/parp(67)    
       ELSEIF(iset(isub).EQ.3.OR.iset(isub).EQ.4) THEN   
         q2e=pmas(23,1)**2   
         IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77) q2e=pmas(24,1)**2 
       ENDIF 
       tmax=log(parp(67)*parp(63)*q2e/parp(61)**2)   
       IF(parp(67)*q2e.LT.max(parp(62)**2,2.*parp(61)**2).OR.    
      &tmax.LT.0.2) RETURN   
     
 C...Common constants and initial values. Save normal Lambda value.  
       xe0=2.*parp(65)/vint(1)   
       alams=paru(111)   
       paru(111)=parp(61)    
       ns=n  
   100 n=ns  
       DO 110 jt=1,2 
       kfls(jt)=mint(14+jt)  
       kfls(jt+2)=kfls(jt)   
       xs(jt)=vint(40+jt)    
       zs(jt)=1. 
       q2s(jt)=parp(67)*q2e  
       tevs(jt)=tmax 
       alam(jt)=parp(61) 
       the2(jt)=100. 
       DO 110 kfl=-6,6   
   110 xfs(jt,kfl)=xsfx(jt,kfl)  
       dsh=vint(44)  
       IF(iset(isub).EQ.3.OR.iset(isub).EQ.4) dsh=vint(26)*vint(2)   
     
 C...Pick up leg with highest virtuality.    
   120 n=n+1 
       jt=1  
       IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2   
       kflb=kfls(jt) 
       xb=xs(jt) 
       DO 130 kfl=-6,6   
   130 xfb(kfl)=xfs(jt,kfl)  
       dshr=2d0*sqrt(dsh)    
       dshz=dsh/dble(zs(jt)) 
       xe=max(xe0,xb*(1./(1.-parp(66))-1.))  
       IF(xb+xe.GE.0.999) THEN   
         q2b=0.  
         GOTO 220    
       ENDIF 
     
 C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.   
       IF(mstp(62).LE.1) THEN    
         q2b=0.5*(1./zs(jt)+1.)*q2s(jt)+0.5*(1./zs(jt)-1.)*(q2s(3-jt)-   
      &  sngl(dsh)+sqrt((sngl(dsh)+q2s(1)+q2s(2))**2+8.*q2s(1)*q2s(2)*   
      &  zs(jt)/(1.-zs(jt))))    
         tevb=log(parp(63)*q2b/alam(jt)**2)  
       ELSE  
         q2b=q2s(jt) 
         tevb=tevs(jt)   
       ENDIF 
       alsdum=ulalps(parp(63)*q2b)   
       tevb=tevb+2.*log(alam(jt)/paru(117))  
       tevbsv=tevb   
       alam(jt)=paru(117)    
       b0=(33.-2.*mstu(118))/6.  
     
 C...Calculate Altarelli-Parisi and structure function weights.  
       DO 140 kfl=-6,6   
       wtap(kfl)=0.  
   140 wtsf(kfl)=0.  
       IF(kflb.EQ.21) THEN   
         wtapq=16.*(1.-sqrt(xb+xe))/(3.*sqrt(xb))    
         DO 150 kfl=-mstp(54),mstp(54)   
         IF(kfl.EQ.0) wtap(kfl)=6.*log((1.-xb)/xe)   
   150   IF(kfl.NE.0) wtap(kfl)=wtapq    
       ELSE  
         wtap(0)=0.5*xb*(1./(xb+xe)-1.)  
         wtap(kflb)=8.*log((1.-xb)*(xb+xe)/xe)/3.    
       ENDIF 
   160 wtsum=0.  
       IF(kflb.NE.21) xfbo=xfb(kflb) 
       IF(kflb.EQ.21) xfbo=xfb(0)
 C***************************************************************
 C**********ERROR HAS OCCURED HERE
       IF(xfbo.EQ.0.0) THEN
                 WRITE(mstu(11),1000)
                 WRITE(mstu(11),1001) kflb,xfb(kflb)
         xfbo=0.00001
       ENDIF
 C****************************************************************    
       DO 170 kfl=-mstp(54),mstp(54) 
       wtsf(kfl)=xfb(kfl)/xfbo   
   170 wtsum=wtsum+wtap(kfl)*wtsf(kfl)   
       wtsum=max(0.0001,wtsum)   
     
 C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).  
   180 IF(mstp(64).LE.0) THEN    
         tevb=tevb+log(rlu(0))*paru(2)/(paru(111)*wtsum) 
       ELSEIF(mstp(64).EQ.1) THEN    
         tevb=tevb*exp(max(-100.,log(rlu(0))*b0/wtsum))  
       ELSE  
         tevb=tevb*exp(max(-100.,log(rlu(0))*b0/(5.*wtsum))) 
       ENDIF 
   190 q2ref=alam(jt)**2*exp(tevb)   
       q2b=q2ref/parp(63)    
     
 C...Evolution ended or select flavour for branching parton. 
       IF(q2b.LT.parp(62)**2) THEN   
         q2b=0.  
       ELSE  
         wtran=rlu(0)*wtsum  
         kfla=-mstp(54)-1    
   200   kfla=kfla+1 
         wtran=wtran-wtap(kfla)*wtsf(kfla)   
         IF(kfla.LT.mstp(54).AND.wtran.GT.0.) GOTO 200   
         IF(kfla.EQ.0) kfla=21   
     
 C...Choose z value and corrective weight.   
         IF(kflb.EQ.21.AND.kfla.EQ.21) THEN  
           z=1./(1.+((1.-xb)/xb)*(xe/(1.-xb))**rlu(0))   
           wtz=(1.-z*(1.-z))**2  
         ELSEIF(kflb.EQ.21) THEN 
           z=xb/(1.-rlu(0)*(1.-sqrt(xb+xe)))**2  
           wtz=0.5*(1.+(1.-z)**2)*sqrt(z)    
         ELSEIF(kfla.EQ.21) THEN 
           z=xb*(1.+rlu(0)*(1./(xb+xe)-1.))  
           wtz=1.-2.*z*(1.-z)    
         ELSE    
           z=1.-(1.-xb)*(xe/((xb+xe)*(1.-xb)))**rlu(0)   
           wtz=0.5*(1.+z**2) 
         ENDIF   
     
 C...Option with resummation of soft gluon emission as effective z shift.    
         IF(mstp(65).GE.1) THEN  
           rsoft=6.  
           IF(kflb.NE.21) rsoft=8./3.    
           z=z*(tevb/tevs(jt))**(rsoft*xe/((xb+xe)*b0))  
           IF(z.LE.xb) GOTO 180  
         ENDIF   
     
 C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.   
         IF(mstp(64).GE.2) THEN  
           IF((1.-z)*q2b.LT.parp(62)**2) GOTO 180    
           alprat=tevb/(tevb+log(1.-z))  
           IF(alprat.LT.5.*rlu(0)) GOTO 180  
           IF(alprat.GT.5.) wtz=wtz*alprat/5.    
         ENDIF   
     
 C...Option with angular ordering requirement.   
         IF(mstp(62).GE.3) THEN  
           the2t=(4.*z**2*q2b)/(vint(2)*(1.-z)*xb**2)    
           IF(the2t.GT.the2(jt)) GOTO 180    
         ENDIF   
     
 C...Weighting with new structure functions. 
         CALL pystfu(mint(10+jt),xb,q2ref,xfn,jt)   
         IF(kflb.NE.21) xfbn=xfn(kflb)   
         IF(kflb.EQ.21) xfbn=xfn(0)  
         IF(xfbn.LT.1e-20) THEN  
           IF(kfla.EQ.kflb) THEN 
             tevb=tevbsv 
             wtap(kflb)=0.   
             GOTO 160    
           ELSEIF(tevbsv-tevb.GT.0.2) THEN   
             tevb=0.5*(tevbsv+tevb)  
             GOTO 190    
           ELSE  
             xfbn=1e-10  
           ENDIF 
         ENDIF   
         DO 210 kfl=-mstp(54),mstp(54)   
   210   xfb(kfl)=xfn(kfl)   
         xa=xb/z 
         CALL pystfu(mint(10+jt),xa,q2ref,xfa,jt)   
         IF(kfla.NE.21) xfan=xfa(kfla)   
         IF(kfla.EQ.21) xfan=xfa(0)  
         IF(xfan.LT.1e-20) GOTO 160  
         IF(kfla.NE.21) wtsfa=wtsf(kfla) 
         IF(kfla.EQ.21) wtsfa=wtsf(0)    
         IF(wtz*xfan/xfbn.LT.rlu(0)*wtsfa) GOTO 160  
       ENDIF 
     
 C...Define two hard scatterers in their CM-frame.   
   220 IF(n.EQ.ns+2) THEN    
         dq2(jt)=q2b 
         dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr   
         DO 240 jr=1,2   
         i=ns+jr 
         IF(jr.EQ.1) ipo=ipus1   
         IF(jr.EQ.2) ipo=ipus2   
         DO 230 j=1,5    
         k(i,j)=0    
         p(i,j)=0.   
   230   v(i,j)=0.   
         k(i,1)=14   
         k(i,2)=kfls(jr+2)   
         k(i,4)=ipo  
         k(i,5)=ipo  
         p(i,3)=dplcm*(-1)**(jr+1)   
         p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr 
         p(i,5)=-sqrt(sngl(dq2(jr))) 
         k(ipo,1)=14 
         k(ipo,3)=i  
         k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i    
   240   k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i    
     
 C...Find maximum allowed mass of timelike parton.   
       ELSEIF(n.GT.ns+2) THEN    
         jr=3-jt 
         dq2(3)=q2b  
         dpc(1)=p(is(1),4)   
         dpc(2)=p(is(2),4)   
         dpc(3)=0.5*(abs(p(is(1),3))+abs(p(is(2),3)))    
         dpd(1)=dsh+dq2(jr)+dq2(jt)  
         dpd(2)=dshz+dq2(jr)+dq2(3)  
         dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))  
         dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))   
         ikin=0  
         IF(q2s(jr).GE.(0.5*parp(62))**2.AND.dpd(1)-dpd(3).GE.   
      &  1d-10*dpd(1)) ikin=1    
         IF(ikin.EQ.0) dmsma=(dq2(jt)/dble(zs(jt))-dq2(3))*(dsh/ 
      &  (dsh+dq2(jt))-dsh/(dshz+dq2(3)))    
         IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/(2.*  
      &  dq2(jr))-dq2(jt)-dq2(3) 
     
 C...Generate timelike parton shower (if required).  
         it=n    
         DO 250 j=1,5    
         k(it,j)=0   
         p(it,j)=0.  
   250   v(it,j)=0.  
         k(it,1)=3   
         k(it,2)=21  
         IF(kflb.EQ.21.AND.kfls(jt+2).NE.21) k(it,2)=-kfls(jt+2) 
         IF(kflb.NE.21.AND.kfls(jt+2).EQ.21) k(it,2)=kflb    
         p(it,5)=ulmass(k(it,2)) 
         IF(sngl(dmsma).LE.p(it,5)**2) GOTO 100  
         IF(mstp(63).GE.1) THEN  
           p(it,4)=(dshz-dsh-p(it,5)**2)/dshr    
           p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)   
           IF(mstp(63).EQ.1) THEN    
             q2tim=dmsma 
           ELSEIF(mstp(63).EQ.2) THEN    
             q2tim=min(sngl(dmsma),parp(71)*q2s(jt)) 
           ELSE  
 C'''Here remains to introduce angular ordering in first branching.  
             q2tim=dmsma 
           ENDIF 
           CALL lushow(it,0,sqrt(q2tim)) 
           IF(n.GE.it+1) p(it,5)=p(it+1,5)   
         ENDIF   
     
 C...Reconstruct kinematics of branching: timelike parton shower.    
         dms=p(it,5)**2  
         IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))  
         IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5*dpd(1)*dpd(2)+0.5*dpd(3)*   
      &  dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/(4.*dsh*dpc(3)**2) 
         IF(dpt2.LT.0.) GOTO 100 
         dpb(1)=(0.5*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/  
      &  dshr)/dpc(3)-dpc(3) 
         p(it,1)=sqrt(sngl(dpt2))    
         p(it,3)=dpb(1)*(-1)**(jt+1) 
         p(it,4)=(dshz-dsh-dms)/dshr 
         IF(n.GE.it+1) THEN  
           dpb(1)=sqrt(dpb(1)**2+dpt2)   
           dpb(2)=sqrt(dpb(1)**2+dms)    
           dpb(3)=p(it+1,3)  
           dpb(4)=sqrt(dpb(3)**2+dms)    
           dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)* 
      &    dpb(1))   
           CALL ludbrb(it+1,n,0.,0.,0d0,0d0,dbez)    
           the=ulangl(p(it,3),p(it,1))   
           CALL ludbrb(it+1,n,the,0.,0d0,0d0,0d0)    
         ENDIF   
     
 C...Reconstruct kinematics of branching: spacelike parton.  
         DO 260 j=1,5    
         k(n+1,j)=0  
         p(n+1,j)=0. 
   260   v(n+1,j)=0. 
         k(n+1,1)=14 
         k(n+1,2)=kflb   
         p(n+1,1)=p(it,1)    
         p(n+1,3)=p(it,3)+p(is(jt),3)    
         p(n+1,4)=p(it,4)+p(is(jt),4)    
         p(n+1,5)=-sqrt(sngl(dq2(3)))    
     
 C...Define colour flow of branching.    
         k(is(jt),3)=n+1 
         k(it,3)=n+1 
         id1=it  
         IF((k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(id1,2).GT.0.AND. 
      &  k(id1,2).NE.21).OR.(k(n+1,2).LT.0.AND.k(id1,2).EQ.21).OR.   
      &  (k(n+1,2).EQ.21.AND.k(id1,2).EQ.21.AND.rlu(0).GT.0.5).OR.   
      &  (k(n+1,2).EQ.21.AND.k(id1,2).LT.0)) id1=is(jt)  
         id2=it+is(jt)-id1   
         k(n+1,4)=k(n+1,4)+id1   
         k(n+1,5)=k(n+1,5)+id2   
         k(id1,4)=k(id1,4)+mstu(5)*(n+1) 
         k(id1,5)=k(id1,5)+mstu(5)*id2   
         k(id2,4)=k(id2,4)+mstu(5)*id1   
         k(id2,5)=k(id2,5)+mstu(5)*(n+1) 
         n=n+1   
     
 C...Boost to new CM-frame.  
         CALL ludbrb(ns+1,n,0.,0.,-dble((p(n,1)+p(is(jr),1))/(p(n,4)+    
      &  p(is(jr),4))),0d0,-dble((p(n,3)+p(is(jr),3))/(p(n,4)+   
      &  p(is(jr),4))))  
         ir=n+(jt-1)*(is(1)-n)   
         CALL ludbrb(ns+1,n,-ulangl(p(ir,3),p(ir,1)),paru(2)*rlu(0), 
      &  0d0,0d0,0d0)    
       ENDIF 
     
 C...Save quantities, loop back. 
       is(jt)=n  
       q2s(jt)=q2b   
       dq2(jt)=q2b   
       IF(mstp(62).GE.3) the2(jt)=the2t  
       dsh=dshz  
       IF(q2b.GE.(0.5*parp(62))**2) THEN 
         kfls(jt+2)=kfls(jt) 
         kfls(jt)=kfla   
         xs(jt)=xa   
         zs(jt)=z    
         DO 270 kfl=-6,6 
   270   xfs(jt,kfl)=xfa(kfl)    
         tevs(jt)=tevb   
       ELSE  
         IF(jt.EQ.1) ipu1=n  
         IF(jt.EQ.2) ipu2=n  
       ENDIF 
       IF(n.GT.mstu(4)-mstu(32)-10) THEN 
         CALL luerrm(11,'(PYSSPA:) no more memory left in LUJETS')   
         IF(mstu(21).GE.1) n=ns  
         IF(mstu(21).GE.1) RETURN    
       ENDIF 
       IF(max(q2s(1),q2s(2)).GE.(0.5*parp(62))**2.OR.n.LE.ns+1) GOTO 120 
     
 C...Boost hard scattering partons to frame of shower initiators.    
       DO 280 j=1,3  
   280 robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4)) 
       DO 290 j=1,5  
   290 p(n+2,j)=p(ns+1,j)    
       robot=robo(3)**2+robo(4)**2+robo(5)**2    
       IF(robot.GE.0.999999) THEN    
         robot=1.00001*sqrt(robot)   
         robo(3)=robo(3)/robot   
         robo(4)=robo(4)/robot   
         robo(5)=robo(5)/robot   
       ENDIF 
       CALL ludbrb(n+2,n+2,0.,0.,-dble(robo(3)),-dble(robo(4)),  
      &-dble(robo(5)))   
       robo(2)=ulangl(p(n+2,1),p(n+2,2)) 
       robo(1)=ulangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))    
       CALL ludbrb(mint(83)+5,ns,robo(1),robo(2),dble(robo(3)),  
      &dble(robo(4)),dble(robo(5)))  
     
 C...Store user information. Reset Lambda value. 
       k(ipu1,3)=mint(83)+3  
       k(ipu2,3)=mint(83)+4  
       DO 300 jt=1,2 
       mint(12+jt)=kfls(jt)  
   300 vint(140+jt)=xs(jt)   
       paru(111)=alams   
  1000 FORMAT(5x,'structure function has a zero point here')
  1001 FORMAT(5x,'xf(x,i=',i5,')=',f10.5)
 
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pystat()

subroutine pystat ( MSTAT )

Definition at line 10603 of file hipyset1.35.f.

     
 C...Prints out information about cross-sections, decay widths, branching    
 C...ratios, kinematical limits, status codes and parameter values.  
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
       common/pyint6/proc(0:200) 
       CHARACTER proc*28 
       SAVE /pyint6/ 
       CHARACTER chau*16,chpa(-40:40)*12,chin(2)*12, 
      &state(-1:5)*4,chkin(21)*18    
       DATA state/'----','off ','on  ','on/+','on/-','on/1','on/2'/, 
      &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',  
      &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',   
      &'     y*_small     ','    eta*_large    ','    eta*_small    ',   
      &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',   
      &'       x_2        ','       x_F        ',' cos(theta_hard)  ',   
      &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',  
      &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',   
      &'       tau''       '/    
     
 C...Cross-sections. 
       IF(mstat.LE.1) THEN   
         WRITE(mstu(11),1000)    
         WRITE(mstu(11),1100)    
         WRITE(mstu(11),1200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)    
         DO 100 i=1,200  
         IF(msub(i).NE.1) GOTO 100   
         WRITE(mstu(11),1200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)    
   100   CONTINUE    
         WRITE(mstu(11),1300) 1.-float(ngen(0,3))/   
      &  max(1.,float(ngen(0,2)))    
     
 C...Decay widths and branching ratios.  
       ELSEIF(mstat.EQ.2) THEN   
         DO 110 kf=-40,40    
         CALL luname(kf,chau)    
   110   chpa(kf)=chau(1:12) 
         WRITE(mstu(11),1400)    
         WRITE(mstu(11),1500)    
 C...Off-shell branchings.   
         DO 130 i=1,17   
         kc=i    
         IF(i.GE.9) kc=i+2   
         IF(i.EQ.17) kc=21   
         WRITE(mstu(11),1600) chpa(kc),0.,0.,state(mdcy(kc,1)),0.    
         DO 120 j=1,mdcy(kc,3)   
         idc=j+mdcy(kc,2)-1  
   120   IF(mdme(idc,2).EQ.102) WRITE(mstu(11),1700) chpa(kfdp(idc,1)),  
      &  chpa(kfdp(idc,2)),0.,0.,state(mdme(idc,1)),0.   
   130   CONTINUE    
 C...On-shell decays.    
         DO 150 i=1,6    
         kc=i+22 
         IF(i.EQ.4) kc=32    
         IF(i.EQ.5) kc=37    
         IF(i.EQ.6) kc=40    
         IF(wide(kc,0).GT.0.) THEN   
           WRITE(mstu(11),1600) chpa(kc),widp(kc,0),1.,  
      &    state(mdcy(kc,1)),1.  
           DO 140 j=1,mdcy(kc,3) 
           idc=j+mdcy(kc,2)-1    
   140     WRITE(mstu(11),1700) chpa(kfdp(idc,1)),chpa(kfdp(idc,2)), 
      &    widp(kc,j),widp(kc,j)/widp(kc,0),state(mdme(idc,1)),  
      &    wide(kc,j)/wide(kc,0) 
         ELSE    
           WRITE(mstu(11),1600) chpa(kc),widp(kc,0),1.,  
      &    state(mdcy(kc,1)),0.  
         ENDIF   
   150   CONTINUE    
         WRITE(mstu(11),1800)    
     
 C...Allowed incoming partons/particles at hard interaction. 
       ELSEIF(mstat.EQ.3) THEN   
         WRITE(mstu(11),1900)    
         CALL luname(mint(11),chau)  
         chin(1)=chau(1:12)  
         CALL luname(mint(12),chau)  
         chin(2)=chau(1:12)  
         WRITE(mstu(11),2000) chin(1),chin(2)    
         DO 160 kf=-40,40    
         CALL luname(kf,chau)    
   160   chpa(kf)=chau(1:12) 
         IF(mint(43).EQ.1) THEN  
           WRITE(mstu(11),2100) chpa(mint(11)),state(kfin(1,mint(11))),  
      &    chpa(mint(12)),state(kfin(2,mint(12)))    
         ELSEIF(mint(43).EQ.2) THEN  
           WRITE(mstu(11),2100) chpa(mint(11)),state(kfin(1,mint(11))),  
      &    chpa(-mstp(54)),state(kfin(2,-mstp(54)))  
           DO 170 i=-mstp(54)+1,-1   
   170     WRITE(mstu(11),2200) chpa(i),state(kfin(2,i)) 
           DO 180 i=1,mstp(54)   
   180     WRITE(mstu(11),2200) chpa(i),state(kfin(2,i)) 
           WRITE(mstu(11),2200) chpa(21),state(kfin(2,21))   
         ELSEIF(mint(43).EQ.3) THEN  
           WRITE(mstu(11),2100) chpa(-mstp(54)),state(kfin(1,-mstp(54))),    
      &    chpa(mint(12)),state(kfin(2,mint(12)))    
           DO 190 i=-mstp(54)+1,-1   
   190     WRITE(mstu(11),2300) chpa(i),state(kfin(1,i)) 
           DO 200 i=1,mstp(54)   
   200     WRITE(mstu(11),2300) chpa(i),state(kfin(1,i)) 
           WRITE(mstu(11),2300) chpa(21),state(kfin(1,21))   
         ELSEIF(mint(43).EQ.4) THEN  
           DO 210 i=-mstp(54),-1 
   210     WRITE(mstu(11),2100) chpa(i),state(kfin(1,i)),chpa(i),    
      &    state(kfin(2,i))  
           DO 220 i=1,mstp(54)   
   220     WRITE(mstu(11),2100) chpa(i),state(kfin(1,i)),chpa(i),    
      &    state(kfin(2,i))  
           WRITE(mstu(11),2100) chpa(21),state(kfin(1,21)),chpa(21), 
      &    state(kfin(2,21)) 
         ENDIF   
         WRITE(mstu(11),2400)    
     
 C...User-defined and derived limits on kinematical variables.   
       ELSEIF(mstat.EQ.4) THEN   
         WRITE(mstu(11),2500)    
         WRITE(mstu(11),2600)    
         shrmax=ckin(2)  
         IF(shrmax.LT.0.) shrmax=vint(1) 
         WRITE(mstu(11),2700) ckin(1),chkin(1),shrmax    
         pthmin=max(ckin(3),ckin(5)) 
         pthmax=ckin(4)  
         IF(pthmax.LT.0.) pthmax=0.5*shrmax  
         WRITE(mstu(11),2800) ckin(3),pthmin,chkin(2),pthmax 
         WRITE(mstu(11),2900) chkin(3),ckin(6)   
         DO 230 i=4,14   
   230   WRITE(mstu(11),2700) ckin(2*i-1),chkin(i),ckin(2*i) 
         sprmax=ckin(32) 
         IF(sprmax.LT.0.) sprmax=vint(1) 
         WRITE(mstu(11),2700) ckin(31),chkin(13),sprmax  
         WRITE(mstu(11),3000)    
         WRITE(mstu(11),3100)    
         WRITE(mstu(11),2600)    
         DO 240 i=16,21  
   240   WRITE(mstu(11),2700) vint(i-5),chkin(i),vint(i+15)  
         WRITE(mstu(11),3000)    
     
 C...Status codes and parameter values.  
       ELSEIF(mstat.EQ.5) THEN   
         WRITE(mstu(11),3200)    
         WRITE(mstu(11),3300)    
         DO 250 i=1,100  
   250   WRITE(mstu(11),3400) i,mstp(i),parp(i),100+i,mstp(100+i),   
      &  parp(100+i) 
       ENDIF 
     
 C...Formats for printouts.  
  1000 FORMAT('1',9('*'),1x,'PYSTAT:  Statistics on Number of ', 
      &'Events and Cross-sections',1x,9('*'))    
  1100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x, 
      &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,  
      &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),    
      &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,    
      &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x, 
      &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x, 
      &'I',12x,'I')  
  1200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p, 
      &e10.3,1x,'I') 
  1300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//    
      &1x,'********* Fraction of events that fail fragmentation ',   
      &'cuts =',1x,f8.5,' *********'/)   
  1400 FORMAT('1',17('*'),1x,'PYSTAT:  Decay Widths and Branching ', 
      &'Ratios',1x,17('*'))  
  1500 FORMAT(/1x,78('=')/1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/ 
      &1x,'I',1x,'Branching/Decay Channel',5x,'I',1x,'Width (GeV)',1x,   
      &'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,'Eff. B.R.',1x,'I'/1x,   
      &'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,78('='))    
  1600 FORMAT(1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,   
      &a12,1x,'->',13x,'I',2x,1p,e10.3,0p,1x,'I',1x,1p,e10.3,0p,1x,'I',  
      &1x,a4,1x,'I',1x,1p,e10.3,0p,1x,'I')   
  1700 FORMAT(1x,'I',1x,a12,1x,'+',1x,a12,1x,'I',2x,1p,e10.3,0p,1x,'I',  
      &1x,1p,e10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,e10.3,0p,1x,'I') 
  1800 FORMAT(1x,'I',29x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,78('='))  
  1900 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/', 
      &'Particles at Hard Interaction',1x,7('*'))    
  2000 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,  
      &'Beam particle:',1x,a,10x,'I',1x,'Target particle:',1x,a,7x,  
      &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',9x,'State',16x,    
      &'I',1x,'Content',9x,'State',15x,'I'/1x,'I',38x,'I',37x,'I'/1x,    
      &78('=')/1x,'I',38x,'I',37x,'I')   
  2100 FORMAT(1x,'I',1x,a,5x,a,16x,'I',1x,a,5x,a,15x,'I')    
  2200 FORMAT(1x,'I',38x,'I',1x,a,5x,a,15x,'I')  
  2300 FORMAT(1x,'I',1x,a,5x,a,16x,'I',37x,'I')  
  2400 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('=')) 
  2500 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',  
      &'Kinematical Variables',1x,12('*'))   
  2600 FORMAT(/1x,78('=')/1x,'I',76x,'I')    
  2700 FORMAT(1x,'I',16x,1p,e10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,e10.3,0p,  
      &16x,'I')  
  2800 FORMAT(1x,'I',3x,1p,e10.3,0p,1x,'(',1p,e10.3,0p,')',1x,'<',1x,a,  
      &1x,'<',1x,1p,e10.3,0p,16x,'I')    
  2900 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,e10.3,0p,16x,'I')    
  3000 FORMAT(1x,'I',76x,'I'/1x,78('=')) 
  3100 FORMAT(////1x,5('*'),1x,'PYSTAT: Derived Limits on Kinematical ', 
      &'Variables Used in Generation',1x,5('*')) 
  3200 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ', 
      &'Parameter Values',1x,12('*'))    
  3300 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x, 
      &'PARP(I)'/)   
  3400 FORMAT(1x,i3,5x,i6,6x,1p,e10.3,0p,18x,i3,5x,i6,6x,1p,e10.3)   
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pystfe()

subroutine pystfe	(		KF,
			X,
			Q2,
		dimension(-6:6)	XPQ
	)

Definition at line 19504 of file hipyset1.35.f.

     
 C...This is a dummy routine, where the user can introduce an interface  
 C...to his own external structure function parametrization. 
 C...Arguments in:   
 C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge  
 C...    conjugation for pbar, nbar or pi- is performed by PYSTFU.   
 C...X : x value.    
 C...Q2 : Q^2 value. 
 C...Arguments out:  
 C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,   
 C...    except that gluon is placed in 0. Thus XPQ(0) = xg, 
 C...    XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar, 
 C...    XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar, 
 C...    XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar. 
 C...    
 C...One such interface, to the Diemos, Ferroni, Longo, Martinelli   
 C...proton structure functions, already comes with the package. What    
 C...the user needs here is external files with the three routines   
 C...FXG160, FXG260 and FXG360 of the authors above, plus the    
 C...interpolation routine FINT, which is part of the CERN library   
 C...KERNLIB package. To avoid problems with unresolved external 
 C...references, the external calls are commented in the current 
 C...version. To enable this option, remove the C* at the beginning  
 C...of the relevant lines.  
 C...    
 C...Alternatively, the routine can be used as an interface to the   
 C...structure function evolution program of Tung. This can be achieved  
 C...by removing C* at the beginning of some of the lines below. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       dimension xpq(-6:6),xfdflm(9) 
       CHARACTER chdflm(9)*5,header*40   
       DATA chdflm/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',  
      &'CBAR ','BBAR ','TBAR '/  
       DATA header/'Tung evolution package has been invoked'/    
       DATA init/0/  
     
 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 
 C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95. 
       IF(mstp(51).GE.11.AND.mstp(51).LE.13.AND.mstp(52).LE.1) THEN  
         xdflm=max(0.51e-4,x)    
         q2dflm=max(10.,min(1e8,q2)) 
         IF(mstp(52).EQ.0) q2dflm=10.    
         DO 100 j=1,9    
         IF(mstp(52).EQ.1.AND.j.EQ.9) THEN   
           q2dflm=q2dflm*(40./pmas(6,1))**2  
           q2dflm=max(10.,min(1e8,q2))   
         ENDIF   
         xfdflm(j)=0.    
 C...Remove C* on following three lines to enable the DFLM options.  
 C*      IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
 C*      IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
 C*      IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))    
   100   CONTINUE    
         IF(x.LT.0.51e-4.AND.abs(parp(51)-1.).GT.0.01) THEN  
           cxs=(0.51e-4/x)**(parp(51)-1.)    
           DO 110 j=1,7  
   110     xfdflm(j)=xfdflm(j)*cxs   
         ENDIF   
         xpq(0)=xfdflm(3)    
         xpq(1)=xfdflm(2)+xfdflm(5)  
         xpq(2)=xfdflm(1)+xfdflm(5)  
         xpq(3)=xfdflm(6)    
         xpq(4)=xfdflm(7)    
         xpq(5)=xfdflm(8)    
         xpq(6)=xfdflm(9)    
         xpq(-1)=xfdflm(5)   
         xpq(-2)=xfdflm(5)   
         xpq(-3)=xfdflm(6)   
         xpq(-4)=xfdflm(7)   
         xpq(-5)=xfdflm(8)   
         xpq(-6)=xfdflm(9)   
     
 C...Proton structure function evolution from Wu-Ki Tung: parton 
 C...distribution functions incorporating heavy quark mass effects.  
 C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.  
       ELSE  
         IF(init.EQ.0) THEN  
           i1=0  
           IF(mstp(52).EQ.4) i1=1    
           ihdrn=1   
           nu=mstp(53)   
           i2=mstp(51)   
           IF(mstp(51).GE.11) i2=mstp(51)-3  
           i3=0  
           IF(mstp(52).EQ.3) i3=1    
     
 C...Convert to Lambda in CWZ scheme (approximately linear relation).    
           alam=0.75*parp(1) 
           tpms=pmas(6,1)    
           qini=parp(52) 
           qmax=parp(53) 
           xmin=parp(54) 
     
 C...Initialize evolution (perform calculation or read results from  
 C...file).  
 C...Remove C* on following two lines to enable Tung initialization. 
 C*        CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,  
 C*   &    I2,I3,IRET,IRR)   
           init=1    
         ENDIF   
     
 C...Put into output array.  
         q=sqrt(q2)  
         DO 200 i=-6,6   
         fixq=0. 
 C...Remove C* on following line to enable structure function call.  
 C*      FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR)) 
   200   xpq(i)=x*fixq   
     
 C...Change order of u and d quarks from Tung to PYTHIA convention.  
         xps=xpq(1)  
         xpq(1)=xpq(2)   
         xpq(2)=xps  
         xps=xpq(-1) 
         xpq(-1)=xpq(-2) 
         xpq(-2)=xps 
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pystfu()

subroutine pystfu	(		KF,
			X,
			Q2,
		dimension(-6:6)	XPQ,
			JBT
	)

Definition at line 18118 of file hipyset1.35.f.

     
 C           *******JBT specifies beam or target of the particle
 C...Gives proton and pi+ parton structure functions according to a few  
 C...different parametrizations. Note that what is coded is x times the  
 C...probability distribution, i.e. xq(x,Q2) etc.    
       common/hiparnt/hipr1(100),ihpr2(50),hint1(100),ihnt2(50)
       SAVE  /hiparnt/
       common/hijcrdn/yp(3,300),yt(3,300)
       SAVE  /hijcrdn/
 C           ********COMMON BLOCK FROM HIJING
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       dimension xpq(-6:6),xq(6),tx(6),tt(6),ts(6),nehlq(8,2),   
      &cehlq(6,6,2,8,2),cdo(3,6,5,2),cow(3,5,4,2)    
     
 C...The following data lines are coefficients needed in the 
 C...Eichten, Hinchliffe, Lane, Quigg proton structure function  
 C...parametrizations, see below.    
 C...Powers of 1-x in different cases.   
       DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/   
 C...Expansion coefficients for up valence quark distribution.   
       DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/  
      1 7.677e-01,-2.087e-01,-3.303e-01,-2.517e-02,-1.570e-02,-1.000e-04,    
      2-5.326e-01,-2.661e-01, 3.201e-01, 1.192e-01, 2.434e-02, 7.620e-03,    
      3 2.162e-01, 1.881e-01,-8.375e-02,-6.515e-02,-1.743e-02,-5.040e-03,    
      4-9.211e-02,-9.952e-02, 1.373e-02, 2.506e-02, 8.770e-03, 2.550e-03,    
      5 3.670e-02, 4.409e-02, 9.600e-04,-7.960e-03,-3.420e-03,-1.050e-03,    
      6-1.549e-02,-2.026e-02,-3.060e-03, 2.220e-03, 1.240e-03, 4.100e-04,    
      1 2.395e-01, 2.905e-01, 9.778e-02, 2.149e-02, 3.440e-03, 5.000e-04,    
      2 1.751e-02,-6.090e-03,-2.687e-02,-1.916e-02,-7.970e-03,-2.750e-03,    
      3-5.760e-03,-5.040e-03, 1.080e-03, 2.490e-03, 1.530e-03, 7.500e-04,    
      4 1.740e-03, 1.960e-03, 3.000e-04,-3.400e-04,-2.900e-04,-1.800e-04,    
      5-5.300e-04,-6.400e-04,-1.700e-04, 4.000e-05, 6.000e-05, 4.000e-05,    
      6 1.700e-04, 2.200e-04, 8.000e-05, 1.000e-05,-1.000e-05,-1.000e-05/    
       DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/  
      1 7.237e-01,-2.189e-01,-2.995e-01,-1.909e-02,-1.477e-02, 2.500e-04,    
      2-5.314e-01,-2.425e-01, 3.283e-01, 1.119e-01, 2.223e-02, 7.070e-03,    
      3 2.289e-01, 1.890e-01,-9.859e-02,-6.900e-02,-1.747e-02,-5.080e-03,    
      4-1.041e-01,-1.084e-01, 2.108e-02, 2.975e-02, 9.830e-03, 2.830e-03,    
      5 4.394e-02, 5.116e-02,-1.410e-03,-1.055e-02,-4.230e-03,-1.270e-03,    
      6-1.991e-02,-2.539e-02,-2.780e-03, 3.430e-03, 1.720e-03, 5.500e-04,    
      1 2.410e-01, 2.884e-01, 9.369e-02, 1.900e-02, 2.530e-03, 2.400e-04,    
      2 1.765e-02,-9.220e-03,-3.037e-02,-2.085e-02,-8.440e-03,-2.810e-03,    
      3-6.450e-03,-5.260e-03, 1.720e-03, 3.110e-03, 1.830e-03, 8.700e-04,    
      4 2.120e-03, 2.320e-03, 2.600e-04,-4.900e-04,-3.900e-04,-2.300e-04,    
      5-6.900e-04,-8.200e-04,-2.000e-04, 7.000e-05, 9.000e-05, 6.000e-05,    
      6 2.400e-04, 3.100e-04, 1.100e-04, 0.000e+00,-2.000e-05,-2.000e-05/    
 C...Expansion coefficients for down valence quark distribution. 
       DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/  
      1 3.813e-01,-8.090e-02,-1.634e-01,-2.185e-02,-8.430e-03,-6.200e-04,    
      2-2.948e-01,-1.435e-01, 1.665e-01, 6.638e-02, 1.473e-02, 4.080e-03,    
      3 1.252e-01, 1.042e-01,-4.722e-02,-3.683e-02,-1.038e-02,-2.860e-03,    
      4-5.478e-02,-5.678e-02, 8.900e-03, 1.484e-02, 5.340e-03, 1.520e-03,    
      5 2.220e-02, 2.567e-02,-3.000e-05,-4.970e-03,-2.160e-03,-6.500e-04,    
      6-9.530e-03,-1.204e-02,-1.510e-03, 1.510e-03, 8.300e-04, 2.700e-04,    
      1 1.261e-01, 1.354e-01, 3.958e-02, 8.240e-03, 1.660e-03, 4.500e-04,    
      2 3.890e-03,-1.159e-02,-1.625e-02,-9.610e-03,-3.710e-03,-1.260e-03,    
      3-1.910e-03,-5.600e-04, 1.590e-03, 1.590e-03, 8.400e-04, 3.900e-04,    
      4 6.400e-04, 4.900e-04,-1.500e-04,-2.900e-04,-1.800e-04,-1.000e-04,    
      5-2.000e-04,-1.900e-04, 0.000e+00, 6.000e-05, 4.000e-05, 3.000e-05,    
      6 7.000e-05, 8.000e-05, 2.000e-05,-1.000e-05,-1.000e-05,-1.000e-05/    
       DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/  
      1 3.578e-01,-8.622e-02,-1.480e-01,-1.840e-02,-7.820e-03,-4.500e-04,    
      2-2.925e-01,-1.304e-01, 1.696e-01, 6.243e-02, 1.353e-02, 3.750e-03,    
      3 1.318e-01, 1.041e-01,-5.486e-02,-3.872e-02,-1.038e-02,-2.850e-03,    
      4-6.162e-02,-6.143e-02, 1.303e-02, 1.740e-02, 5.940e-03, 1.670e-03,    
      5 2.643e-02, 2.957e-02,-1.490e-03,-6.450e-03,-2.630e-03,-7.700e-04,    
      6-1.218e-02,-1.497e-02,-1.260e-03, 2.240e-03, 1.120e-03, 3.500e-04,    
      1 1.263e-01, 1.334e-01, 3.732e-02, 7.070e-03, 1.260e-03, 3.400e-04,    
      2 3.660e-03,-1.357e-02,-1.795e-02,-1.031e-02,-3.880e-03,-1.280e-03,    
      3-2.100e-03,-3.600e-04, 2.050e-03, 1.920e-03, 9.800e-04, 4.400e-04,    
      4 7.700e-04, 5.400e-04,-2.400e-04,-3.900e-04,-2.400e-04,-1.300e-04,    
      5-2.600e-04,-2.300e-04, 2.000e-05, 9.000e-05, 6.000e-05, 4.000e-05,    
      6 9.000e-05, 1.000e-04, 2.000e-05,-2.000e-05,-2.000e-05,-1.000e-05/    
 C...Expansion coefficients for up and down sea quark distributions. 
       DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/  
      1 6.870e-02,-6.861e-02, 2.973e-02,-5.400e-03, 3.780e-03,-9.700e-04,    
      2-1.802e-02, 1.400e-04, 6.490e-03,-8.540e-03, 1.220e-03,-1.750e-03,    
      3-4.650e-03, 1.480e-03,-5.930e-03, 6.000e-04,-1.030e-03,-8.000e-05,    
      4 6.440e-03, 2.570e-03, 2.830e-03, 1.150e-03, 7.100e-04, 3.300e-04,    
      5-3.930e-03,-2.540e-03,-1.160e-03,-7.700e-04,-3.600e-04,-1.900e-04,    
      6 2.340e-03, 1.930e-03, 5.300e-04, 3.700e-04, 1.600e-04, 9.000e-05,    
      1 1.014e+00,-1.106e+00, 3.374e-01,-7.444e-02, 8.850e-03,-8.700e-04,    
      2 9.233e-01,-1.285e+00, 4.475e-01,-9.786e-02, 1.419e-02,-1.120e-03,    
      3 4.888e-02,-1.271e-01, 8.606e-02,-2.608e-02, 4.780e-03,-6.000e-04,    
      4-2.691e-02, 4.887e-02,-1.771e-02, 1.620e-03, 2.500e-04,-6.000e-05,    
      5 7.040e-03,-1.113e-02, 1.590e-03, 7.000e-04,-2.000e-04, 0.000e+00,    
      6-1.710e-03, 2.290e-03, 3.800e-04,-3.500e-04, 4.000e-05, 1.000e-05/    
       DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/  
      1 1.008e-01,-7.100e-02, 1.973e-02,-5.710e-03, 2.930e-03,-9.900e-04,    
      2-5.271e-02,-1.823e-02, 1.792e-02,-6.580e-03, 1.750e-03,-1.550e-03,    
      3 1.220e-02, 1.763e-02,-8.690e-03,-8.800e-04,-1.160e-03,-2.100e-04,    
      4-1.190e-03,-7.180e-03, 2.360e-03, 1.890e-03, 7.700e-04, 4.100e-04,    
      5-9.100e-04, 2.040e-03,-3.100e-04,-1.050e-03,-4.000e-04,-2.400e-04,    
      6 1.190e-03,-1.700e-04,-2.000e-04, 4.200e-04, 1.700e-04, 1.000e-04,    
      1 1.081e+00,-1.189e+00, 3.868e-01,-8.617e-02, 1.115e-02,-1.180e-03,    
      2 9.917e-01,-1.396e+00, 4.998e-01,-1.159e-01, 1.674e-02,-1.720e-03,    
      3 5.099e-02,-1.338e-01, 9.173e-02,-2.885e-02, 5.890e-03,-6.500e-04,    
      4-3.178e-02, 5.703e-02,-2.070e-02, 2.440e-03, 1.100e-04,-9.000e-05,    
      5 8.970e-03,-1.392e-02, 2.050e-03, 6.500e-04,-2.300e-04, 2.000e-05,    
      6-2.340e-03, 3.010e-03, 5.000e-04,-3.900e-04, 6.000e-05, 1.000e-05/    
 C...Expansion coefficients for gluon distribution.  
       DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/  
      1 9.482e-01,-9.578e-01, 1.009e-01,-1.051e-01, 3.456e-02,-3.054e-02,    
      2-9.627e-01, 5.379e-01, 3.368e-01,-9.525e-02, 1.488e-02,-2.051e-02,    
      3 4.300e-01,-8.306e-02,-3.372e-01, 4.902e-02,-9.160e-03, 1.041e-02,    
      4-1.925e-01,-1.790e-02, 2.183e-01, 7.490e-03, 4.140e-03,-1.860e-03,    
      5 8.183e-02, 1.926e-02,-1.072e-01,-1.944e-02,-2.770e-03,-5.200e-04,    
      6-3.884e-02,-1.234e-02, 5.410e-02, 1.879e-02, 3.350e-03, 1.040e-03,    
      1 2.948e+01,-3.902e+01, 1.464e+01,-3.335e+00, 5.054e-01,-5.915e-02,    
      2 2.559e+01,-3.955e+01, 1.661e+01,-4.299e+00, 6.904e-01,-8.243e-02,    
      3-1.663e+00, 1.176e+00, 1.118e+00,-7.099e-01, 1.948e-01,-2.404e-02,    
      4-2.168e-01, 8.170e-01,-7.169e-01, 1.851e-01,-1.924e-02,-3.250e-03,    
      5 2.088e-01,-4.355e-01, 2.239e-01,-2.446e-02,-3.620e-03, 1.910e-03,    
      6-9.097e-02, 1.601e-01,-5.681e-02,-2.500e-03, 2.580e-03,-4.700e-04/    
       DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/  
      1 2.367e+00, 4.453e-01, 3.660e-01, 9.467e-02, 1.341e-01, 1.661e-02,    
      2-3.170e+00,-1.795e+00, 3.313e-02,-2.874e-01,-9.827e-02,-7.119e-02,    
      3 1.823e+00, 1.457e+00,-2.465e-01, 3.739e-02, 6.090e-03, 1.814e-02,    
      4-1.033e+00,-9.827e-01, 2.136e-01, 1.169e-01, 5.001e-02, 1.684e-02,    
      5 5.133e-01, 5.259e-01,-1.173e-01,-1.139e-01,-4.988e-02,-2.021e-02,    
      6-2.881e-01,-3.145e-01, 5.667e-02, 9.161e-02, 4.568e-02, 1.951e-02,    
      1 3.036e+01,-4.062e+01, 1.578e+01,-3.699e+00, 6.020e-01,-7.031e-02,    
      2 2.700e+01,-4.167e+01, 1.770e+01,-4.804e+00, 7.862e-01,-1.060e-01,    
      3-1.909e+00, 1.357e+00, 1.127e+00,-7.181e-01, 2.232e-01,-2.481e-02,    
      4-2.488e-01, 9.781e-01,-8.127e-01, 2.094e-01,-2.997e-02,-4.710e-03,    
      5 2.506e-01,-5.427e-01, 2.672e-01,-3.103e-02,-1.800e-03, 2.870e-03,    
      6-1.128e-01, 2.087e-01,-6.972e-02,-2.480e-03, 2.630e-03,-8.400e-04/    
 C...Expansion coefficients for strange sea quark distribution.  
       DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/  
      1 4.968e-02,-4.173e-02, 2.102e-02,-3.270e-03, 3.240e-03,-6.700e-04,    
      2-6.150e-03,-1.294e-02, 6.740e-03,-6.890e-03, 9.000e-04,-1.510e-03,    
      3-8.580e-03, 5.050e-03,-4.900e-03,-1.600e-04,-9.400e-04,-1.500e-04,    
      4 7.840e-03, 1.510e-03, 2.220e-03, 1.400e-03, 7.000e-04, 3.500e-04,    
      5-4.410e-03,-2.220e-03,-8.900e-04,-8.500e-04,-3.600e-04,-2.000e-04,    
      6 2.520e-03, 1.840e-03, 4.100e-04, 3.900e-04, 1.600e-04, 9.000e-05,    
      1 9.235e-01,-1.085e+00, 3.464e-01,-7.210e-02, 9.140e-03,-9.100e-04,    
      2 9.315e-01,-1.274e+00, 4.512e-01,-9.775e-02, 1.380e-02,-1.310e-03,    
      3 4.739e-02,-1.296e-01, 8.482e-02,-2.642e-02, 4.760e-03,-5.700e-04,    
      4-2.653e-02, 4.953e-02,-1.735e-02, 1.750e-03, 2.800e-04,-6.000e-05,    
      5 6.940e-03,-1.132e-02, 1.480e-03, 6.500e-04,-2.100e-04, 0.000e+00,    
      6-1.680e-03, 2.340e-03, 4.200e-04,-3.400e-04, 5.000e-05, 1.000e-05/    
       DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/  
      1 6.478e-02,-4.537e-02, 1.643e-02,-3.490e-03, 2.710e-03,-6.700e-04,    
      2-2.223e-02,-2.126e-02, 1.247e-02,-6.290e-03, 1.120e-03,-1.440e-03,    
      3-1.340e-03, 1.362e-02,-6.130e-03,-7.900e-04,-9.000e-04,-2.000e-04,    
      4 5.080e-03,-3.610e-03, 1.700e-03, 1.830e-03, 6.800e-04, 4.000e-04,    
      5-3.580e-03, 6.000e-05,-2.600e-04,-1.050e-03,-3.800e-04,-2.300e-04,    
      6 2.420e-03, 9.300e-04,-1.000e-04, 4.500e-04, 1.700e-04, 1.100e-04,    
      1 9.868e-01,-1.171e+00, 3.940e-01,-8.459e-02, 1.124e-02,-1.250e-03,    
      2 1.001e+00,-1.383e+00, 5.044e-01,-1.152e-01, 1.658e-02,-1.830e-03,    
      3 4.928e-02,-1.368e-01, 9.021e-02,-2.935e-02, 5.800e-03,-6.600e-04,    
      4-3.133e-02, 5.785e-02,-2.023e-02, 2.630e-03, 1.600e-04,-8.000e-05,    
      5 8.840e-03,-1.416e-02, 1.900e-03, 5.800e-04,-2.500e-04, 1.000e-05,    
      6-2.300e-03, 3.080e-03, 5.500e-04,-3.700e-04, 7.000e-05, 1.000e-05/    
 C...Expansion coefficients for charm sea quark distribution.    
       DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/  
      1 9.270e-03,-1.817e-02, 9.590e-03,-6.390e-03, 1.690e-03,-1.540e-03,    
      2 5.710e-03,-1.188e-02, 6.090e-03,-4.650e-03, 1.240e-03,-1.310e-03,    
      3-3.960e-03, 7.100e-03,-3.590e-03, 1.840e-03,-3.900e-04, 3.400e-04,    
      4 1.120e-03,-1.960e-03, 1.120e-03,-4.800e-04, 1.000e-04,-4.000e-05,    
      5 4.000e-05,-3.000e-05,-1.800e-04, 9.000e-05,-5.000e-05,-2.000e-05,    
      6-4.200e-04, 7.300e-04,-1.600e-04, 5.000e-05, 5.000e-05, 5.000e-05,    
      1 8.098e-01,-1.042e+00, 3.398e-01,-6.824e-02, 8.760e-03,-9.000e-04,    
      2 8.961e-01,-1.217e+00, 4.339e-01,-9.287e-02, 1.304e-02,-1.290e-03,    
      3 3.058e-02,-1.040e-01, 7.604e-02,-2.415e-02, 4.600e-03,-5.000e-04,    
      4-2.451e-02, 4.432e-02,-1.651e-02, 1.430e-03, 1.200e-04,-1.000e-04,    
      5 1.122e-02,-1.457e-02, 2.680e-03, 5.800e-04,-1.200e-04, 3.000e-05,    
      6-7.730e-03, 7.330e-03,-7.600e-04,-2.400e-04, 1.000e-05, 0.000e+00/    
       DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/  
      1 9.980e-03,-1.945e-02, 1.055e-02,-6.870e-03, 1.860e-03,-1.560e-03,    
      2 5.700e-03,-1.203e-02, 6.250e-03,-4.860e-03, 1.310e-03,-1.370e-03,    
      3-4.490e-03, 7.990e-03,-4.170e-03, 2.050e-03,-4.400e-04, 3.300e-04,    
      4 1.470e-03,-2.480e-03, 1.460e-03,-5.700e-04, 1.200e-04,-1.000e-05,    
      5-9.000e-05, 1.500e-04,-3.200e-04, 1.200e-04,-6.000e-05,-4.000e-05,    
      6-4.200e-04, 7.600e-04,-1.400e-04, 4.000e-05, 7.000e-05, 5.000e-05,    
      1 8.698e-01,-1.131e+00, 3.836e-01,-8.111e-02, 1.048e-02,-1.300e-03,    
      2 9.626e-01,-1.321e+00, 4.854e-01,-1.091e-01, 1.583e-02,-1.700e-03,    
      3 3.057e-02,-1.088e-01, 8.022e-02,-2.676e-02, 5.590e-03,-5.600e-04,    
      4-2.845e-02, 5.164e-02,-1.918e-02, 2.210e-03,-4.000e-05,-1.500e-04,    
      5 1.311e-02,-1.751e-02, 3.310e-03, 5.100e-04,-1.200e-04, 5.000e-05,    
      6-8.590e-03, 8.380e-03,-9.200e-04,-2.600e-04, 1.000e-05,-1.000e-05/    
 C...Expansion coefficients for bottom sea quark distribution.   
       DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/  
      1 9.010e-03,-1.401e-02, 7.150e-03,-4.130e-03, 1.260e-03,-1.040e-03,    
      2 6.280e-03,-9.320e-03, 4.780e-03,-2.890e-03, 9.100e-04,-8.200e-04,    
      3-2.930e-03, 4.090e-03,-1.890e-03, 7.600e-04,-2.300e-04, 1.400e-04,    
      4 3.900e-04,-1.200e-03, 4.400e-04,-2.500e-04, 2.000e-05,-2.000e-05,    
      5 2.600e-04, 1.400e-04,-8.000e-05, 1.000e-04, 1.000e-05, 1.000e-05,    
      6-2.600e-04, 3.200e-04, 1.000e-05,-1.000e-05, 1.000e-05,-1.000e-05,    
      1 8.029e-01,-1.075e+00, 3.792e-01,-7.843e-02, 1.007e-02,-1.090e-03,    
      2 7.903e-01,-1.099e+00, 4.153e-01,-9.301e-02, 1.317e-02,-1.410e-03,    
      3-1.704e-02,-1.130e-02, 2.882e-02,-1.341e-02, 3.040e-03,-3.600e-04,    
      4-7.200e-04, 7.230e-03,-5.160e-03, 1.080e-03,-5.000e-05,-4.000e-05,    
      5 3.050e-03,-4.610e-03, 1.660e-03,-1.300e-04,-1.000e-05, 1.000e-05,    
      6-4.360e-03, 5.230e-03,-1.610e-03, 2.000e-04,-2.000e-05, 0.000e+00/    
       DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/  
      1 8.980e-03,-1.459e-02, 7.510e-03,-4.410e-03, 1.310e-03,-1.070e-03,    
      2 5.970e-03,-9.440e-03, 4.800e-03,-3.020e-03, 9.100e-04,-8.500e-04,    
      3-3.050e-03, 4.440e-03,-2.100e-03, 8.500e-04,-2.400e-04, 1.400e-04,    
      4 5.300e-04,-1.300e-03, 5.600e-04,-2.700e-04, 3.000e-05,-2.000e-05,    
      5 2.000e-04, 1.400e-04,-1.100e-04, 1.000e-04, 0.000e+00, 0.000e+00,    
      6-2.600e-04, 3.200e-04, 0.000e+00,-3.000e-05, 1.000e-05,-1.000e-05,    
      1 8.672e-01,-1.174e+00, 4.265e-01,-9.252e-02, 1.244e-02,-1.460e-03,    
      2 8.500e-01,-1.194e+00, 4.630e-01,-1.083e-01, 1.614e-02,-1.830e-03,    
      3-2.241e-02,-5.630e-03, 2.815e-02,-1.425e-02, 3.520e-03,-4.300e-04,    
      4-7.300e-04, 8.030e-03,-5.780e-03, 1.380e-03,-1.300e-04,-4.000e-05,    
      5 3.460e-03,-5.380e-03, 1.960e-03,-2.100e-04, 1.000e-05, 1.000e-05,    
      6-4.850e-03, 5.950e-03,-1.890e-03, 2.600e-04,-3.000e-05, 0.000e+00/    
 C...Expansion coefficients for top sea quark distribution.  
       DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/  
      1 4.410e-03,-7.480e-03, 3.770e-03,-2.580e-03, 7.300e-04,-7.100e-04,    
      2 3.840e-03,-6.050e-03, 3.030e-03,-2.030e-03, 5.800e-04,-5.900e-04,    
      3-8.800e-04, 1.660e-03,-7.500e-04, 4.700e-04,-1.000e-04, 1.000e-04,    
      4-8.000e-05,-1.500e-04, 1.200e-04,-9.000e-05, 3.000e-05, 0.000e+00,    
      5 1.300e-04,-2.200e-04,-2.000e-05,-2.000e-05,-2.000e-05,-2.000e-05,    
      6-7.000e-05, 1.900e-04,-4.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,    
      1 6.623e-01,-9.248e-01, 3.519e-01,-7.930e-02, 1.110e-02,-1.180e-03,    
      2 6.380e-01,-9.062e-01, 3.582e-01,-8.479e-02, 1.265e-02,-1.390e-03,    
      3-2.581e-02, 2.125e-02, 4.190e-03,-4.980e-03, 1.490e-03,-2.100e-04,    
      4 7.100e-04, 5.300e-04,-1.270e-03, 3.900e-04,-5.000e-05,-1.000e-05,    
      5 3.850e-03,-5.060e-03, 1.860e-03,-3.500e-04, 4.000e-05, 0.000e+00,    
      6-3.530e-03, 4.460e-03,-1.500e-03, 2.700e-04,-3.000e-05, 0.000e+00/    
       DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/  
      1 4.260e-03,-7.530e-03, 3.830e-03,-2.680e-03, 7.600e-04,-7.300e-04,    
      2 3.640e-03,-6.050e-03, 3.030e-03,-2.090e-03, 5.900e-04,-6.000e-04,    
      3-9.200e-04, 1.710e-03,-8.200e-04, 5.000e-04,-1.200e-04, 1.000e-04,    
      4-5.000e-05,-1.600e-04, 1.300e-04,-9.000e-05, 3.000e-05, 0.000e+00,    
      5 1.300e-04,-2.100e-04,-1.000e-05,-2.000e-05,-2.000e-05,-1.000e-05,    
      6-8.000e-05, 1.800e-04,-5.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,    
      1 7.146e-01,-1.007e+00, 3.932e-01,-9.246e-02, 1.366e-02,-1.540e-03,    
      2 6.856e-01,-9.828e-01, 3.977e-01,-9.795e-02, 1.540e-02,-1.790e-03,    
      3-3.053e-02, 2.758e-02, 2.150e-03,-4.880e-03, 1.640e-03,-2.500e-04,    
      4 9.200e-04, 4.200e-04,-1.340e-03, 4.600e-04,-8.000e-05,-1.000e-05,    
      5 4.230e-03,-5.660e-03, 2.140e-03,-4.300e-04, 6.000e-05, 0.000e+00,    
      6-3.890e-03, 5.000e-03,-1.740e-03, 3.300e-04,-4.000e-05, 0.000e+00/    
     
 C...The following data lines are coefficients needed in the 
 C...Duke, Owens proton structure function parametrizations, see below.  
 C...Expansion coefficients for (up+down) valence quark distribution.    
       DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/    
      1 4.190e-01, 3.460e+00, 4.400e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2 4.000e-03, 7.240e-01,-4.860e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      3-7.000e-03,-6.600e-02, 1.330e+00, 0.000e+00, 0.000e+00, 0.000e+00/    
       DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/    
      1 3.740e-01, 3.330e+00, 6.030e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2 1.400e-02, 7.530e-01,-6.220e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      3 0.000e+00,-7.600e-02, 1.560e+00, 0.000e+00, 0.000e+00, 0.000e+00/    
 C...Expansion coefficients for down valence quark distribution. 
       DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/    
      1 7.630e-01, 4.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2-2.370e-01, 6.270e-01,-4.210e-01, 0.000e+00, 0.000e+00, 0.000e+00,    
      3 2.600e-02,-1.900e-02, 3.300e-02, 0.000e+00, 0.000e+00, 0.000e+00/    
       DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/    
      1 7.610e-01, 3.830e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2-2.320e-01, 6.270e-01,-4.180e-01, 0.000e+00, 0.000e+00, 0.000e+00,    
      3 2.300e-02,-1.900e-02, 3.600e-02, 0.000e+00, 0.000e+00, 0.000e+00/    
 C...Expansion coefficients for (up+down+strange) sea quark distribution.    
       DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/    
      1 1.265e+00, 0.000e+00, 8.050e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2-1.132e+00,-3.720e-01, 1.590e+00, 6.310e+00,-1.050e+01, 1.470e+01,    
      3 2.930e-01,-2.900e-02,-1.530e-01,-2.730e-01,-3.170e+00, 9.800e+00/    
       DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/    
      1 1.670e+00, 0.000e+00, 9.150e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2-1.920e+00,-2.730e-01, 5.300e-01, 1.570e+01,-1.010e+02, 2.230e+02,    
      3 5.820e-01,-1.640e-01,-7.630e-01,-2.830e+00, 4.470e+01,-1.170e+02/    
 C...Expansion coefficients for charm sea quark distribution.    
       DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/    
      1 0.000e+00,-3.600e-02, 6.350e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2 1.350e-01,-2.220e-01, 3.260e+00,-3.030e+00, 1.740e+01,-1.790e+01,    
      3-7.500e-02,-5.800e-02,-9.090e-01, 1.500e+00,-1.130e+01, 1.560e+01/    
        DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/   
      1 0.000e+00,-1.200e-01, 3.510e+00, 0.000e+00, 0.000e+00, 0.000e+00,    
      2 6.700e-02,-2.330e-01, 3.660e+00,-4.740e-01, 9.500e+00,-1.660e+01,    
      3-3.100e-02,-2.300e-02,-4.530e-01, 3.580e-01,-5.430e+00, 1.550e+01/    
 C...Expansion coefficients for gluon distribution.  
       DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/    
      1 1.560e+00, 0.000e+00, 6.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,    
      2-1.710e+00,-9.490e-01, 1.440e+00,-7.190e+00,-1.650e+01, 1.530e+01,    
      3 6.380e-01, 3.250e-01,-1.050e+00, 2.550e-01, 1.090e+01,-1.010e+01/    
       DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/    
      1 8.790e-01, 0.000e+00, 4.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,    
      2-9.710e-01,-1.160e+00, 1.230e+00,-5.640e+00,-7.540e+00,-5.960e-01,    
      3 4.340e-01, 4.760e-01,-2.540e-01,-8.170e-01, 5.500e+00, 1.260e-01/    
     
 C...The following data lines are coefficients needed in the 
 C...Owens pion structure function parametrizations, see below.  
 C...Expansion coefficients for up and down valence quark distributions. 
       DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/    
      1  4.0000e-01,  7.0000e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
      2 -6.2120e-02,  6.4780e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
      3 -7.1090e-03,  1.3350e-02,  0.0000e+00,  0.0000e+00,  0.0000e+00/ 
       DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/    
      1  4.0000e-01,  6.2800e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
      2 -5.9090e-02,  6.4360e-01,  0.0000e+00,  0.0000e+00,  0.0000e+00, 
      3 -6.5240e-03,  1.4510e-02,  0.0000e+00,  0.0000e+00,  0.0000e+00/ 
 C...Expansion coefficients for gluon distribution.  
       DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/    
      1  8.8800e-01,  0.0000e+00,  3.1100e+00,  6.0000e+00,  0.0000e+00, 
      2 -1.8020e+00, -1.5760e+00, -1.3170e-01,  2.8010e+00, -1.7280e+01, 
      3  1.8120e+00,  1.2000e+00,  5.0680e-01, -1.2160e+01,  2.0490e+01/ 
       DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/    
      1  7.9400e-01,  0.0000e+00,  2.8900e+00,  6.0000e+00,  0.0000e+00, 
      2 -9.1440e-01, -1.2370e+00,  5.9660e-01, -3.6710e+00, -8.1910e+00, 
      3  5.9660e-01,  6.5820e-01, -2.5500e-01, -2.3040e+00,  7.7580e+00/ 
 C...Expansion coefficients for (up+down+strange) quark sea distribution.    
       DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/    
      1  9.0000e-01,  0.0000e+00,  5.0000e+00,  0.0000e+00,  0.0000e+00, 
      2 -2.4280e-01, -2.1200e-01,  8.6730e-01,  1.2660e+00,  2.3820e+00, 
      3  1.3860e-01,  3.6710e-03,  4.7470e-02, -2.2150e+00,  3.4820e-01/ 
       DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/    
      1  9.0000e-01,  0.0000e+00,  5.0000e+00,  0.0000e+00,  0.0000e+00, 
      2 -1.4170e-01, -1.6970e-01, -2.4740e+00, -2.5340e+00,  5.6210e-01, 
      3 -1.7400e-01, -9.6230e-02,  1.5750e+00,  1.3780e+00, -2.7010e-01/ 
 C...Expansion coefficients for charm quark sea distribution.    
       DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/    
      1  0.0000e+00, -2.2120e-02,  2.8940e+00,  0.0000e+00,  0.0000e+00, 
      2  7.9280e-02, -3.7850e-01,  9.4330e+00,  5.2480e+00,  8.3880e+00, 
      3 -6.1340e-02, -1.0880e-01, -1.0852e+01, -7.1870e+00, -1.1610e+01/ 
       DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/    
      1  0.0000e+00, -8.8200e-02,  1.9240e+00,  0.0000e+00,  0.0000e+00, 
      2  6.2290e-02, -2.8920e-01,  2.4240e-01, -4.4630e+00, -8.3670e-01, 
      3 -4.0990e-02, -1.0820e-01,  2.0360e+00,  5.2090e+00, -4.8400e-02/ 
     
 C...Euler's beta function, requires ordinary Gamma function 
       eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)   
     
 C...Reset structure functions, check x and hadron flavour.  
       alam=0.   
       DO 100 kfl=-6,6   
   100 xpq(kfl)=0.   
       IF(x.LT.0..OR.x.GT.1.) THEN   
         WRITE(mstu(11),1000) x  
         RETURN  
       ENDIF 
       kfa=iabs(kf)  
       IF(kfa.NE.211.AND.kfa.NE.2212.AND.kfa.NE.2112) THEN   
         WRITE(mstu(11),1100) kf 
         RETURN  
       ENDIF 
     
 C...Call user-supplied structure function. Select proton/neutron/pion.  
       IF(mstp(51).EQ.0.OR.mstp(52).GE.2) THEN   
         kfe=kfa 
         IF(kfa.EQ.2112) kfe=2212    
         CALL pystfe(kfe,x,q2,xpq)   
         GOTO 230    
       ENDIF 
       IF(kfa.EQ.211) GOTO 200   
     
       IF(mstp(51).EQ.1.OR.mstp(51).EQ.2) THEN   
 C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.   
 C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1    
     
 C...Determine set, Lamdba and x and t expansion variables.  
         nset=mstp(51)   
         IF(nset.EQ.1) alam=0.2  
         IF(nset.EQ.2) alam=0.29 
         tmin=log(5./alam**2)    
         tmax=log(1e8/alam**2)   
         IF(mstp(52).EQ.0) THEN  
           t=tmin    
         ELSE    
           t=log(q2/alam**2) 
         ENDIF   
         vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))    
         nx=1    
         IF(x.LE.0.1) nx=2   
         IF(nx.EQ.1) vx=(2.*x-1.1)/0.9   
         IF(nx.EQ.2) vx=max(-1.,(2.*log(x)+11.51293)/6.90776)    
         cxs=1.  
         IF(x.LT.1e-4.AND.abs(parp(51)-1.).GT.0.01) cxs= 
      &  (1e-4/x)**(parp(51)-1.) 
     
 C...Chebyshev polynomials for x and t expansion.    
         tx(1)=1.    
         tx(2)=vx    
         tx(3)=2.*vx**2-1.   
         tx(4)=4.*vx**3-3.*vx    
         tx(5)=8.*vx**4-8.*vx**2+1.  
         tx(6)=16.*vx**5-20.*vx**3+5.*vx 
         tt(1)=1.    
         tt(2)=vt    
         tt(3)=2.*vt**2-1.   
         tt(4)=4.*vt**3-3.*vt    
         tt(5)=8.*vt**4-8.*vt**2+1.  
         tt(6)=16.*vt**5-20.*vt**3+5.*vt 
     
 C...Calculate structure functions.  
         DO 120 kfl=1,6  
         xqsum=0.    
         DO 110 it=1,6   
         DO 110 ix=1,6   
   110   xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)  
   120   xq(kfl)=xqsum*(1.-x)**nehlq(kfl,nset)*cxs   
     
 C...Put into output array.  
         xpq(0)=xq(4)    
         xpq(1)=xq(2)+xq(3)  
         xpq(2)=xq(1)+xq(3)  
         xpq(3)=xq(5)    
         xpq(4)=xq(6)    
         xpq(-1)=xq(3)   
         xpq(-2)=xq(3)   
         xpq(-3)=xq(5)   
         xpq(-4)=xq(6)   
     
 C...Special expansion for bottom (threshold effects).   
         IF(mstp(54).GE.5) THEN  
           IF(nset.EQ.1) tmin=8.1905 
           IF(nset.EQ.2) tmin=7.4474 
           IF(t.LE.tmin) GOTO 140    
           vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))  
           tt(1)=1.  
           tt(2)=vt  
           tt(3)=2.*vt**2-1. 
           tt(4)=4.*vt**3-3.*vt  
           tt(5)=8.*vt**4-8.*vt**2+1.    
           tt(6)=16.*vt**5-20.*vt**3+5.*vt   
           xqsum=0.  
           DO 130 it=1,6 
           DO 130 ix=1,6 
   130     xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)  
           xpq(5)=xqsum*(1.-x)**nehlq(7,nset)    
           xpq(-5)=xpq(5)    
   140     CONTINUE  
         ENDIF   
     
 C...Special expansion for top (threshold effects).  
         IF(mstp(54).GE.6) THEN  
           IF(nset.EQ.1) tmin=11.5528    
           IF(nset.EQ.2) tmin=10.8097    
           tmin=tmin+2.*log(pmas(6,1)/30.)   
           tmax=tmax+2.*log(pmas(6,1)/30.)   
           IF(t.LE.tmin) GOTO 160    
           vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))  
           tt(1)=1.  
           tt(2)=vt  
           tt(3)=2.*vt**2-1. 
           tt(4)=4.*vt**3-3.*vt  
           tt(5)=8.*vt**4-8.*vt**2+1.    
           tt(6)=16.*vt**5-20.*vt**3+5.*vt   
           xqsum=0.  
           DO 150 it=1,6 
           DO 150 ix=1,6 
   150     xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)  
           xpq(6)=xqsum*(1.-x)**nehlq(8,nset)    
           xpq(-6)=xpq(6)    
   160     CONTINUE  
         ENDIF   
     
       ELSEIF(mstp(51).EQ.3.OR.mstp(51).EQ.4) THEN   
 C...Proton structure functions from Duke, Owens.    
 C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.  
     
 C...Determine set, Lambda and s expansion parameter.    
         nset=mstp(51)-2 
         IF(nset.EQ.1) alam=0.2  
         IF(nset.EQ.2) alam=0.4  
         IF(mstp(52).LE.0) THEN  
           sd=0. 
         ELSE    
           sd=log(log(max(q2,4.)/alam**2)/log(4./alam**2))   
         ENDIF   
     
 C...Calculate structure functions.  
         DO 180 kfl=1,5  
         DO 170 is=1,6   
   170   ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+    
      &  cdo(3,is,kfl,nset)*sd**2    
         IF(kfl.LE.2) THEN   
           xq(kfl)=x**ts(1)*(1.-x)**ts(2)*(1.+ts(3)*x)/(eulbet(ts(1),    
      &    ts(2)+1.)*(1.+ts(3)*ts(1)/(ts(1)+ts(2)+1.)))  
         ELSE    
           xq(kfl)=ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2+  
      &    ts(6)*x**3)   
         ENDIF   
   180   CONTINUE    
     
 C...Put into output arrays. 
         xpq(0)=xq(5)    
         xpq(1)=xq(2)+xq(3)/6.   
         xpq(2)=3.*xq(1)-xq(2)+xq(3)/6.  
         xpq(3)=xq(3)/6. 
         xpq(4)=xq(4)    
         xpq(-1)=xq(3)/6.    
         xpq(-2)=xq(3)/6.    
         xpq(-3)=xq(3)/6.    
         xpq(-4)=xq(4)   
     
 C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli. 
 C...These are accessed via PYSTFE since the files needed may not always 
 C...available.  
       ELSEIF(mstp(51).GE.11.AND.mstp(51).LE.13) THEN    
         CALL pystfe(2212,x,q2,xpq)  
     
 C...Unknown proton parametrization. 
       ELSE  
         WRITE(mstu(11),1200) mstp(51)   
       ENDIF 
       GOTO 230  
     
   200 IF((mstp(51).GE.1.AND.mstp(51).LE.4).OR.  
      &(mstp(51).GE.11.AND.mstp(51).LE.13)) THEN 
 C...Pion structure functions from Owens.    
 C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2. 
     
 C...Determine set, Lambda and s expansion variable. 
         nset=1  
         IF(mstp(51).EQ.2.OR.mstp(51).EQ.4.OR.mstp(51).EQ.13) nset=2 
         IF(nset.EQ.1) alam=0.2  
         IF(nset.EQ.2) alam=0.4  
         IF(mstp(52).LE.0) THEN  
           sd=0. 
         ELSE    
           sd=log(log(max(q2,4.)/alam**2)/log(4./alam**2))   
         ENDIF   
     
 C...Calculate structure functions.  
         DO 220 kfl=1,4  
         DO 210 is=1,5   
   210   ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+    
      &  cow(3,is,kfl,nset)*sd**2    
         IF(kfl.EQ.1) THEN   
           xq(kfl)=x**ts(1)*(1.-x)**ts(2)/eulbet(ts(1),ts(2)+1.) 
         ELSE    
           xq(kfl)=ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**2)  
         ENDIF   
   220   CONTINUE    
     
 C...Put into output arrays. 
         xpq(0)=xq(2)    
         xpq(1)=xq(3)/6. 
         xpq(2)=xq(1)+xq(3)/6.   
         xpq(3)=xq(3)/6. 
         xpq(4)=xq(4)    
         xpq(-1)=xq(1)+xq(3)/6.  
         xpq(-2)=xq(3)/6.    
         xpq(-3)=xq(3)/6.    
         xpq(-4)=xq(4)   
     
 C...Unknown pion parametrization.   
       ELSE  
         WRITE(mstu(11),1200) mstp(51)   
       ENDIF 
     
 C...Isospin conjugation for neutron, charge conjugation for antipart.   
   230 IF(kfa.EQ.2112) THEN  
         xps=xpq(1)  
         xpq(1)=xpq(2)   
         xpq(2)=xps  
         xps=xpq(-1) 
         xpq(-1)=xpq(-2) 
         xpq(-2)=xps 
       ENDIF 
       IF(kf.LT.0) THEN  
         DO 240 kfl=1,4  
         xps=xpq(kfl)    
         xpq(kfl)=xpq(-kfl)  
   240   xpq(-kfl)=xps   
       ENDIF 
     
 C...Check positivity and reset above maximum allowed flavour.   
       DO 250 kfl=-6,6   
       xpq(kfl)=max(0.,xpq(kfl)) 
   250 IF(iabs(kfl).GT.mstp(54)) xpq(kfl)=0. 
 
 C...consider nuclear effect on the structure function
         IF((jbt.NE.1.AND.jbt.NE.2).OR.ihpr2(6).EQ.0
      &                  .OR.ihnt2(16).EQ.1) GO TO 400
         atnm=ihnt2(2*jbt-1)
         IF(atnm.LE.1.0) GO TO 400
         IF(jbt.EQ.1) THEN
       bbr2=(yp(1,ihnt2(11))**2+yp(2,ihnt2(11))**2)/1.44/atnm**0.66666
         ELSEIF(jbt.EQ.2) THEN
       bbr2=(yt(1,ihnt2(12))**2+yt(2,ihnt2(12))**2)/1.44/atnm**0.66666
         ENDIF
         bbr2=min(1.0,bbr2)
     abx=(atnm**0.33333333-1.0)
         apx=hipr1(6)*4.0/3.0*abx*sqrt(1.0-bbr2)
         aax=1.192*alog(atnm)**0.1666666
         rrx=aax*(x**3-1.2*x**2+0.21*x)+1.0
      &      -(apx-1.079*abx*sqrt(x)/alog(atnm+1.0))*exp(-x**2.0/0.01)
         DO 300 kfl=-6,6
         xpq(kfl)=xpq(kfl)*rrx
 300     CONTINUE
 C           ********consider the nuclear effect on the structure
 C               fucntion which also depends on the impact
 C               parameter of the nuclear reaction
 
 400     CONTINUE    
 C...Formats for error printouts.    
  1000 FORMAT(' Error: x value outside physical range, x =',1p,e12.3)    
  1100 FORMAT(' Error: illegal particle code for structure function,',   
      &' KF =',i5)   
  1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',  
      &' MSTP(51) =',i5) 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pytest()

subroutine pytest ( MTEST )

Definition at line 19030 of file hipyset1.35.f.

     
 C...Purpose: to provide a simple program (disguised as a subroutine) to 
 C...run at installation as a check that the program works as intended.  
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
     
 C...Common initial values. Loop over initiating conditions. 
       mstp(122)=1   
       IF(mtest.LE.0) mstp(122)=0    
       mdcy(lucomp(111),1)=0 
       nerr=0    
       DO 130 iproc=1,7  
     
 C...Reset process type, kinematics cuts, and the flags used.    
       msel=0    
       DO 100 isub=1,200 
   100 msub(isub)=0  
       ckin(1)=2.    
       ckin(3)=0.    
       mstp(2)=1 
       mstp(33)=0    
       mstp(81)=1    
       mstp(82)=1    
       mstp(111)=1   
       mstp(131)=0   
       mstp(133)=0   
       parp(131)=0.01    
     
 C...Prompt photon production at fixed target.   
       IF(iproc.EQ.1) THEN   
         pzsum=300.  
         pesum=sqrt(pzsum**2+ulmass(211)**2)+ulmass(2212)    
         pqsum=2.    
         msel=10 
         ckin(3)=5.  
         CALL pyinit('FIXT','pi+','p',pzsum) 
     
 C...QCD processes at ISR energies.  
       ELSEIF(iproc.EQ.2) THEN   
         pesum=63.   
         pzsum=0.    
         pqsum=2.    
         msel=1  
         ckin(3)=5.  
         CALL pyinit('CMS','p','p',pesum)    
     
 C...W production + multiple interactions at CERN Collider.  
       ELSEIF(iproc.EQ.3) THEN   
         pesum=630.  
         pzsum=0.    
         pqsum=0.    
         msel=12 
         ckin(1)=20. 
         mstp(82)=4  
         mstp(2)=2   
         mstp(33)=3  
         CALL pyinit('CMS','p','pbar',pesum) 
     
 C...W/Z gauge boson pairs + overlayed events at the Tevatron.   
       ELSEIF(iproc.EQ.4) THEN   
         pesum=1800. 
         pzsum=0.    
         pqsum=0.    
         msub(22)=1  
         msub(23)=1  
         msub(25)=1  
         ckin(1)=200.    
         mstp(111)=0 
         mstp(131)=1 
         mstp(133)=2 
         parp(131)=0.04  
         CALL pyinit('CMS','p','pbar',pesum) 
     
 C...Higgs production at LHC.    
       ELSEIF(iproc.EQ.5) THEN   
         pesum=17000.    
         pzsum=0.    
         pqsum=0.    
         msel=16 
         pmas(25,1)=300. 
         ckin(1)=200.    
         mstp(81)=0  
         mstp(111)=0 
         CALL pyinit('CMS','p','pbar',pesum) 
     
 C...Z' production at SSC.   
       ELSEIF(iproc.EQ.6) THEN   
         pesum=40000.    
         pzsum=0.    
         pqsum=0.    
         msel=21 
         pmas(32,1)=600. 
         ckin(1)=400.    
         mstp(81)=0  
         mstp(111)=0 
         CALL pyinit('CMS','p','pbar',pesum) 
     
 C...W pair production at 1 TeV e+e- collider.   
       ELSEIF(iproc.EQ.7) THEN   
         pesum=1000. 
         pzsum=0.    
         pqsum=0.    
         msub(25)=1  
         CALL pyinit('CMS','e+','e-',pesum)  
       ENDIF 
     
 C...Generate 20 events of each required type.   
       DO 120 iev=1,20   
       CALL pythia   
       pesumm=pesum  
       IF(iproc.EQ.4) pesumm=msti(41)*pesum  
     
 C...Check conservation of energy/momentum/flavour.  
       merr=0    
       deve=abs(plu(0,4)-pesumm)+abs(plu(0,3)-pzsum) 
       devt=abs(plu(0,1))+abs(plu(0,2))  
       devq=abs(plu(0,6)-pqsum)  
       IF(deve.GT.1e-3*pesum.OR.devt.GT.max(0.01,1e-5*pesum).OR. 
      &devq.GT.0.1) merr=1   
       IF(merr.NE.0) WRITE(mstu(11),1000) iproc,iev  
     
 C...Check that all KF codes are known ones, and that partons/particles  
 C...satisfy energy-momentum-mass relation.  
       DO 110 i=1,n  
       IF(k(i,1).GT.20) GOTO 110 
       IF(lucomp(k(i,2)).EQ.0) THEN  
         WRITE(mstu(11),1100) i  
         merr=merr+1 
       ENDIF 
       pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2* 
      &sign(1.,p(i,5))   
       IF(abs(pd).GT.max(0.1,0.002*p(i,4)**2,0.002*p(i,5)**2).OR.    
      &(p(i,5).GE.0..AND.p(i,4).LT.0.)) THEN 
         WRITE(mstu(11),1200) i  
         merr=merr+1 
       ENDIF 
   110 CONTINUE  
     
 C...Listing of erronoeus events, and first event of each type.  
       IF(merr.GE.1) nerr=nerr+1 
       IF(nerr.GE.10) THEN   
         WRITE(mstu(11),1300)    
         CALL lulist(1)  
         stop    
       ENDIF 
       IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN   
         IF(merr.GE.1) WRITE(mstu(11),1400)  
         CALL lulist(1)  
       ENDIF 
   120 CONTINUE  
     
 C...List statistics for each process type.  
       IF(mtest.GE.1) CALL pystat(1) 
   130 CONTINUE  
     
 C...Summarize result of run.    
       IF(nerr.EQ.0) WRITE(mstu(11),1500)    
       IF(nerr.GT.0) WRITE(mstu(11),1600) nerr   
       RETURN    
     
 C...Formats for information.    
  1000 FORMAT(/5x,'Energy/momentum/flavour nonconservation for process', 
      &i2,', event',i4)  
  1100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')   
  1200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',  
      &'kinematics') 
  1300 FORMAT(/5x,'This is the tenth error experienced! Something is ',  
      &'wrong.'/5x,'Execution will be stopped after listing of event.')  
  1400 FORMAT(5x,'Faulty event follows:')    
  1500 FORMAT(//5x,'End result of run: no errors detected.') 
  1600 FORMAT(//5x,'End result of run:',i2,' errors detected.'/  
      &5x,'This should not have happened!')  

Here is the call graph for this function:

◆ pythia()

subroutine pythia ( )

Definition at line 10307 of file hipyset1.35.f.

     
 C...Administers the generation of a high-pt event via calls to a number 
 C...of subroutines; also computes cross-sections.   
       common/lujets/n,k(9000,5),p(9000,5),v(9000,5)
       SAVE /lujets/ 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200) 
       SAVE /pysubs/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2) 
       SAVE /pyint2/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
     
 C...Loop over desired number of overlayed events (normally 1).  
       mint(7)=0 
       mint(8)=0 
       novl=1    
       IF(mstp(131).NE.0) CALL pyovly(2) 
       IF(mstp(131).NE.0) novl=mint(81)  
       mint(83)=0    
       mint(84)=mstp(126)    
       mstu(70)=0    
       DO 190 iovl=1,novl    
       IF(mint(84)+100.GE.mstu(4)) THEN  
         CALL luerrm(11, 
      &  '(PYTHIA:) no more space in LUJETS for overlayed events')   
         IF(mstu(21).GE.1) GOTO 200  
       ENDIF 
       mint(82)=iovl 
     
 C...Generate variables of hard scattering.  
   100 CONTINUE  
       IF(iovl.EQ.1) ngen(0,2)=ngen(0,2)+1   
       mint(31)=0    
       mint(51)=0    
       CALL pyrand   
       isub=mint(1)  
       IF(iovl.EQ.1) THEN    
         ngen(isub,2)=ngen(isub,2)+1 
     
 C...Store information on hard interaction.  
         DO 110 j=1,200  
         msti(j)=0   
   110   pari(j)=0.  
         msti(1)=mint(1) 
         msti(2)=mint(2) 
         msti(11)=mint(11)   
         msti(12)=mint(12)   
         msti(15)=mint(15)   
         msti(16)=mint(16)   
         msti(17)=mint(17)   
         msti(18)=mint(18)   
         pari(11)=vint(1)    
         pari(12)=vint(2)    
         IF(isub.NE.95) THEN 
           DO 120 j=13,22    
   120     pari(j)=vint(30+j)    
           pari(33)=vint(41) 
           pari(34)=vint(42) 
           pari(35)=pari(33)-pari(34)    
           pari(36)=vint(21) 
           pari(37)=vint(22) 
           pari(38)=vint(26) 
           pari(41)=vint(23) 
         ENDIF   
       ENDIF 
     
       IF(mstp(111).EQ.-1) GOTO 160  
       IF(isub.LE.90.OR.isub.GE.95) THEN 
 C...Hard scattering (including low-pT): 
 C...reconstruct kinematics and colour flow of hard scattering.  
         CALL pyscat 
         IF(mint(51).EQ.1) GOTO 100  
     
 C...Showering of initial state partons (optional).  
         ipu1=mint(84)+1 
         ipu2=mint(84)+2 
         IF(mstp(61).GE.1.AND.mint(43).NE.1.AND.isub.NE.95)  
      &  CALL pysspa(ipu1,ipu2)  
         nsav1=n 
     
 C...Multiple interactions.  
         IF(mstp(81).GE.1.AND.mint(43).EQ.4.AND.isub.NE.95)  
      &  CALL pymult(6)  
         mint(1)=isub    
         nsav2=n 
     
 C...Hadron remnants and primordial kT.  
         CALL pyremn(ipu1,ipu2)  
         IF(mint(51).EQ.1) GOTO 100  
         nsav3=n 
     
 C...Showering of final state partons (optional).    
         ipu3=mint(84)+3 
         ipu4=mint(84)+4 
         IF(mstp(71).GE.1.AND.isub.NE.95.AND.k(ipu3,1).GT.0.AND. 
      &  k(ipu3,1).LE.10.AND.k(ipu4,1).GT.0.AND.k(ipu4,1).LE.10) THEN    
           qmax=sqrt(parp(71)*vint(52))  
           IF(isub.EQ.5) qmax=sqrt(pmas(23,1)**2)    
           IF(isub.EQ.8) qmax=sqrt(pmas(24,1)**2)    
           CALL lushow(ipu3,ipu4,qmax)   
         ENDIF   
     
 C...Sum up transverse and longitudinal momenta. 
         IF(iovl.EQ.1) THEN  
           pari(65)=2.*pari(17)  
           DO 130 i=mstp(126)+1,n    
           IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 130  
           pt=sqrt(p(i,1)**2+p(i,2)**2)  
           pari(69)=pari(69)+pt  
           IF(i.LE.nsav1.OR.i.GT.nsav3) pari(66)=pari(66)+pt 
           IF(i.GT.nsav1.AND.i.LE.nsav2) pari(68)=pari(68)+pt    
   130     CONTINUE  
           pari(67)=pari(68) 
           pari(71)=vint(151)    
           pari(72)=vint(152)    
           pari(73)=vint(151)    
           pari(74)=vint(152)    
         ENDIF   
     
 C...Decay of final state resonances.    
         IF(mstp(41).GE.1.AND.isub.NE.95) CALL pyresd    
     
       ELSE  
 C...Diffractive and elastic scattering. 
         CALL pydiff 
         IF(iovl.EQ.1) THEN  
           pari(65)=2.*pari(17)  
           pari(66)=pari(65) 
           pari(69)=pari(65) 
         ENDIF   
       ENDIF 
     
 C...Recalculate energies from momenta and masses (if desired).  
       IF(mstp(113).GE.1) THEN   
         DO 140 i=mint(83)+1,n   
   140   IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+ 
      &  p(i,2)**2+p(i,3)**2+p(i,5)**2)  
       ENDIF 
     
 C...Rearrange partons along strings, check invariant mass cuts. 
       mstu(28)=0    
       CALL luprep(mint(84)+1)   
       IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) GOTO 100 
       IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN 
         DO 150 i=mint(84)+1,n   
         IF(k(i,2).NE.94) GOTO 150   
         k(i+1,3)=mod(k(i+1,4)/mstu(5),mstu(5))  
         k(i+2,3)=mod(k(i+2,4)/mstu(5),mstu(5))  
   150   CONTINUE    
         CALL luedit(12) 
         CALL luedit(14) 
         IF(mstp(125).EQ.0) CALL luedit(15)  
         IF(mstp(125).EQ.0) mint(4)=0    
       ENDIF 
     
 C...Introduce separators between sections in LULIST event listing.  
       IF(iovl.EQ.1.AND.mstp(125).LE.0) THEN 
         mstu(70)=1  
         mstu(71)=n  
       ELSEIF(iovl.EQ.1) THEN    
         mstu(70)=3  
         mstu(71)=2  
         mstu(72)=mint(4)    
         mstu(73)=n  
       ENDIF 
     
 C...Perform hadronization (if desired). 
       IF(mstp(111).GE.1) CALL luexec    
       IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL luedit(14)  
     
 C...Calculate Monte Carlo estimates of cross-sections.  
   160 IF(iovl.EQ.1) THEN    
         IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1 
         ngen(0,3)=ngen(0,3)+1   
         xsec(0,3)=0.    
         DO 170 i=1,200  
         IF(i.EQ.96) THEN    
           xsec(i,3)=0.  
         ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR. 
      &  i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN    
           xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1.,float(ngen(96,1))*  
      &    float(ngen(96,2)))    
         ELSEIF(ngen(i,1).EQ.0) THEN 
           xsec(i,3)=0.  
         ELSEIF(ngen(i,2).EQ.0) THEN 
           xsec(i,3)=xsec(i,2)*ngen(0,3)/(float(ngen(i,1))*  
      &    float(ngen(0,2))) 
         ELSE    
           xsec(i,3)=xsec(i,2)*ngen(i,3)/(float(ngen(i,1))*  
      &    float(ngen(i,2))) 
         ENDIF   
   170   xsec(0,3)=xsec(0,3)+xsec(i,3)   
         IF(msub(95).EQ.1) THEN  
           ngens=ngen(91,3)+ngen(92,3)+ngen(93,3)+ngen(94,3)+ngen(95,3)  
           xsecs=xsec(91,3)+xsec(92,3)+xsec(93,3)+xsec(94,3)+xsec(95,3)  
           xmaxs=xsec(95,1)  
           IF(msub(91).EQ.1) xmaxs=xmaxs+xsec(91,1)  
           IF(msub(92).EQ.1) xmaxs=xmaxs+xsec(92,1)  
           IF(msub(93).EQ.1) xmaxs=xmaxs+xsec(93,1)  
           IF(msub(94).EQ.1) xmaxs=xmaxs+xsec(94,1)  
           fac=1.    
           IF(ngens.LT.ngen(0,3)) fac=(xmaxs-xsecs)/(xsec(0,3)-xsecs)    
           xsec(11,3)=fac*xsec(11,3) 
           xsec(12,3)=fac*xsec(12,3) 
           xsec(13,3)=fac*xsec(13,3) 
           xsec(28,3)=fac*xsec(28,3) 
           xsec(53,3)=fac*xsec(53,3) 
           xsec(68,3)=fac*xsec(68,3) 
           xsec(0,3)=xsec(91,3)+xsec(92,3)+xsec(93,3)+xsec(94,3)+    
      &    xsec(95,1)    
         ENDIF   
     
 C...Store final information.    
         mint(5)=mint(5)+1   
         msti(3)=mint(3) 
         msti(4)=mint(4) 
         msti(5)=mint(5) 
         msti(6)=mint(6) 
         msti(7)=mint(7) 
         msti(8)=mint(8) 
         msti(13)=mint(13)   
         msti(14)=mint(14)   
         msti(21)=mint(21)   
         msti(22)=mint(22)   
         msti(23)=mint(23)   
         msti(24)=mint(24)   
         msti(25)=mint(25)   
         msti(26)=mint(26)   
         msti(31)=mint(31)   
         pari(1)=xsec(0,3)   
         pari(2)=xsec(0,3)/mint(5)   
         pari(31)=vint(141)  
         pari(32)=vint(142)  
         IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN    
           pari(42)=2.*vint(47)/vint(1)  
           DO 180 is=7,8 
           pari(36+is)=p(mint(is),3)/vint(1) 
           pari(38+is)=p(mint(is),4)/vint(1) 
           i=mint(is)    
           pr=max(1e-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)   
           pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/    
      &    sqrt(pr),1e20)),p(i,3))   
           pr=max(1e-20,p(i,1)**2+p(i,2)**2) 
           pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/    
      &    sqrt(pr),1e20)),p(i,3))   
           pari(44+is)=p(i,3)/sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)    
           pari(46+is)=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))  
           pari(48+is)=ulangl(p(i,1),p(i,2)) 
   180     CONTINUE  
         ENDIF   
         pari(61)=vint(148)  
         IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN 
           mstu(161)=mint(21)    
           mstu(162)=0   
         ELSE    
           mstu(161)=mint(21)    
           mstu(162)=mint(22)    
         ENDIF   
       ENDIF 
     
 C...Prepare to go to next overlayed event.  
       msti(41)=iovl 
       IF(iovl.GE.2.AND.iovl.LE.10) msti(40+iovl)=isub   
       IF(mstu(70).LT.10) THEN   
         mstu(70)=mstu(70)+1 
         mstu(70+mstu(70))=n 
       ENDIF 
       mint(83)=n    
       mint(84)=n+mstp(126)  
   190 CONTINUE  
     
 C...Information on overlayed events.    
       IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN    
         pari(91)=vint(132)  
         pari(92)=vint(133)  
         pari(93)=vint(134)  
         IF(mstp(133).EQ.2) pari(93)=pari(93)*xsec(0,3)/vint(131)    
       ENDIF 
     
 C...Transform to the desired coordinate frame.  
   200 CALL pyfram(mstp(124))    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyw1au()

function pyw1au	(	EPS,
		IREIM
	)

Definition at line 18839 of file hipyset1.35.f.

     
 C...Calculates real and imaginary parts of the auxiliary function W1;   
 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
     
       asinh(x)=log(x+sqrt(x**2+1.)) 
       acosh(x)=log(x+sqrt(x**2-1.)) 
     
       IF(eps.LT.0.) THEN    
         w1re=2.*sqrt(1.-eps)*asinh(sqrt(-1./eps))   
         w1im=0. 
       ELSEIF(eps.LT.1.) THEN    
         w1re=2.*sqrt(1.-eps)*acosh(sqrt(1./eps))    
         w1im=-paru(1)*sqrt(1.-eps)  
       ELSE  
         w1re=2.*sqrt(eps-1.)*asin(sqrt(1./eps)) 
         w1im=0. 
       ENDIF 
     
       IF(ireim.EQ.1) pyw1au=w1re    
       IF(ireim.EQ.2) pyw1au=w1im    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyw2au()

function pyw2au	(	EPS,
		IREIM
	)

Definition at line 18869 of file hipyset1.35.f.

     
 C...Calculates real and imaginary parts of the auxiliary function W2;   
 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,   
 C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
     
       asinh(x)=log(x+sqrt(x**2+1.)) 
       acosh(x)=log(x+sqrt(x**2-1.)) 
     
       IF(eps.LT.0.) THEN    
         w2re=4.*(asinh(sqrt(-1./eps)))**2   
         w2im=0. 
       ELSEIF(eps.LT.1.) THEN    
         w2re=4.*(acosh(sqrt(1./eps)))**2-paru(1)**2 
         w2im=-4.*paru(1)*acosh(sqrt(1./eps))    
       ELSE  
         w2re=-4.*(asin(sqrt(1./eps)))**2    
         w2im=0. 
       ENDIF 
     
       IF(ireim.EQ.1) pyw2au=w2re    
       IF(ireim.EQ.2) pyw2au=w2im    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pywidt()

subroutine pywidt	(		KFLR,
			RMAS,
		dimension(0:40)	WDTP,
		dimension(0:40,0:5)	WDTE
	)

Definition at line 15129 of file hipyset1.35.f.

     
 C...Calculates full and partial widths of resonances.   
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
       common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)    
       SAVE /ludat3/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3) 
       SAVE /pyint4/ 
       dimension wdtp(0:40),wdte(0:40,0:5)   
     
 C...Some common constants.  
       kfla=iabs(kflr)   
       sqm=rmas**2   
       as=ulalps(sqm)    
       aem=paru(101) 
       xw=paru(102)  
       radc=1.+as/paru(1)    
     
 C...Reset width information.    
       DO 100 i=0,40 
       wdtp(i)=0.    
       DO 100 j=0,5  
   100 wdte(i,j)=0.  
     
       IF(kfla.EQ.21) THEN   
 C...QCD:    
         DO 110 i=1,mdcy(21,3)   
         idc=i+mdcy(21,2)-1  
         rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
         rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
         IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 110  
         IF(i.LE.8) THEN 
 C...QCD -> q + qb   
           wdtp(i)=(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
           wid2=1.   
         ENDIF   
         wdtp(0)=wdtp(0)+wdtp(i) 
         IF(mdme(idc,1).GT.0) THEN   
           wdte(i,mdme(idc,1))=wdtp(i)*wid2  
           wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
           wdte(i,0)=wdte(i,mdme(idc,1)) 
           wdte(0,0)=wdte(0,0)+wdte(i,0) 
         ENDIF   
   110   CONTINUE    
     
       ELSEIF(kfla.EQ.23) THEN   
 C...Z0: 
         IF(mint(61).EQ.1) THEN  
           ei=kchg(iabs(mint(15)),1)/3.  
           ai=sign(1.,ei)    
           vi=ai-4.*ei*xw    
           sqmz=pmas(23,1)**2    
           gzmz=pmas(23,2)*pmas(23,1)    
           ggi=ei**2 
           gzi=ei*vi/(8.*xw*(1.-xw))*sqm*(sqm-sqmz)/ 
      &    ((sqm-sqmz)**2+gzmz**2)   
           zzi=(vi**2+ai**2)/(16.*xw*(1.-xw))**2*sqm**2/ 
      &    ((sqm-sqmz)**2+gzmz**2)   
           IF(mstp(43).EQ.1) THEN    
 C...Only gamma* production included 
             gzi=0.  
             zzi=0.  
           ELSEIF(mstp(43).EQ.2) THEN    
 C...Only Z0 production included 
             ggi=0.  
             gzi=0.  
           ENDIF 
         ELSEIF(mint(61).EQ.2) THEN  
           vint(111)=0.  
           vint(112)=0.  
           vint(114)=0.  
         ENDIF   
         DO 120 i=1,mdcy(23,3)   
         idc=i+mdcy(23,2)-1  
         rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
         rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
         IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 120  
         IF(i.LE.8) THEN 
 C...Z0 -> q + qb    
           ef=kchg(i,1)/3.   
           af=sign(1.,ef+0.1)    
           vf=af-4.*ef*xw    
           IF(mint(61).EQ.0) THEN    
             wdtp(i)=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*   
      &      sqrt(max(0.,1.-4.*rm1))*radc    
           ELSEIF(mint(61).EQ.1) THEN    
             wdtp(i)=3.*((ggi*ef**2+gzi*ef*vf+zzi*vf**2)*    
      &      (1.+2.*rm1)+zzi*af**2*(1.-4.*rm1))* 
      &      sqrt(max(0.,1.-4.*rm1))*radc    
           ELSEIF(mint(61).EQ.2) THEN    
             ggf=3.*ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
             gzf=3.*ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
             zzf=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*   
      &      sqrt(max(0.,1.-4.*rm1))*radc    
           ENDIF 
           wid2=1.   
         ELSEIF(i.LE.16) THEN    
 C...Z0 -> l+ + l-, nu + nub 
           ef=kchg(i+2,1)/3. 
           af=sign(1.,ef+0.1)    
           vf=af-4.*ef*xw    
           wdtp(i)=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*    
      &    sqrt(max(0.,1.-4.*rm1))   
           IF(mint(61).EQ.0) THEN    
             wdtp(i)=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*  
      &      sqrt(max(0.,1.-4.*rm1)) 
           ELSEIF(mint(61).EQ.1) THEN    
             wdtp(i)=((ggi*ef**2+gzi*ef*vf+zzi*vf**2)*   
      &      (1.+2.*rm1)+zzi*af**2*(1.-4.*rm1))* 
      &      sqrt(max(0.,1.-4.*rm1)) 
           ELSEIF(mint(61).EQ.2) THEN    
             ggf=ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
             gzf=ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
             zzf=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*  
      &      sqrt(max(0.,1.-4.*rm1)) 
           ENDIF 
           wid2=1.   
         ELSE    
 C...Z0 -> H+ + H-   
           cf=2.*(1.-2.*xw)  
           IF(mint(61).EQ.0) THEN    
             wdtp(i)=0.25*cf**2*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))  
           ELSEIF(mint(61).EQ.1) THEN    
             wdtp(i)=0.25*(ggi+gzi*cf+zzi*cf**2)*(1.-4.*rm1)*    
      &      sqrt(max(0.,1.-4.*rm1)) 
           ELSEIF(mint(61).EQ.2) THEN    
             ggf=0.25*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))    
             gzf=0.25*cf*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1)) 
             zzf=0.25*cf**2*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))  
           ENDIF 
           wid2=wids(37,1)   
         ENDIF   
         wdtp(0)=wdtp(0)+wdtp(i) 
         IF(mdme(idc,1).GT.0) THEN   
           wdte(i,mdme(idc,1))=wdtp(i)*wid2  
           wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
           wdte(i,0)=wdte(i,mdme(idc,1)) 
           wdte(0,0)=wdte(0,0)+wdte(i,0) 
           vint(111)=vint(111)+ggf*wid2  
           vint(112)=vint(112)+gzf*wid2  
           vint(114)=vint(114)+zzf*wid2  
         ENDIF   
   120   CONTINUE    
         IF(mstp(43).EQ.1) THEN  
 C...Only gamma* production included 
           vint(112)=0.  
           vint(114)=0.  
         ELSEIF(mstp(43).EQ.2) THEN  
 C...Only Z0 production included 
           vint(111)=0.  
           vint(112)=0.  
         ENDIF   
     
       ELSEIF(kfla.EQ.24) THEN   
 C...W+/-:   
         DO 130 i=1,mdcy(24,3)   
         idc=i+mdcy(24,2)-1  
         rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
         rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
         IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 130  
         IF(i.LE.16) THEN    
 C...W+/- -> q + qb' 
           wdtp(i)=3.*(2.-rm1-rm2-(rm1-rm2)**2)* 
      &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))* 
      &    vckm((i-1)/4+1,mod(i-1,4)+1)*radc 
           wid2=1.   
         ELSE    
 C...W+/- -> l+/- + nu   
           wdtp(i)=(2.-rm1-rm2-(rm1-rm2)**2)*    
      &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))  
           wid2=1.   
         ENDIF   
         wdtp(0)=wdtp(0)+wdtp(i) 
         IF(mdme(idc,1).GT.0) THEN   
           wdte(i,mdme(idc,1))=wdtp(i)*wid2  
           wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
           wdte(i,0)=wdte(i,mdme(idc,1)) 
           wdte(0,0)=wdte(0,0)+wdte(i,0) 
         ENDIF   
   130   CONTINUE    
     
       ELSEIF(kfla.EQ.25) THEN   
 C...H0: 
         DO 170 i=1,mdcy(25,3)   
         idc=i+mdcy(25,2)-1  
         rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
         rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
         IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 170  
         IF(i.LE.8) THEN 
 C...H0 -> q + qb    
           wdtp(i)=3.*rm1*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
           wid2=1.   
         ELSEIF(i.LE.12) THEN    
 C...H0 -> l+ + l-   
           wdtp(i)=rm1*(1.-4.*rm1)*sqrt(max(0.,1.-4.*rm1))   
           wid2=1.   
         ELSEIF(i.EQ.13) THEN    
 C...H0 -> g + g; quark loop contribution only   
           etare=0.  
           etaim=0.  
           DO 140 j=1,2*mstp(1)  
           eps=(2.*pmas(j,1)/rmas)**2    
           IF(eps.LE.1.) THEN    
             IF(eps.GT.1.e-4) THEN   
               root=sqrt(1.-eps) 
               rln=log((1.+root)/(1.-root))  
             ELSE    
               rln=log(4./eps-2.)    
             ENDIF   
             phire=0.25*(rln**2-paru(1)**2)  
             phiim=0.5*paru(1)*rln   
           ELSE  
             phire=-(asin(1./sqrt(eps)))**2  
             phiim=0.    
           ENDIF 
           etare=etare+0.5*eps*(1.+(eps-1.)*phire)   
           etaim=etaim+0.5*eps*(eps-1.)*phiim    
   140     CONTINUE  
           eta2=etare**2+etaim**2    
           wdtp(i)=(as/paru(1))**2*eta2  
           wid2=1.   
         ELSEIF(i.EQ.14) THEN    
 C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions 
           etare=0.  
           etaim=0.  
           DO 150 j=1,3*mstp(1)+1    
           IF(j.LE.2*mstp(1)) THEN   
             ej=kchg(j,1)/3. 
             eps=(2.*pmas(j,1)/rmas)**2  
           ELSEIF(j.LE.3*mstp(1)) THEN   
             jl=2*(j-2*mstp(1))-1    
             ej=kchg(10+jl,1)/3. 
             eps=(2.*pmas(10+jl,1)/rmas)**2  
           ELSE  
             eps=(2.*pmas(24,1)/rmas)**2 
           ENDIF 
           IF(eps.LE.1.) THEN    
             IF(eps.GT.1.e-4) THEN   
               root=sqrt(1.-eps) 
               rln=log((1.+root)/(1.-root))  
             ELSE    
               rln=log(4./eps-2.)    
             ENDIF   
             phire=0.25*(rln**2-paru(1)**2)  
             phiim=0.5*paru(1)*rln   
           ELSE  
             phire=-(asin(1./sqrt(eps)))**2  
             phiim=0.    
           ENDIF 
           IF(j.LE.2*mstp(1)) THEN   
             etare=etare+0.5*3.*ej**2*eps*(1.+(eps-1.)*phire)    
             etaim=etaim+0.5*3.*ej**2*eps*(eps-1.)*phiim 
           ELSEIF(j.LE.3*mstp(1)) THEN   
             etare=etare+0.5*ej**2*eps*(1.+(eps-1.)*phire)   
             etaim=etaim+0.5*ej**2*eps*(eps-1.)*phiim    
           ELSE  
             etare=etare-0.5-0.75*eps*(1.+(eps-2.)*phire)    
             etaim=etaim+0.75*eps*(eps-2.)*phiim 
           ENDIF 
   150     CONTINUE  
           eta2=etare**2+etaim**2    
           wdtp(i)=(aem/paru(1))**2*0.5*eta2 
           wid2=1.   
         ELSEIF(i.EQ.15) THEN    
 C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions    
           etare=0.  
           etaim=0.  
           DO 160 j=1,3*mstp(1)+1    
           IF(j.LE.2*mstp(1)) THEN   
             ej=kchg(j,1)/3. 
             aj=sign(1.,ej+0.1)  
             vj=aj-4.*ej*xw  
             eps=(2.*pmas(j,1)/rmas)**2  
             epsp=(2.*pmas(j,1)/pmas(23,1))**2   
           ELSEIF(j.LE.3*mstp(1)) THEN   
             jl=2*(j-2*mstp(1))-1    
             ej=kchg(10+jl,1)/3. 
             aj=sign(1.,ej+0.1)  
             vj=ai-4.*ej*xw  
             eps=(2.*pmas(10+jl,1)/rmas)**2  
             epsp=(2.*pmas(10+jl,1)/pmas(23,1))**2   
           ELSE  
             eps=(2.*pmas(24,1)/rmas)**2 
             epsp=(2.*pmas(24,1)/pmas(23,1))**2  
           ENDIF 
           IF(eps.LE.1.) THEN    
             root=sqrt(1.-eps)   
             IF(eps.GT.1.e-4) THEN   
               rln=log((1.+root)/(1.-root))  
             ELSE    
               rln=log(4./eps-2.)    
             ENDIF   
             phire=0.25*(rln**2-paru(1)**2)  
             phiim=0.5*paru(1)*rln   
             psire=-(1.+0.5*root*rln)    
             psiim=0.5*paru(1)*root  
           ELSE  
             phire=-(asin(1./sqrt(eps)))**2  
             phiim=0.    
             psire=-(1.+sqrt(eps-1.)*asin(1./sqrt(eps))) 
             psiim=0.    
           ENDIF 
           IF(epsp.LE.1.) THEN   
             root=sqrt(1.-epsp)  
             IF(epsp.GT.1.e-4) THEN  
               rln=log((1.+root)/(1.-root))  
             ELSE    
               rln=log(4./epsp-2.)   
             ENDIF   
             phirep=0.25*(rln**2-paru(1)**2) 
             phiimp=0.5*paru(1)*rln  
             psirep=-(1.+0.5*root*rln)   
             psiimp=0.5*paru(1)*root 
           ELSE  
             phirep=-(asin(1./sqrt(epsp)))**2    
             phiimp=0.   
             psirep=-(1.+sqrt(epsp-1.)*asin(1./sqrt(epsp)))  
             psiimp=0.   
           ENDIF 
           fxyre=eps*epsp/(8.*(eps-epsp))*(1.-eps*epsp/(eps-epsp)*(phire-    
      &    phirep)+2.*eps/(eps-epsp)*(psire-psirep)) 
           fxyim=eps*epsp/(8.*(eps-epsp))*(-eps*epsp/(eps-epsp)*(phiim-  
      &    phiimp)+2.*eps/(eps-epsp)*(psiim-psiimp)) 
           f1re=eps*epsp/(2.*(eps-epsp))*(phire-phirep)  
           f1im=eps*epsp/(2.*(eps-epsp))*(phiim-phiimp)  
           IF(j.LE.2*mstp(1)) THEN   
             etare=etare-3.*ej*vj*(fxyre-0.25*f1re)  
             etaim=etaim-3.*ej*vj*(fxyim-0.25*f1im)  
           ELSEIF(j.LE.3*mstp(1)) THEN   
             etare=etare-ej*vj*(fxyre-0.25*f1re) 
             etaim=etaim-ej*vj*(fxyim-0.25*f1im) 
           ELSE  
             etare=etare-sqrt(1.-xw)*(((1.+2./eps)*xw/sqrt(1.-xw)-   
      &      (5.+2./eps))*fxyre+(3.-xw/sqrt(1.-xw))*f1re)    
             etaim=etaim-sqrt(1.-xw)*(((1.+2./eps)*xw/sqrt(1.-xw)-   
      &      (5.+2./eps))*fxyim+(3.-xw/sqrt(1.-xw))*f1im)    
           ENDIF 
   160     CONTINUE  
           eta2=etare**2+etaim**2    
           wdtp(i)=(aem/paru(1))**2*(1.-(pmas(23,1)/rmas)**2)**3/xw*eta2 
           wid2=wids(23,2)   
         ELSE    
 C...H0 -> Z0 + Z0, W+ + W-  
           wdtp(i)=(1.-4.*rm1+12.*rm1**2)*sqrt(max(0.,1.-4.*rm1))/   
      &    (2.*(18-i))   
           wid2=wids(7+i,1)  
         ENDIF   
         wdtp(0)=wdtp(0)+wdtp(i) 
         IF(mdme(idc,1).GT.0) THEN   
           wdte(i,mdme(idc,1))=wdtp(i)*wid2  
           wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
           wdte(i,0)=wdte(i,mdme(idc,1)) 
           wdte(0,0)=wdte(0,0)+wdte(i,0) 
         ENDIF   
   170   CONTINUE    
     
       ELSEIF(kfla.EQ.32) THEN   
 C...Z'0:    
         IF(mint(61).EQ.1) THEN  
           ei=kchg(iabs(mint(15)),1)/3.  
           ai=sign(1.,ei)    
           vi=ai-4.*ei*xw    
           sqmz=pmas(23,1)**2    
           gzmz=pmas(23,2)*pmas(23,1)    
           api=sign(1.,ei)   
           vpi=api-4.*ei*xw  
           sqmzp=pmas(32,1)**2   
           gzpmzp=pmas(32,2)*pmas(32,1)  
           ggi=ei**2 
           gzi=ei*vi/(8.*xw*(1.-xw))*sqm*(sqm-sqmz)/ 
      &    ((sqm-sqmz)**2+gzmz**2)   
           gzpi=ei*vpi/(8.*xw*(1.-xw))*sqm*(sqm-sqmzp)/  
      &    ((sqm-sqmzp)**2+gzpmzp**2)    
           zzi=(vi**2+ai**2)/(16.*xw*(1.-xw))**2*sqm**2/ 
      &    ((sqm-sqmz)**2+gzmz**2)   
           zzpi=2.*(vi*vpi+ai*api)/(16.*xw*(1.-xw))**2*  
      &    sqm**2*((sqm-sqmz)*(sqm-sqmzp)+gzmz*gzpmzp)/  
      &    (((sqm-sqmz)**2+gzmz**2)*((sqm-sqmzp)**2+gzpmzp**2))  
           zpzpi=(vpi**2+api**2)/(16.*xw*(1.-xw))**2*sqm**2/ 
      &    ((sqm-sqmzp)**2+gzpmzp**2)    
           IF(mstp(44).EQ.1) THEN    
 C...Only gamma* production included 
             gzi=0.  
             gzpi=0. 
             zzi=0.  
             zzpi=0. 
             zpzpi=0.    
           ELSEIF(mstp(44).EQ.2) THEN    
 C...Only Z0 production included 
             ggi=0.  
             gzi=0.  
             gzpi=0. 
             zzpi=0. 
             zpzpi=0.    
           ELSEIF(mstp(44).EQ.3) THEN    
 C...Only Z'0 production included    
             ggi=0.  
             gzi=0.  
             gzpi=0. 
             zzi=0.  
             zzpi=0. 
           ELSEIF(mstp(44).EQ.4) THEN    
 C...Only gamma*/Z0 production included  
             gzpi=0. 
             zzpi=0. 
             zpzpi=0.    
           ELSEIF(mstp(44).EQ.5) THEN    
 C...Only gamma*/Z'0 production included 
             gzi=0.  
             zzi=0.  
             zzpi=0. 
           ELSEIF(mstp(44).EQ.6) THEN    
 C...Only Z0/Z'0 production included 
             ggi=0.  
             gzi=0.  
             gzpi=0. 
           ENDIF 
         ELSEIF(mint(61).EQ.2) THEN  
           vint(111)=0.  
           vint(112)=0.  
           vint(113)=0.  
           vint(114)=0.  
           vint(115)=0.  
           vint(116)=0.  
         ENDIF   
         DO 180 i=1,mdcy(32,3)   
         idc=i+mdcy(32,2)-1  
         rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
         rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
         IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 180  
         IF(i.LE.8) THEN 
 C...Z'0 -> q + qb   
           ef=kchg(i,1)/3.   
           af=sign(1.,ef+0.1)    
           vf=af-4.*ef*xw    
           apf=sign(1.,ef+0.1)   
           vpf=apf-4.*ef*xw  
           IF(mint(61).EQ.0) THEN    
             wdtp(i)=3.*(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))* 
      &      sqrt(max(0.,1.-4.*rm1))*radc    
           ELSEIF(mint(61).EQ.1) THEN    
             wdtp(i)=3.*((ggi*ef**2+gzi*ef*vf+gzpi*ef*vpf+zzi*vf**2+ 
      &      zzpi*vf*vpf+zpzpi*vpf**2)*(1.+2.*rm1)+(zzi*af**2+   
      &      zzpi*af*apf+zpzpi*apf**2)*(1.-4.*rm1))* 
      &      sqrt(max(0.,1.-4.*rm1))*radc    
           ELSEIF(mint(61).EQ.2) THEN    
             ggf=3.*ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
             gzf=3.*ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc   
             gzpf=3.*ef*vpf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))*radc 
             zzf=3.*(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*   
      &      sqrt(max(0.,1.-4.*rm1))*radc    
             zzpf=3.*(vf*vpf*(1.+2.*rm1)+af*apf*(1.-4.*rm1))*    
      &      sqrt(max(0.,1.-4.*rm1))*radc    
             zpzpf=3.*(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*   
      &      sqrt(max(0.,1.-4.*rm1))*radc    
           ENDIF 
           wid2=1.   
         ELSE    
 C...Z'0 -> l+ + l-, nu + nub    
           ef=kchg(i+2,1)/3. 
           af=sign(1.,ef+0.1)    
           vf=af-4.*ef*xw    
           apf=sign(1.,ef+0.1)   
           vpf=api-4.*ef*xw  
           IF(mint(61).EQ.0) THEN    
             wdtp(i)=(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*    
      &      sqrt(max(0.,1.-4.*rm1)) 
           ELSEIF(mint(61).EQ.1) THEN    
             wdtp(i)=((ggi*ef**2+gzi*ef*vf+gzpi*ef*vpf+zzi*vf**2+    
      &      zzpi*vf*vpf+zpzpi*vpf**2)*(1.+2.*rm1)+(zzi*af**2+   
      &      zzpi*af*apf+zpzpi*apf**2)*(1.-4.*rm1))* 
      &      sqrt(max(0.,1.-4.*rm1)) 
           ELSEIF(mint(61).EQ.2) THEN    
             ggf=ef**2*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
             gzf=ef*vf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1))   
             gzpf=ef*vpf*(1.+2.*rm1)*sqrt(max(0.,1.-4.*rm1)) 
             zzf=(vf**2*(1.+2.*rm1)+af**2*(1.-4.*rm1))*  
      &      sqrt(max(0.,1.-4.*rm1)) 
             zzpf=(vf*vpf*(1.+2.*rm1)+af*apf*(1.-4.*rm1))*   
      &      sqrt(max(0.,1.-4.*rm1)) 
             zpzpf=(vpf**2*(1.+2.*rm1)+apf**2*(1.-4.*rm1))*  
      &      sqrt(max(0.,1.-4.*rm1)) 
           ENDIF 
           wid2=1.   
         ENDIF   
         wdtp(0)=wdtp(0)+wdtp(i) 
         IF(mdme(idc,1).GT.0) THEN   
           wdte(i,mdme(idc,1))=wdtp(i)*wid2  
           wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
           wdte(i,0)=wdte(i,mdme(idc,1)) 
           wdte(0,0)=wdte(0,0)+wdte(i,0) 
           vint(111)=vint(111)+ggf   
           vint(112)=vint(112)+gzf   
           vint(113)=vint(113)+gzpf  
           vint(114)=vint(114)+zzf   
           vint(115)=vint(115)+zzpf  
           vint(116)=vint(116)+zpzpf 
         ENDIF   
   180   CONTINUE    
         IF(mstp(44).EQ.1) THEN  
 C...Only gamma* production included 
           vint(112)=0.  
           vint(113)=0.  
           vint(114)=0.  
           vint(115)=0.  
           vint(116)=0.  
         ELSEIF(mstp(44).EQ.2) THEN  
 C...Only Z0 production included 
           vint(111)=0.  
           vint(112)=0.  
           vint(113)=0.  
           vint(115)=0.  
           vint(116)=0.  
         ELSEIF(mstp(44).EQ.3) THEN  
 C...Only Z'0 production included    
           vint(111)=0.  
           vint(112)=0.  
           vint(113)=0.  
           vint(114)=0.  
           vint(115)=0.  
         ELSEIF(mstp(44).EQ.4) THEN  
 C...Only gamma*/Z0 production included  
           vint(113)=0.  
           vint(115)=0.  
           vint(116)=0.  
         ELSEIF(mstp(44).EQ.5) THEN  
 C...Only gamma*/Z'0 production included 
           vint(112)=0.  
           vint(114)=0.  
           vint(115)=0.  
         ELSEIF(mstp(44).EQ.6) THEN  
 C...Only Z0/Z'0 production included 
           vint(111)=0.  
           vint(112)=0.  
           vint(113)=0.  
         ENDIF   
     
       ELSEIF(kfla.EQ.37) THEN   
 C...H+/-:   
         DO 190 i=1,mdcy(37,3)   
         idc=i+mdcy(37,2)-1  
         rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
         rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
         IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 190  
         IF(i.LE.4) THEN 
 C...H+/- -> q + qb' 
           wdtp(i)=3.*((rm1*paru(121)+rm2/paru(121))*    
      &    (1.-rm1-rm2)-4.*rm1*rm2)* 
      &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))*radc 
           wid2=1.   
         ELSE    
 C...H+/- -> l+/- + nu   
           wdtp(i)=((rm1*paru(121)+rm2/paru(121))*   
      &    (1.-rm1-rm2)-4.*rm1*rm2)* 
      &    sqrt(max(0.,(1.-rm1-rm2)**2-4.*rm1*rm2))  
           wid2=1.   
         ENDIF   
         wdtp(0)=wdtp(0)+wdtp(i) 
         IF(mdme(idc,1).GT.0) THEN   
           wdte(i,mdme(idc,1))=wdtp(i)*wid2  
           wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
           wdte(i,0)=wdte(i,mdme(idc,1)) 
           wdte(0,0)=wdte(0,0)+wdte(i,0) 
         ENDIF   
   190   CONTINUE    
     
       ELSEIF(kfla.EQ.40) THEN   
 C...R:  
         DO 200 i=1,mdcy(40,3)   
         idc=i+mdcy(40,2)-1  
         rm1=(pmas(iabs(kfdp(idc,1)),1)/rmas)**2 
         rm2=(pmas(iabs(kfdp(idc,2)),1)/rmas)**2 
         IF(sqrt(rm1)+sqrt(rm2).GT.1..OR.mdme(idc,1).LT.0) GOTO 200  
         IF(i.LE.4) THEN 
 C...R -> q + qb'    
           wdtp(i)=3.*radc   
           wid2=1.   
         ELSE    
 C...R -> l+ + l'-   
           wdtp(i)=1.    
           wid2=1.   
         ENDIF   
         wdtp(0)=wdtp(0)+wdtp(i) 
         IF(mdme(idc,1).GT.0) THEN   
           wdte(i,mdme(idc,1))=wdtp(i)*wid2  
           wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))   
           wdte(i,0)=wdte(i,mdme(idc,1)) 
           wdte(0,0)=wdte(0,0)+wdte(i,0) 
         ENDIF   
   200   CONTINUE    
     
       ENDIF 
       mint(61)=0    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pyxtot()

subroutine pyxtot ( )

Definition at line 11177 of file hipyset1.35.f.

     
 C...Parametrizes total, double diffractive, single diffractive and  
 C...elastic cross-sections for different energies and beams.    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/pypars/mstp(200),parp(200),msti(200),pari(200) 
       SAVE /pypars/ 
       common/pyint1/mint(400),vint(400) 
       SAVE /pyint1/ 
       common/pyint5/ngen(0:200,3),xsec(0:200,3) 
       SAVE /pyint5/ 
       dimension bcs(5,8),bcb(2,5),bcc(3)    
     
 C...The following data lines are coefficients needed in the 
 C...Block, Cahn parametrization of total cross-section and nuclear  
 C...slope parameter; see below. 
       DATA ((bcs(i,j),j=1,8),i=1,5)/    
      1 41.74, 0.66, 0.0000, 337.,  0.0, 0.0, -39.3, 0.48,   
      2 41.66, 0.60, 0.0000, 306.,  0.0, 0.0, -34.6, 0.51,   
      3 41.36, 0.63, 0.0000, 299.,  7.3, 0.5, -40.4, 0.47,   
      4 41.68, 0.63, 0.0083, 330.,  0.0, 0.0, -39.0, 0.48,   
      5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/   
       DATA ((bcb(i,j),j=1,5),i=1,2)/    
      1 10.79, -0.049, 0.040, 21.5, 1.23,    
      2  9.92, -0.027, 0.013, 18.9, 1.07/    
       DATA bcc/2.0164346,-0.5590311,0.0376279/  
     
 C...Total cross-section and nuclear slope parameter for pp and p-pbar   
       nfit=min(5,max(1,mstp(31)))   
       sigp=bcs(nfit,1)+bcs(nfit,2)*(-0.25*paru(1)**2*   
      &(1.-0.25*bcs(nfit,3)*paru(1)**2)+(1.+0.5*bcs(nfit,3)*paru(1)**2)* 
      &(log(vint(2)/bcs(nfit,4)))**2+bcs(nfit,3)*    
      &(log(vint(2)/bcs(nfit,4)))**4)/   
      &((1.-0.25*bcs(nfit,3)*paru(1)**2)**2+2.*bcs(nfit,3)*  
      &(1.+0.25*bcs(nfit,3)*paru(1)**2)*(log(vint(2)/bcs(nfit,4)))**2+   
      &bcs(nfit,3)**2*(log(vint(2)/bcs(nfit,4)))**4)+bcs(nfit,5)*    
      &vint(2)**(bcs(nfit,6)-1.)*sin(0.5*paru(1)*bcs(nfit,6))    
       sigm=-bcs(nfit,7)*vint(2)**(bcs(nfit,8)-1.)*  
      &cos(0.5*paru(1)*bcs(nfit,8))  
       refp=bcs(nfit,2)*paru(1)*log(vint(2)/bcs(nfit,4))/    
      &((1.-0.25*bcs(nfit,3)*paru(1)**2)**2+2.*bcs(nfit,3)*  
      &(1.+0.25*bcs(nfit,3)*paru(1)**2)+(log(vint(2)/bcs(nfit,4)))**2+   
      &bcs(nfit,3)**2*(log(vint(2)/bcs(nfit,4)))**4)-bcs(nfit,5)*    
      &vint(2)**(bcs(nfit,6)-1.)*cos(0.5*paru(1)*bcs(nfit,6))    
       refm=-bcs(nfit,7)*vint(2)**(bcs(nfit,8)-1.)*  
      &sin(0.5*paru(1)*bcs(nfit,8))  
       sigma=sigp-isign(1,mint(11)*mint(12))*sigm    
       rho=(refp-isign(1,mint(11)*mint(12))*refm)/sigma  
     
 C...Nuclear slope parameter B, curvature C: 
       nfit=1    
       IF(mstp(31).GE.4) nfit=2  
       bp=bcb(nfit,1)+bcb(nfit,2)*log(vint(2))+  
      &bcb(nfit,3)*(log(vint(2)))**2 
       bm=bcb(nfit,4)+bcb(nfit,5)*log(vint(2))   
       b=bp-isign(1,mint(11)*mint(12))*sigm/sigp*(bm-bp) 
       vint(121)=b   
       c=-0.5*bcc(2)/bcc(3)*(1.-sqrt(max(0.,1.+4.*bcc(3)/bcc(2)**2*  
      &(1.e-03*vint(1)-bcc(1)))))    
       vint(122)=c   
     
 C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).   
       sigel=sigma**2*(1.+rho**2)/(16.*paru(1)*paru(5)*b)    
     
 C...Single diffractive scattering cross-section from Goulianos: 
       sigsd=2.*0.68*(1.+36./vint(2))*log(0.6+0.1*vint(2))   
     
 C...Double diffractive scattering cross-section (essentially fixed by   
 C...sigma-sd and sigma-el). 
       sigdd=sigsd**2/(3.*sigel) 
     
 C...Total non-elastic, non-diffractive cross-section.   
       signd=sigma-sigdd-sigsd-sigel 
     
 C...Rescale for pions.  
       IF(iabs(mint(11)).EQ.211.AND.iabs(mint(12)).EQ.211) THEN  
         sigma=4./9.*sigma   
         sigdd=4./9.*sigdd   
         sigsd=4./9.*sigsd   
         sigel=4./9.*sigel   
         signd=4./9.*signd   
       ELSEIF(iabs(mint(11)).EQ.211.OR.iabs(mint(12)).EQ.211) THEN   
         sigma=2./3.*sigma   
         sigdd=2./3.*sigdd   
         sigsd=2./3.*sigsd   
         sigel=2./3.*sigel   
         signd=2./3.*signd   
       ENDIF 
     
 C...Save cross-sections in common block PYPARA. 
       vint(101)=sigma   
       vint(102)=sigel   
       vint(103)=sigsd   
       vint(104)=sigdd   
       vint(106)=signd   
       xsec(95,1)=signd  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ rlu()

function rlu ( IDUM )

Definition at line 5182 of file hipyset1.35.f.

     
 C...Purpose: to generate random numbers uniformly distributed between   
 C...0 and 1, excluding the endpoints.   
       common/ludatr/mrlu(6),rrlu(100)   
       SAVE /ludatr/ 
       equivalence(mrlu1,mrlu(1)),(mrlu2,mrlu(2)),(mrlu3,mrlu(3)),  
      &(mrlu4,mrlu(4)),(mrlu5,mrlu(5)),(mrlu6,mrlu(6)),  
      &(rrlu98,rrlu(98)),(rrlu99,rrlu(99)),(rrlu00,rrlu(100))    
     
 C...Initialize generation from given seed.  
       IF(mrlu2.EQ.0) THEN   
         ij=mod(mrlu1/30082,31329)   
         kl=mod(mrlu1,30082) 
         i=mod(ij/177,177)+2 
         j=mod(ij,177)+2 
         k=mod(kl/169,178)+1 
         l=mod(kl,169)   
         DO 110 ii=1,97  
         s=0.    
         t=0.5   
         DO 100 jj=1,24  
         m=mod(mod(i*j,179)*k,179)   
         i=j 
         j=k 
         k=m 
         l=mod(53*l+1,169)   
         IF(mod(l*m,64).GE.32) s=s+t 
   100   t=0.5*t 
   110   rrlu(ii)=s  
         twom24=1.   
         DO 120 i24=1,24 
   120   twom24=0.5*twom24   
         rrlu98=362436.*twom24   
         rrlu99=7654321.*twom24  
         rrlu00=16777213.*twom24 
         mrlu2=1 
         mrlu3=0 
         mrlu4=97    
         mrlu5=33    
       ENDIF 
     
 C...Generate next random number.    
   130 runi=rrlu(mrlu4)-rrlu(mrlu5)  
       IF(runi.LT.0.) runi=runi+1.   
       rrlu(mrlu4)=runi  
       mrlu4=mrlu4-1 
       IF(mrlu4.EQ.0) mrlu4=97   
       mrlu5=mrlu5-1 
       IF(mrlu5.EQ.0) mrlu5=97   
       rrlu98=rrlu98-rrlu99  
       IF(rrlu98.LT.0.) rrlu98=rrlu98+rrlu00 
       runi=runi-rrlu98  
       IF(runi.LT.0.) runi=runi+1.   
       IF(runi.LE.0.OR.runi.GE.1.) GOTO 130  
     
 C...Update counters. Random number to output.   
       mrlu3=mrlu3+1 
       IF(mrlu3.EQ.1000000000) THEN  
         mrlu2=mrlu2+1   
         mrlu3=0 
       ENDIF 
       rlu=runi  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ rluget()

subroutine rluget	(	LFN,
		MOVE
	)

Definition at line 5251 of file hipyset1.35.f.

     
 C...Purpose: to dump the state of the random number generator on a file 
 C...for subsequent startup from this state onwards. 
       common/ludatr/mrlu(6),rrlu(100)   
       SAVE /ludatr/ 
       CHARACTER cherr*8 
     
 C...Backspace required number of records (or as many as there are). 
       IF(move.LT.0) THEN    
         nbck=min(mrlu(6),-move) 
         DO 100 ibck=1,nbck  
   100   backspace(lfn,err=110,iostat=ierr)  
         mrlu(6)=mrlu(6)-nbck    
       ENDIF 
     
 C...Unformatted write on unit LFN.  
       WRITE(lfn,err=110,iostat=ierr) (mrlu(i1),i1=1,5), 
      &(rrlu(i2),i2=1,100)   
       mrlu(6)=mrlu(6)+1 
       RETURN    
     
 C...Write error.    
   110 WRITE(cherr,'(I8)') ierr  
       CALL luerrm(18,'(RLUGET:) error when accessing file, IOSTAT ='//  
      &cherr)    
     
       RETURN    

Here is the call graph for this function:

◆ rluset()

subroutine rluset	(	LFN,
		MOVE
	)

Definition at line 5283 of file hipyset1.35.f.

     
 C...Purpose: to read a state of the random number generator from a file 
 C...for subsequent generation from this state onwards.  
       common/ludatr/mrlu(6),rrlu(100)   
       SAVE /ludatr/ 
       CHARACTER cherr*8 
     
 C...Backspace required number of records (or as many as there are). 
       IF(move.LT.0) THEN    
         nbck=min(mrlu(6),-move) 
         DO 100 ibck=1,nbck  
   100   backspace(lfn,err=120,iostat=ierr)  
         mrlu(6)=mrlu(6)-nbck    
       ENDIF 
     
 C...Unformatted read from unit LFN. 
       nfor=1+max(0,move)    
       DO 110 ifor=1,nfor    
   110 READ(lfn,err=120,iostat=ierr) (mrlu(i1),i1=1,5),  
      &(rrlu(i2),i2=1,100)   
       mrlu(6)=mrlu(6)+nfor  
       RETURN    
     
 C...Write error.    
   120 WRITE(cherr,'(I8)') ierr  
       CALL luerrm(18,'(RLUSET:) error when accessing file, IOSTAT ='//  
      &cherr)    
     
       RETURN    

Here is the call graph for this function:

◆ ulalps()

function ulalps ( Q2 )

Definition at line 5099 of file hipyset1.35.f.

     
 C...Purpose: to give the value of alpha_strong. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Constant alpha_strong trivial.  
       IF(mstu(111).LE.0) THEN   
         ulalps=paru(111)    
         mstu(118)=mstu(112) 
         paru(117)=0.    
         paru(118)=paru(111) 
         RETURN  
       ENDIF 
     
 C...Find effective Q2, number of flavours and Lambda.   
       q2eff=q2  
       IF(mstu(115).GE.2) q2eff=max(q2,paru(114))    
       nf=mstu(112)  
       alam2=paru(112)**2    
   100 IF(nf.GT.max(2,mstu(113))) THEN   
         q2thr=paru(113)*pmas(nf,1)**2   
         IF(q2eff.LT.q2thr) THEN 
           nf=nf-1   
           alam2=alam2*(q2thr/alam2)**(2./(33.-2.*nf))   
           GOTO 100  
         ENDIF   
       ENDIF 
   110 IF(nf.LT.min(8,mstu(114))) THEN   
         q2thr=paru(113)*pmas(nf+1,1)**2 
         IF(q2eff.GT.q2thr) THEN 
           nf=nf+1   
           alam2=alam2*(alam2/q2thr)**(2./(33.-2.*nf))   
           GOTO 110  
         ENDIF   
       ENDIF 
       IF(mstu(115).EQ.1) q2eff=q2eff+alam2  
       paru(117)=sqrt(alam2) 
     
 C...Evaluate first or second order alpha_strong.    
       b0=(33.-2.*nf)/6. 
       algq=log(q2eff/alam2) 
       IF(mstu(111).EQ.1) THEN   
         ulalps=paru(2)/(b0*algq)    
       ELSE  
         b1=(153.-19.*nf)/6. 
         ulalps=paru(2)/(b0*algq)*(1.-b1*log(algq)/(b0**2*algq)) 
       ENDIF 
       mstu(118)=nf  
       paru(118)=ulalps  
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ ulangl()

function ulangl	(	X,
		Y
	)

Definition at line 5157 of file hipyset1.35.f.

     
 C...Purpose: to reconstruct an angle from given x and y coordinates.    
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
     
       ulangl=0. 
       r=sqrt(x**2+y**2) 
       IF(r.LT.1e-20) RETURN 
       IF(abs(x)/r.LT.0.8) THEN  
         ulangl=sign(acos(x/r),y)    
       ELSE  
         ulangl=asin(y/r)    
         IF(x.LT.0..AND.ulangl.GE.0.) THEN   
           ulangl=paru(1)-ulangl 
         ELSEIF(x.LT.0.) THEN    
           ulangl=-paru(1)-ulangl    
         ENDIF   
       ENDIF 
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

◆ ulmass()

function ulmass ( KF )

Definition at line 4680 of file hipyset1.35.f.

     
 C...Purpose: to give the mass of a particle/parton. 
       common/ludat1/mstu(200),paru(200),mstj(200),parj(200) 
       SAVE /ludat1/ 
       common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)    
       SAVE /ludat2/ 
     
 C...Reset variables. Compressed code.   
       ulmass=0. 
       kfa=iabs(kf)  
       kc=lucomp(kf) 
       IF(kc.EQ.0) RETURN    
       parf(106)=pmas(6,1)   
       parf(107)=pmas(7,1)   
       parf(108)=pmas(8,1)   
     
 C...Guarantee use of constituent masses for internal checks.    
       IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.kfa.LE.10) THEN   
         ulmass=parf(100+kfa)    
         IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(121))   
     
 C...Masses that can be read directly off table. 
       ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN  
         ulmass=pmas(kc,1)   
     
 C...Find constituent partons and their masses.  
       ELSE  
         kfla=mod(kfa/1000,10)   
         kflb=mod(kfa/100,10)    
         kflc=mod(kfa/10,10) 
         kfls=mod(kfa,10)    
         kflr=mod(kfa/10000,10)  
         pma=parf(100+kfla)  
         pmb=parf(100+kflb)  
         pmc=parf(100+kflc)  
     
 C...Construct masses for various meson, diquark and baryon cases.   
         IF(kfla.EQ.0.AND.kflr.EQ.0.AND.kfls.LE.3) THEN  
           IF(kfls.EQ.1) pmspl=-3./(pmb*pmc) 
           IF(kfls.GE.3) pmspl=1./(pmb*pmc)  
           ulmass=parf(111)+pmb+pmc+parf(113)*parf(101)**2*pmspl 
         ELSEIF(kfla.EQ.0) THEN  
           kmul=2    
           IF(kfls.EQ.1) kmul=3  
           IF(kflr.EQ.2) kmul=4  
           IF(kfls.EQ.5) kmul=5  
           ulmass=parf(113+kmul)+pmb+pmc 
         ELSEIF(kflc.EQ.0) THEN  
           IF(kfls.EQ.1) pmspl=-3./(pma*pmb) 
           IF(kfls.EQ.3) pmspl=1./(pma*pmb)  
           ulmass=2.*parf(112)/3.+pma+pmb+parf(114)*parf(101)**2*pmspl   
           IF(mstj(93).EQ.1) ulmass=pma+pmb  
           IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(122)- 
      &    2.*parf(112)/3.)  
         ELSE    
           IF(kfls.EQ.2.AND.kfla.EQ.kflb) THEN   
             pmspl=1./(pma*pmb)-2./(pma*pmc)-2./(pmb*pmc)    
           ELSEIF(kfls.EQ.2.AND.kflb.GE.kflc) THEN   
             pmspl=-2./(pma*pmb)-2./(pma*pmc)+1./(pmb*pmc)   
           ELSEIF(kfls.EQ.2) THEN    
             pmspl=-3./(pmb*pmc) 
           ELSE  
             pmspl=1./(pma*pmb)+1./(pma*pmc)+1./(pmb*pmc)    
           ENDIF 
           ulmass=parf(112)+pma+pmb+pmc+parf(114)*parf(101)**2*pmspl 
         ENDIF   
       ENDIF 
     
 C...Optional mass broadening according to truncated Breit-Wigner    
 C...(either in m or in m^2).    
       IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1e-4) THEN 
         IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN    
           ulmass=ulmass+0.5*pmas(kc,2)*tan((2.*rlu(0)-1.)*  
      &    atan(2.*pmas(kc,3)/pmas(kc,2)))   
         ELSE    
           pm0=ulmass    
           pmlow=atan((max(0.,pm0-pmas(kc,3))**2-pm0**2)/    
      &    (pm0*pmas(kc,2))) 
           pmupp=atan((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2))   
           ulmass=sqrt(max(0.,pm0**2+pm0*pmas(kc,2)*tan(pmlow+   
      &    (pmupp-pmlow)*rlu(0))))   
         ENDIF   
       ENDIF 
       mstj(93)=0    
     
       RETURN    

Here is the call graph for this function:

Here is the caller graph for this function:

Functions/Subroutines

Function/Subroutine Documentation

◆ hirobo()

◆ klu()

◆ lu1ent()

◆ lu2ent()

◆ lu3ent()

◆ lu4ent()

◆ luboei()

◆ lucell()

◆ luchge()

◆ luclus()

◆ lucomp()

◆ ludecy()

◆ luedit()

◆ lueevt()

◆ luerrm()

◆ luexec()

◆ lufowo()

◆ lugive()

◆ luhepc()

◆ luindf()

◆ lujmas()

◆ lujoin()

◆ lukfdi()

◆ lulist()

◆ luname()

◆ luonia()

◆ luprep()

◆ luptdi()

◆ luradk()

◆ lurobo()

◆ lushow()

◆ lusphe()

◆ lustrf()

◆ lutabu()

◆ lutest()

◆ luthru()

◆ luupda()

◆ lux3jt()

◆ lux4jt()

◆ luxdif()

◆ luxjet()

◆ luxkfl()

◆ luxtot()

◆ luzdis()

◆ plu()

◆ pydiff()

◆ pyfram()

◆ pygamm()

◆ pyi3au()

◆ pyinit()

◆ pyinki()

◆ pyinre()

◆ pykcut()

◆ pyklim()

◆ pykmap()

◆ pymaxi()

◆ pymult()

◆ pyovly()

◆ pyrand()

◆ pyremn()

◆ pyresd()

◆ pyscat()

◆ pysigh()

◆ pyspen()

◆ pyspli()

◆ pysspa()

◆ pystat()

◆ pystfe()

◆ pystfu()

◆ pytest()

◆ pythia()

◆ pyw1au()

◆ pyw2au()

◆ pywidt()

◆ pyxtot()

◆ rlu()

◆ rluget()

◆ rluset()