C********************************************************************* C*** HEADER ******************************************************** C * C THE LUND MONTE CARLO FOR JET FRAGMENTATION AND E+E- PHYSICS * C JETSET VERSION 6.3, OCTOBER 1986 * C AUTHOR: TORBJORN SJOSTRAND, DEPARTMENT OF THEORETICAL PHYSICS, * C UNIVERSITY OF LUND, SOLVEGATAN 14A, S-223 62 LUND, SWEDEN * C BITNET/EARN USER THEP NODE SELDC51 * C LUSHOW IS WRITTEN TOGETHER WITH MATS BENGTSSON, ADDRESS AS ABOVE * C PLEASE REPORT ANY ERRORS TO THE AUTHOR * C * C********************************************************************* C*** JETSET VERSION 6.3, GENERAL PART ****************************** SUBROUTINE LUPART(IP,KF,PE,THE,PHI) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) C...FILL ONE PARTICLE (OR JET IF KF>=500) IF(MST(19).GE.1) CALL LULIST(-1) IF(IP.GE.MST(30)-5-MST(31)) MST(26)=1 IR=MAX(IP,1) K(IR,1)=0 K(IR,2)=KF IF(MST(9).EQ.0) P(IR,5)=ULMASS(1,KF) P(IR,4)=MAX(PE,P(IR,5)) PA=SQRT(P(IR,4)**2-P(IR,5)**2) P(IR,1)=PA*SIN(THE)*COS(PHI) P(IR,2)=PA*SIN(THE)*SIN(PHI) P(IR,3)=PA*COS(THE) N=IR IF(IP.EQ.0) CALL LUEXEC RETURN END C********************************************************************* SUBROUTINE LU1JET(IP,IFL,IFLJ,IFLI,PE,THE,PHI) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) C...FILL ONE JET: LEADING QUARK, GLUON OR DIQUARK IF(IABS(IFL).GT.100) MST(26)=2 IR=MAX(IABS(IP),1) CALL LUPART(IR,IFL+ISIGN(500,2*IFL+1),PE,THE,PHI) IF(IP.LT.0) K(N,1)=10000 IF(IFLJ.NE.0.OR.IFLI.NE.0) THEN C...EXTRA LINE FOR ORDER IN DIQUARK AND/OR LAST QUARK IN HADRON JET IF(IABS(IFLJ).GT.10.OR.IABS(IFLI).GT.10.OR.(IFLJ.NE.0.AND. & IABS(IFL).LT.10).OR.IFL*IFLJ.LT.0.OR.(IFLI.NE.0.AND.IFL.EQ.0). & OR.IFL*(10-IABS(IFL))*IFLI.GT.0) MST(26)=2 N=IR+1 K(N,1)=60000+IR K(N,2)=ISIGN(600+10*IABS(IFLJ)+IABS(IFLI),IFLJ+IFLI) DO 100 J=1,5 100 P(N,J)=0. ENDIF IF(IP.EQ.0) CALL LUEXEC RETURN END C********************************************************************* SUBROUTINE LU2JET(IP,IFL1,IFL2,ECM) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) C...FLAVOUR CHECKS, FILL TWO JETS IN CM FRAME, IFL1 ALONG +Z AXIS IF(IABS(IFL1).GT.100.OR.IABS(IFL2).GT.100.OR.(IFL1.EQ.0.AND. &IFL2.NE.0).OR.(IFL1.NE.0.AND.IFL2.EQ.0).OR.IFL1*(10- &IABS(IFL1))*IFL2*(10-IABS(IFL2)).GT.0) MST(26)=2 IR=MAX(IABS(IP),1) IF(MST(9).EQ.0) P(IR,5)=ULMASS(2,IFL1) IF(MST(9).EQ.0) P(IR+1,5)=ULMASS(2,IFL2) IF(ECM.LE.P(IR,5)+P(IR+1,5)) MST(26)=4 PE1=0.5*(ECM+(P(IR,5)**2-P(IR+1,5)**2)/ECM) MST(9)=MST(9)+1 CALL LUPART(IR,IFL1+ISIGN(500,2*IFL1+1),PE1,0.,0.) K(N,1)=10000 CALL LUPART(IR+1,IFL2+ISIGN(500,2*IFL2+1),ECM-PE1,PAR(71),0.) MST(9)=MST(9)-1 IF(IP.EQ.0) CALL LUEXEC C...REARRANGE JETS TO PREPARE FOR SHOWER EVOLUTION (OPTIONAL) IF(IP.LT.0) THEN K(IR+2,1)=K(IR+1,1) K(IR+2,2)=K(IR+1,2) DO 100 J=1,5 100 P(IR+2,J)=P(IR+1,J) DO 110 I=IR+1,IR+3,2 K(I,1)=70000+I-1 K(I,2)=1000+I-1 P(I,3)=0. P(I,4)=0. 110 P(I,5)=0. P(IR+1,1)=IR+2 P(IR+1,2)=IR+2 P(IR+3,1)=IR P(IR+3,2)=IR N=N+2 ENDIF RETURN END C********************************************************************* SUBROUTINE LU3JET(IP,IFL1,IFL3,ECM,X1,X3) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) C...FLAVOUR CHECKS, CALCULATE MASSES AND MOMENTA IF(IABS(IFL1).GT.100.OR.IABS(IFL3).GT.100.OR.(IFL1.EQ.0.AND. &IFL3.NE.0).OR.(IFL1.NE.0.AND.IFL3.EQ.0).OR.IFL1*(10- &IABS(IFL1))*IFL3*(10-IABS(IFL3)).GT.0) MST(26)=2 IR=MAX(IP,1) IF(MST(9).EQ.0) P(IR,5)=ULMASS(2,IFL1) IF(MST(9).EQ.0) P(IR+1,5)=ULMASS(2,0) IF(MST(9).EQ.0) P(IR+2,5)=ULMASS(2,IFL3) IF(0.5*X1*ECM.LE.P(IR,5).OR.0.5*(2.-X1-X3)*ECM.LE.P(IR+1,5).OR. &0.5*X3*ECM.LE.P(IR+2,5)) MST(26)=4 PA1=SQRT((0.5*X1*ECM)**2-P(IR,5)**2) PA2=SQRT((0.5*(2.-X1-X3)*ECM)**2-P(IR+1,5)**2) PA3=SQRT((0.5*X3*ECM)**2-P(IR+2,5)**2) C...FILL THREE JETS IN CM FRAME, IFL1 ALONG +Z AXIS, IFL3 IN XZ C...PLANE WITH X>0; IFL2 IS AUTOMATICALLY GLUON CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2) IF(ABS(CTHE2).GE.1.001) MST(26)=4 IF(ABS(CTHE2).LE.1.001) CTHE2=MAX(-1.,MIN(1.,CTHE2)) THE2=-ACOS(CTHE2) CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3) IF(ABS(CTHE3).GE.1.001) MST(26)=4 IF(ABS(CTHE3).LE.1.001) CTHE3=MAX(-1.,MIN(1.,CTHE3)) THE3=ACOS(CTHE3) MST(9)=MST(9)+1 CALL LUPART(IR,IFL1+ISIGN(500,2*IFL1+1),0.5*X1*ECM,0.,0.) K(N,1)=10000 CALL LUPART(IR+1,500,0.5*(2.-X1-X3)*ECM,THE2,0.) K(N,1)=10000 CALL LUPART(IR+2,IFL3+ISIGN(500,2*IFL3+1),0.5*X3*ECM,THE3,0.) MST(9)=MST(9)-1 IF(IP.EQ.0) CALL LUEXEC C...REARRANGE JETS TO PREPARE FOR SHOWER EVOLUTION (OPTIONAL) IF(IP.LT.0) THEN DO 100 I=2,1,-1 K(IR+2*I,1)=K(IR+I,1) K(IR+2*I,2)=K(IR+I,2) DO 100 J=1,5 100 P(IR+2*I,J)=P(IR+I,J) DO 110 I=IR+1,IR+5,2 K(I,1)=70000+I-1 K(I,2)=1000+I-1 P(I,3)=0. P(I,4)=0. 110 P(I,5)=0. ISG=1 IF((IFL1.LT.0.AND.IFL1.GT.-10).OR.IFL1.GT.10) ISG=2 P(IR+1,ISG)=IR+2 P(IR+1,3-ISG)=IR+4 P(IR+3,ISG)=IR+4 P(IR+3,3-ISG)=IR P(IR+5,ISG)=IR P(IR+5,3-ISG)=IR+2 N=N+3 ENDIF RETURN END C********************************************************************* SUBROUTINE LU4JET(IP,IFL1,IFL2,IFL3,IFL4,ECM,X1,X2,X4,X12,X14) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) C...FLAVOUR CHECKS, CALCULATE MASSES AND MOMENTA IF(IABS(IFL1).GT.100.OR.IABS(IFL2).GT.100.OR.IABS(IFL3).GT.100. &OR.IABS(IFL4).GT.100) MST(26)=2 IF(IFL2.EQ.0.AND.(IFL3.NE.0.OR.(IFL1.EQ.0.AND.IFL4.NE.0).OR. &(IFL1.NE.0.AND.IFL4.EQ.0).OR.IFL1*(10-IABS(IFL1))*IFL4* &(10-IABS(IFL4)).GT.0)) MST(26)=2 IF(IFL2.NE.0.AND.(IFL1.EQ.0.OR.IFL1*(10-IABS(IFL1))*IFL2* &(10-IABS(IFL2)).GT.0.OR.(IFL3.EQ.0.AND.IFL4.NE.0).OR. &(IFL3.NE.0.AND.IFL4.EQ.0).OR.IFL3*(10-IABS(IFL3))*IFL4* &(10-IABS(IFL4)).GT.0)) MST(26)=2 IR=MAX(IP,1) IF(MST(9).EQ.0) P(IR,5)=ULMASS(2,IFL1) IF(MST(9).EQ.0) P(IR+1,5)=ULMASS(2,IFL2) IF(MST(9).EQ.0) P(IR+2,5)=ULMASS(2,IFL3) IF(MST(9).EQ.0) P(IR+3,5)=ULMASS(2,IFL4) IF(0.5*X1*ECM.LE.P(IR,5).OR.0.5*X2*ECM.LE.P(IR+1,5).OR. &0.5*(2.-X1-X2-X4)*ECM.LE.P(IR+2,5).OR.0.5*X4*ECM.LE. &P(IR+3,5)) MST(26)=4 PA1=SQRT((0.5*X1*ECM)**2-P(IR,5)**2) PA2=SQRT((0.5*X2*ECM)**2-P(IR+1,5)**2) PA3=SQRT((0.5*(2.-X1-X2-X4)*ECM)**2-P(IR+2,5)**2) PA4=SQRT((0.5*X4*ECM)**2-P(IR+3,5)**2) C...KINEMATICS FOR FOUR JETS IN CM FRAME, IFL1 ALONG +Z AXIS, C...IFL4 IN XZ PLANE WITH X>0, IFL2 WITH Y>0 AND Y<0 EQUALLY OFTEN X24=X1+X2+X4-1.-X12-X14+(P(IR+2,5)**2-P(IR,5)**2- &P(IR+1,5)**2-P(IR+3,5)**2)/ECM**2 CTHE4=(X1*X4-2.*X14)*ECM**2/(4.*PA1*PA4) IF(ABS(CTHE4).GE.1.002) MST(26)=4 IF(ABS(CTHE4).LE.1.002) CTHE4=MAX(-1.,MIN(1.,CTHE4)) THE4=ACOS(CTHE4) CTHE2=(X1*X2-2.*X12)*ECM**2/(4.*PA1*PA2) IF(ABS(CTHE2).GE.1.002) MST(26)=4 IF(ABS(CTHE2).LE.1.002) CTHE2=MAX(-1.,MIN(1.,CTHE2)) THE2=ACOS(CTHE2) CTHE3=-(PA1+PA2*CTHE2+PA4*CTHE4)/PA3 IF(ABS(CTHE3).GE.1.002) MST(26)=4 IF(ABS(CTHE3).LE.1.002) CTHE3=MAX(-1.,MIN(1.,CTHE3)) THE3=ACOS(CTHE3) SGN=(-1.)**INT(RLU(0)+0.5) CPHI2=((X2*X4-2.*X24)*ECM**2-4.*PA2*CTHE2*PA4*CTHE4)/ &(4.*PA2*SIN(THE2)*PA4*SIN(THE4)) IF(ABS(CPHI2).GE.1.05) MST(26)=4 IF(ABS(CPHI2).LE.1.05) CPHI2=MAX(-1.,MIN(1.,CPHI2)) PHI2=SGN*ACOS(CPHI2) CPHI3=-(PA2*SIN(THE2)*CPHI2+PA4*SIN(THE4))/(PA3*SIN(THE3)) IF(ABS(CPHI3).GE.1.05) MST(26)=4 IF(ABS(CPHI3).LE.1.05) CPHI3=MAX(-1.,MIN(1.,CPHI3)) PHI3=-SGN*ACOS(CPHI3) C...FILL JETS, TWO SEPARATE SYSTEMS IF IFL2 NOT GLUON MST(9)=MST(9)+1 CALL LUPART(IR,IFL1+ISIGN(500,2*IFL1+1),0.5*X1*ECM,0.,0.) K(N,1)=10000 CALL LUPART(IR+1,IFL2+ISIGN(500,2*IFL2+1),0.5*X2*ECM,THE2,PHI2) IF(IFL2.EQ.0) K(N,1)=10000 CALL LUPART(IR+2,IFL3+ISIGN(500,2*IFL3+1),0.5*(2.-X1-X2-X4)*ECM, &THE3,PHI3) K(N,1)=10000 CALL LUPART(IR+3,IFL4+ISIGN(500,2*IFL4+1),0.5*X4*ECM,THE4,0.) MST(9)=MST(9)-1 IF(IP.EQ.0) CALL LUEXEC C...REARRANGE JETS TO PREPARE FOR SHOWER EVOLUTION (OPTIONAL) IF(IP.LT.0) THEN DO 100 I=3,1,-1 K(IR+2*I,1)=K(IR+I,1) K(IR+2*I,2)=K(IR+I,2) DO 100 J=1,5 100 P(IR+2*I,J)=P(IR+I,J) DO 110 I=IR+1,IR+7,2 K(I,1)=70000+I-1 K(I,2)=1000+I-1 P(I,3)=0. P(I,4)=0. 110 P(I,5)=0. IF(IFL2.EQ.0) THEN ISG=1 IF((IFL1.LT.0.AND.IFL1.GT.-10).OR.IFL1.GT.10) ISG=2 DO 120 I=1,4 P(IR+2*I-1,ISG)=IR+2*I 120 P(IR+2*I-1,3-ISG)=IR+2*I-4 P(IR+1,3-ISG)=IR+6 P(IR+7,ISG)=IR ELSE DO 130 J=1,2 P(IR+1,J)=IR+2 P(IR+3,J)=IR P(IR+5,J)=IR+6 130 P(IR+7,J)=IR+4 ENDIF N=N+4 ENDIF RETURN END C********************************************************************* FUNCTION KLU(I,J) COMMON/LUJETS/N,K(2000,2),P(2000,5) KLU=0 IF(I.LT.0.OR.J.LE.0) RETURN C...NUMBER OF LINES, NUMBER OF STABLE PARTICLES/JETS, TOTAL CHARGE, C...NUMBER OF JETS IF(I.EQ.0.AND.J.LE.1) THEN KLU=N ELSEIF(I.EQ.0) THEN DO 100 I1=1,N IF(J.EQ.2.AND.K(I1,1).LT.20000) KLU=KLU+1 IF(J.EQ.3.AND.K(I1,1).LT.20000) KLU=KLU+LUCHGE(K(I1,2)) IF(J.NE.3.OR.K(I1,1)/10000.NE.6) GOTO 100 IF(K(I1-1,1).LT.20000) KLU=KLU+LUCHGE(K(I1,2)) 100 IF(J.EQ.4.AND.K(I1,1).LT.40000.AND.IABS(K(I1,2)).GE.500) KLU= & KLU+1 C...DIRECT READOUT OF K MATRIX OR CHARGE ELSEIF(J.LE.2) THEN KLU=K(I,J) ELSEIF(J.LE.4) THEN IF(J.EQ.3) KLU=LUCHGE(K(I,2)) C...PARTICLE HISTORY: PARENT, GENERATION, ANCESTOR, RANK IF(J.EQ.4) KLU=MOD(K(I,1),10000) ELSEIF(J.LE.7) THEN I2=I I1=I 110 KLU=KLU+1 I3=I2 I2=I1 I1=MOD(K(I1,1),10000) IF(I1.GT.0.AND.K(I1,1).LT.40000) GOTO 110 IF(J.EQ.6) KLU=I2 IF(J.EQ.7) THEN KLU=0 DO 120 I1=I2+1,I3 120 IF(MOD(K(I1,1),10000).EQ.I2.AND.K(I1,1).LT.40000) KLU=KLU+1 ENDIF C...PARTICLE CODE OR IFL JET CODE, ELSE 0 OR 1000 ELSEIF(J.LE.9) THEN IF(J.EQ.8.AND.K(I,1).LT.60000.AND.IABS(K(I,2)).LT.500) KLU= & K(I,2) IF(J.EQ.9) KLU=1000 IF(J.EQ.9.AND.K(I,1).LT.60000.AND.IABS(K(I,2)).GE.500) KLU= & MOD(K(I,2),500) C...PARTICLE OR JET CODE AFTER CUTS, ELSE 0 ELSEIF(J.LE.13) THEN IF(K(I,1).LT.60000) KLU=K(I,2) IF(J.GE.11.AND.K(I,1).GE.20000) KLU=0 KFA=IABS(K(I,2)) IF(J.GE.12.AND.(KFA.EQ.8.OR.KFA.EQ.10.OR.KFA.EQ.12.OR.KFA.EQ. & 14)) KLU=0 IF(J.GE.13.AND.LUCHGE(KFA).EQ.0) KLU=0 C...HEAVIEST FLAVOUR IN HADRON, 0 FOR NON-HADRON ELSEIF(J.EQ.14) THEN CALL LUIFLV(K(I,2),IFLA,IFLB,IFLC,KSP) IF(KSP.GE.0) KLU=IFLA C...PARTICLE COMING FROM COLLAPSING JET SYSTEM OR NOT ELSEIF(J.EQ.15) THEN I1=I 130 KLU=KLU+1 I3=I1 I1=MOD(K(I1,1),10000) IF(I1.EQ.0.AND.KLU.EQ.1) KLU=-1 IF(I1.EQ.0.AND.KLU.GT.1) KLU=0 IF(I1.EQ.0) RETURN IF(IABS(K(I1,2)).LT.500) GOTO 130 IF(K(I1,1)/10000.NE.3) KLU=0 IF(K(I1,1)/10000.NE.3) RETURN I2=I1 140 I2=I2+1 IF(I2.LT.N.AND.K(I2,1)/10000.NE.2) GOTO 140 K3M=MOD(K(I3-1,1),10000) IF(K3M.EQ.I1.OR.K3M.EQ.I2) KLU=0 K3P=MOD(K(I3+1,1),10000) IF(I3.LT.N.AND.(K3P.EQ.I1.OR.K3P.EQ.I2)) KLU=0 ENDIF RETURN END C********************************************************************* FUNCTION PLU(I,J) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) DIMENSION PSUM(4) PLU=0. IF(I.LT.0.OR.J.LE.0.OR.(I.EQ.0.AND.J.GT.6)) RETURN C...SUM OF MOMENTA OR CHARGES (IF I=0) OR DIRECT READOUT OF P MATRIX IF(I.EQ.0.AND.J.LE.4) THEN DO 100 I1=1,N 100 IF(K(I1,1).LT.20000) 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).LT.20000) 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) THEN DO 120 I1=1,N IF(K(I1,1)/10000.NE.6) GOTO 120 IF(K(I1-1,1).LT.20000) PLU=PLU+LUCHGE(K(I1,2))/3. 120 IF(K(I1,1).LT.20000) PLU=PLU+LUCHGE(K(I1,2))/3. 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 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./PAR(71) 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(0,17) PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2) PLU=SIGN(ALOG(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)/PAR(75) IF(J.EQ.21) PLU=2.*P(I,3)/PAR(75) IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PAR(75) IF(J.EQ.23) PLU=2.*P(I,4)/PAR(75) IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PAR(75) IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PAR(75) ENDIF RETURN END C********************************************************************* SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) DIMENSION ROT(3,3),PV(3) DOUBLE PRECISION DP(4),DBEX,DBEY,DBEZ,DGA,DBEP,DGABEP IMAX=N IF(MST(2).GT.0) IMAX=MST(2) IF(THE**2+PHI**2.GT.1E-20) THEN C...ROTATE (TYPICALLY FROM Z AXIS TO DIRECTION THETA,PHI) 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 120 I=MAX(1,MST(1)),IMAX IF(MOD(K(I,1)/10000,10).GE.6) GOTO 120 DO 100 J=1,3 100 PV(J)=P(I,J) DO 110 J=1,3 110 P(I,J)=ROT(J,1)*PV(1)+ROT(J,2)*PV(2)+ROT(J,3)*PV(3) 120 CONTINUE ENDIF IF(BEX**2+BEY**2+BEZ**2.GT.1E-20) THEN C...LORENTZ BOOST (TYPICALLY FROM REST TO MOMENTUM/ENERGY=BETA) DBEX=BEX DBEY=BEY DBEZ=BEZ DGA=1D0/DSQRT(1D0-DBEX**2-DBEY**2-DBEZ**2) DO 140 I=MAX(1,MST(1)),IMAX IF(MOD(K(I,1)/10000,10).GE.6) GOTO 140 DO 130 J=1,4 130 DP(J)=P(I,J) DBEP=DBEX*DP(1)+DBEY*DP(2)+DBEZ*DP(3) DGABEP=DGA*(DGA*DBEP/(1D0+DGA)+DP(4)) P(I,1)=DP(1)+DGABEP*DBEX P(I,2)=DP(2)+DGABEP*DBEY P(I,3)=DP(3)+DGABEP*DBEZ P(I,4)=DGA*(DP(4)+DBEP) 140 CONTINUE ENDIF RETURN END C********************************************************************* SUBROUTINE LUEDIT(MEDIT) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) IF(MEDIT.GE.0.AND.MEDIT.LE.3) THEN C...THROW AWAY UNWANTED JETS AND PARTICLES IMAX=N IF(MST(2).GT.0) IMAX=MST(2) MNOT=0 I1=MAX(1,MST(1))-1 DO 120 I=MAX(1,MST(1)),IMAX IF(MNOT.EQ.1.AND.K(I,1)/20000.EQ.3) GOTO 100 MNOT=0 IF(K(I,1).GE.40000) GOTO 120 IF(MEDIT.GE.1.AND.K(I,1).GE.20000) GOTO 120 KFA=IABS(K(I,2)) IF(MEDIT.GE.2.AND.(KFA.EQ.8.OR.KFA.EQ.10.OR.KFA.EQ.12.OR. & KFA.EQ.14)) GOTO 120 IF(MEDIT.GE.3.AND.KFA.LE.499.AND.LUCHGE(KFA).EQ.0) GOTO 120 IF(KFA.GE.500) MNOT=1 C...PACK REMAINING JETS AND PARTICLES, ORIGIN NO LONGER KNOWN 100 I1=I1+1 K(I1,1)=10000*(K(I,1)/10000) K(I1,2)=K(I,2) DO 110 J=1,5 110 P(I1,J)=P(I,J) 120 CONTINUE N=I1 ELSEIF(MEDIT.EQ.-1) THEN C...SAVE TOP ENTRIES AT BOTTOM OF LUJETS IF(2*N.GE.MST(30)) THEN MST(26)=1 RETURN ENDIF DO 130 I=1,N K(MST(30)-I,1)=K(I,1) K(MST(30)-I,2)=K(I,2) DO 130 J=1,5 130 P(MST(30)-I,J)=P(I,J) MST(31)=N ELSEIF(MEDIT.EQ.-2) THEN C...RESTORE BOTTOM ENTRIES OF LUJETS TO TOP DO 140 I=1,MST(31) K(I,1)=K(MST(30)-I,1) K(I,2)=K(MST(30)-I,2) DO 140 J=1,5 140 P(I,J)=P(MST(30)-I,J) N=MST(31) ELSEIF(MEDIT.EQ.-3) THEN C...MARK PRIMARY ENTRIES IN TOP OF LUJETS AS UNTREATED I1=0 DO 150 I=1,N KH=MOD(K(I,1),10000) IF(KH.GE.1) THEN IF(K(KH,1)/20000.EQ.2) KH=0 ENDIF IF(K(I,1).GE.60000) KH=0 IF(KH.NE.0) GOTO 160 I1=I1+1 150 IF(K(I,1)/20000.EQ.1) K(I,1)=K(I,1)-20000 160 N=I1 ENDIF RETURN END C********************************************************************* SUBROUTINE LULIST(MLIST) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600) COMMON/LUDAT4/CHAG(50),CHAF(100) CHARACTER CHAG*4,CHAF*4,CHAP*8,CHAN*8,CHAD(4)*8 DIMENSION PS(6) IF((MLIST.GE.0.AND.MLIST.LE.2).OR.(MLIST.GE.10.AND.MLIST.LE.12)) &THEN C...LIST EVENT DATA IF(MLIST.LE.2) WRITE(MST(20),1000) IF(MLIST.GE.10) WRITE(MST(20),1100) IMAX=N IF(MST(2).GT.0) IMAX=MST(2) DO 100 I=MAX(1,MST(1)),IMAX CALL LUNAME(K(I,2),CHAP) MLC=0 IF(K(I,1)/20000.EQ.1) MLC=1 IF(MLC.EQ.1.AND.IABS(K(I,2)).GE.500) MLC=2 IF(K(I,1)/20000.EQ.2) MLC=K(I,1)/10000-1 IF(MLC.NE.0) CHAP(8:8)=CHAG(36)(MLC:MLC) IF(K(I,1).GE.70000) MLC=10 IF(MLIST.LE.2.AND.MLC.LT.10) WRITE(MST(20),1200) I, & MOD(K(I,1),10000),CHAP,(P(I,J),J=1,5) IF(MLIST.GE.10.AND.MLC.LT.10) WRITE(MST(20),1300) I,K(I,1), & K(I,2),CHAP,(P(I,J),J=1,5) IF(MLIST.LE.2.AND.MLC.EQ.10) WRITE(MST(20),1400) I,K(I,1), & K(I,2),(P(I,J),J=1,5) 100 IF(MLIST.GE.10.AND.MLC.EQ.10) WRITE(MST(20),1500) I,K(I,1), & K(I,2),(P(I,J),J=1,5) C...SUM OF CHARGES AND MOMENTA OR EXTRA LINES AFTER PARTICLES IF(MLIST.EQ.1.OR.MLIST.EQ.11) THEN DO 110 J=1,6 110 PS(J)=PLU(0,J) IF(MLIST.EQ.1) WRITE(MST(20),1600) PS(6),(PS(J),J=1,5) IF(MLIST.EQ.11) WRITE(MST(20),1700) PS(6),(PS(J),J=1,5) ELSEIF(MLIST.EQ.2.OR.MLIST.EQ.12) THEN DO 120 I=N+1,N+MST(3) IF(MLIST.EQ.2) WRITE(MST(20),1400) I,K(I,1),K(I,2), & (P(I,J),J=1,5) 120 IF(MLIST.EQ.12) WRITE(MST(20),1500) I,K(I,1),K(I,2), & (P(I,J),J=1,5) ENDIF ELSEIF(MLIST.EQ.3) THEN C...LIST PARTICLE DATA TABLE WRITE(MST(20),1800) KF=MAX(1,MST(1))-1 130 KF=KF+1 WRITE(MST(20),1900) C...PARTICLE NUMBER, NAME, TYPE, MASS, WIDTH 140 CALL LUNAME(KF,CHAP) CALL LUNAME(-KF,CHAN) KFA=KF IF(KF.GT.100) CALL LUIFLV(KF,IFLA,IFLB,IFLC,KSP) IF(KF.GT.100) KFA=100+IFLA PM=ULMASS(0,KF) KTY=KTYP(KFA) IF(KTY.LT.10) WRITE(MST(20),2000) KF,CHAP,CHAN,KTY,PM IF(KTY.GE.10) WRITE(MST(20),2000) KF,CHAP,CHAN,KTY,PM, & PWID(2*(KTY/10)-1),PWID(2*(KTY/10)) IF(KF.GT.100.AND.(MST(2).LE.0.OR.KF.LT.MST(2))) THEN C...FOR HEAVY HADRONS DECAY DATA ONLY BY GROUP CALL LUIFLV(KF+1-50*(KF/392),IFLA1,IFLB1,IFLC1,KSP1) IF(IFLA1.EQ.IFLA) KF=KF+1 IF(IFLA1.EQ.IFLA) GOTO 140 KFA=76+5*IFLA+KSP ENDIF C...PARTICLE DECAY: CHANNEL NUMBER, MATRIX ELEMENT, BRANCHING C...RATIO, DECAY PRODUCTS IF(IDB(KFA).EQ.0) GOTO 170 IDC=IDB(KFA)-1 150 IDC=IDC+1 MMAT=IABS(KDP(4*IDC-3))/1000 IF(IDC.EQ.IDB(KFA)) BR=100.*CBR(IDC) IF(IDC.NE.IDB(KFA)) BR=100.*(CBR(IDC)-CBR(IDC-1)) DO 160 J=1,4 160 CALL LUNAME(MOD(KDP(4*IDC-4+J),1000),CHAD(J)) WRITE(MST(20),2100) IDC,MMAT,BR,(CHAD(J),J=1,4) IF(CBR(IDC).LE.0.99999) GOTO 150 170 IF((MST(2).LE.0.AND.KF.LT.392).OR.(MST(2).GT.0.AND.KF.LT. & MST(2))) GOTO 130 ELSEIF(MLIST.EQ.4) THEN C...LIST PARTON/JET DATA TABLE WRITE(MST(20),2200) IFL=MAX(0,MST(1))-1 180 IFL=IFL+1 IF(IFL.GT.0.AND.MOD(IFL-1,10).GE.8) GOTO 180 CALL LUNAME(IFL+500,CHAP) CALL LUNAME(-IFL-500,CHAN) PMC=ULMASS(2,IFL) PMA=ULMASS(3,IFL) KTY=KTYP(100+MAX(IFL/10,MOD(IFL,10))) IF(KTY.LT.10) WRITE(MST(20),2300) IFL+500,IFL,CHAP,CHAN,KTY, & PMC,PMA IF(KTY.GE.10) WRITE(MST(20),2300) IFL+500,IFL,CHAP,CHAN,KTY, & PMC,PMA,PWID(2*(KTY/10)-1),PWID(2*(KTY/10)) IF((MST(2).LE.0.AND.IFL.LT.88).OR.(MST(2).GT.0.AND.IFL.LT. & MST(2).AND.(MOD(IFL,10).NE.8.OR.MST(2)-IFL.GE.3))) GOTO 180 ELSEIF(MLIST.EQ.5) THEN C...LIST PARAMETER VALUE TABLE WRITE(MST(20),2400) DO 190 L=1,20 190 WRITE(MST(20),2500) L,MST(L),MST(L+20),PAR(L),PAR(L+20), & PAR(L+40),PAR(L+60),DPAR(L) ELSEIF(MLIST.EQ.-1) THEN C...INITIALIZATION PRINTOUT (MONTE CARLO VERSION NUMBER AND DATE) WRITE(MST(20),2600) MST(19)=0 ENDIF C...FORMAT STATEMENTS FOR OUTPUT ON UNIT MST(20) (DEFAULT 6) 1000 FORMAT(///20X,'EVENT LISTING'//5X,'I ORI PART/JET',7X, &'PX',9X,'PY',9X,'PZ',9X,'E',10X,'M'/) 1100 FORMAT(///20X,'EVENT LISTING (EXTENDED)'//5X,'I K(I,1) K(I,2)', &3X,'PART/JET',7X,'P(I,1)',7X,'P(I,2)',7X,'P(I,3)',7X,'P(I,4)', &7X,'P(I,5)'/) 1200 FORMAT(2X,I4,1X,I7,3X,A8,5(1X,F10.3)) 1300 FORMAT(2X,I4,2(1X,I7),3X,A8,5(1X,F12.5)) 1400 FORMAT(2X,I4,1X,I7,4X,I7,5(1X,F10.3)) 1500 FORMAT(2X,I4,2(1X,I7),11X,5(1X,F12.5)) 1600 FORMAT(10X,'SUM:',6(1X,F10.3)) 1700 FORMAT(16X,'SUM:',6(1X,F12.5)) 1800 FORMAT(///20X,'PARTICLE DATA TABLE'//4X,'KF PARTICLE ', &'ANTIPART KTYP MASS WIDTH W-CUT'/18X, &'IDC MAT B.R. DECAY PRODUCTS') 1900 FORMAT(10X) 2000 FORMAT(1X,I5,4X,A8,3X,A8,1X,I5,1X,F12.5,1X,F11.5,1X,F11.5) 2100 FORMAT(16X,I5,3X,'(',I2,')',1X,F7.1,4(3X,A8)) 2200 FORMAT(///20X,'PARTON/JET DATA TABLE'//4X,'KF IFL PARTON', &' ANTIPAR KTYP M-CONS M-C.A. WIDTH W-CUT') 2300 FORMAT(/1X,I5,1X,I5,4X,A8,3X,A8,1X,I4,4(1X,F9.3)) 2400 FORMAT(///20X,'PARAMETER VALUE TABLE'//5X,'L',4X,'MST(L)', &3X,'&(L+20)',7X,'PAR(L)',6X,'&(L+20)',6X,'&(L+40)',6X, &'&(L+60)',6X,'DPAR(L)'/) 2500 FORMAT(1X,I5,2(1X,I9),5(1X,F12.4)) 2600 FORMAT(///20X,'THE LUND MONTE CARLO - JETSET VERSION 6.3'/ & 20X,' LAST DATE OF CHANGE: 12 JUNE 1987 ') RETURN END C********************************************************************* SUBROUTINE LUUPDA(MUPDA,LFN) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600) COMMON/LUDAT4/CHAG(50),CHAF(100) CHARACTER CHAG*4,CHAF*4,CLI*72,CUT*12,CWR*12,CSA*12,CRE*12 IF(MUPDA.EQ.1) THEN C...WRITE INFORMATION ON FILE FOR EDITING DO 120 KF=1,120 IF(IDB(KF).EQ.0) THEN NDC=0 ELSE IDC=IDB(KF)-1 100 IDC=IDC+1 IF(CBR(IDC).LE.0.99999) GOTO 100 NDC=IDC+1-IDB(KF) IF(KF.GE.2) THEN IF(IDB(KF).EQ.IDB(KF-1)) NDC=-1 ENDIF ENDIF KTY=KTYP(KF)-10*(KTYP(KF)/10) PWI=0. PCU=0. IF(KTYP(KF).GE.10) PWI=PWID(2*(KTYP(KF)/10)-1) IF(KTYP(KF).GE.10) PCU=PWID(2*(KTYP(KF)/10)) IF(KF.LE.100) WRITE(LFN,1000) KF,NDC,KTY,PMAS(KF),PWI,PCU, & CHAF(KF) IF(KF.GT.100) WRITE(LFN,1000) KF,NDC,KTY,PMAS(KF),PWI,PCU DO 110 IDC=IDB(KF),IDB(KF)+NDC-1 MMAT=IABS(KDP(4*IDC-3))/1000 110 WRITE(LFN,1100) CBR(IDC),MMAT,(MOD(KDP(4*IDC-4+J),1000),J=1,4) 120 CONTINUE ELSEIF(MUPDA.EQ.2) THEN C...READ INFORMATION FROM EDITING DO 130 I=1,60 130 PWID(I)=0. DO 140 I=1,400 140 CBR(I)=0. DO 150 I=1,1600 150 KDP(I)=0 IWIS=0 IDBS=0 DO 170 KF=1,120 IF(KF.LE.100) READ(LFN,1000) KFA,NDC,KTYP(KF),PMAS(KF),PWI,PCU, & CHAF(KF) IF(KF.GT.100) READ(LFN,1000) KFA,NDC,KTYP(KF),PMAS(KF),PWI,PCU IF(PWI.GE.0.0005) THEN PWID(2*IWIS+1)=PWI PWID(2*IWIS+2)=PCU IWIS=IWIS+1 KTYP(KF)=KTYP(KF)+10*IWIS ENDIF IF(NDC.EQ.0) THEN IDB(KF)=0 ELSEIF(NDC.EQ.-1) THEN IDB(KF)=IDB(KF-1) ELSE IDB(KF)=IDBS+1 DO 160 IDC=IDBS+1,IDBS+NDC READ(LFN,1100) CBR(IDC),MMAT,(KDP(4*IDC-4+J),J=1,4) 160 KDP(4*IDC-3)=KDP(4*IDC-3)+ISIGN(1000*MMAT,KDP(4*IDC-3)) IDBS=IDBS+NDC ENDIF 170 CONTINUE ELSEIF(MUPDA.EQ.3) THEN C...WRITE INFORMATION FOR INCLUSION IN PROGRAM DO 220 IC=1,12 NE=120 IF(IC.EQ.3) NE=60 IF(IC.EQ.5.OR.IC.EQ.6) NE=200 IF(IC.GE.7.AND.IC.LE.11) NE=320 IF(IC.EQ.12) NE=100 CLI=' ' IF(IC.EQ.1) CLI(7:16)='DATA KTYP/' IF(IC.EQ.2) CLI(7:16)='DATA PMAS/' IF(IC.EQ.3) CLI(7:16)='DATA PWID/' IF(IC.EQ.4) CLI(7:15)='DATA IDB/' IF(IC.EQ.5) CLI(7:28)='DATA (CBR(J),J=1,200)/' IF(IC.EQ.6) CLI(7:30)='DATA (CBR(J),J=201,400)/' IF(IC.EQ.7) CLI(7:28)='DATA (KDP(J),J=1,320)/' IF(IC.EQ.8) CLI(7:30)='DATA (KDP(J),J=321,640)/' IF(IC.EQ.9) CLI(7:30)='DATA (KDP(J),J=641,960)/' IF(IC.EQ.10) CLI(7:31)='DATA (KDP(J),J=961,1280)/' IF(IC.EQ.11) CLI(7:32)='DATA (KDP(J),J=1281,1600)/' IF(IC.EQ.12) CLI(7:16)='DATA CHAF/' LCT=16 IF(IC.EQ.4) LCT=15 IF(IC.EQ.5.OR.IC.EQ.7) LCT=28 IF(IC.EQ.6.OR.IC.EQ.8.OR.IC.EQ.9) LCT=30 IF(IC.EQ.10) LCT=31 IF(IC.EQ.11) LCT=32 CSA='START' DO 210 IE=1,NE IF(IC.EQ.1) WRITE(CUT,1200) KTYP(IE) IF(IC.EQ.2) WRITE(CUT,1300) PMAS(IE) IF(IC.EQ.3) WRITE(CUT,1300) PWID(IE) IF(IC.EQ.4) WRITE(CUT,1200) IDB(IE) IF(IC.EQ.5) WRITE(CUT,1300) CBR(IE) IF(IC.EQ.6) WRITE(CUT,1300) CBR(200+IE) IF(IC.EQ.7) WRITE(CUT,1200) KDP(IE) IF(IC.EQ.8) WRITE(CUT,1200) KDP(320+IE) IF(IC.EQ.9) WRITE(CUT,1200) KDP(640+IE) IF(IC.EQ.10) WRITE(CUT,1200) KDP(960+IE) IF(IC.EQ.11) WRITE(CUT,1200) KDP(1280+IE) IF(IC.EQ.12) CUT=CHAF(IE) CWR=' ' LA=1 LB=1 DO 180 LL=1,12 IF(CUT(13-LL:13-LL).NE.' ') LA=13-LL 180 IF(CUT(LL:LL).NE.' ') LB=LL LON=1+LB-LA CWR(1:LON)=CUT(LA:LB) IF(IC.EQ.12) THEN DO 190 LL=LON,1,-1 IF(CWR(LL:LL).EQ.'''') THEN CWR=CWR(1:LL)//''''//CWR(LL+1:11) LON=LON+1 ENDIF 190 CONTINUE CUT=CWR CWR(1:LON+2)=''''//CUT(1:LON)//'''' LON=LON+2 ELSEIF(IC.EQ.2.OR.IC.EQ.3.OR.IC.EQ.5.OR.IC.EQ.6) THEN LON=LON+1 200 LON=LON-1 IF(CWR(LON:LON).EQ.'0') GOTO 200 IF(LON.EQ.1) CWR(1:2)='0.' IF(LON.EQ.1) LON=2 ENDIF IF(CWR.NE.CSA) THEN IAG=1 CSA=CWR ELSE LEX=LON+1 IF(IAG.GE.2) LEX=LON+3 IF(IAG.GE.10) LEX=LON+4 IF(IAG.GE.100) LEX=LON+5 LCT=LCT-LEX IAG=IAG+1 WRITE(CRE,1200) IAG LEX=1 IF(IAG.GE.10) LEX=2 IF(IAG.GE.100) LEX=3 CUT=CWR CWR(1:LEX+1+LON)=CRE(13-LEX:12)//'*'//CUT(1:LON) LON=LON+LEX+1 ENDIF IF(LCT+LON.GT.70) THEN CLI(LCT+1:72)=' ' WRITE(LFN,1400) CLI CLI=' ' CLI(6:6)='&' LCT=6 ENDIF CLI(LCT+1:LCT+LON)=CWR(1:LON) LCT=LCT+LON+1 IF(IE.LT.NE) CLI(LCT:LCT)=',' 210 IF(IE.EQ.NE) CLI(LCT:LCT)='/' 220 WRITE(LFN,1400) CLI ENDIF C...FORMATS FOR READING AND WRITING PARTICLE DATA 1000 FORMAT(3I5,3F12.5,2X,A4) 1100 FORMAT(5X,F12.5,5I5) 1200 FORMAT(I12) 1300 FORMAT(F12.5) 1400 FORMAT(A72) RETURN END C********************************************************************* SUBROUTINE LUEXEC COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600) DIMENSION PSUM(2,5) C...RESET AND INITIALIZE, SUM UP ENERGY OF ORIGINAL JETS/PARTICLES IF(MST(19).GE.1) CALL LULIST(-1) MST(2)=0 MST(3)=0 NERR=MST(24) MST(25)=0 MST(32)=0 MST(34)=MST(34)+1 PAR(75)=0. DO 100 I=1,N 100 IF(MOD(K(I,1),10000).EQ.0) PAR(75)=PAR(75)+P(I,4) C...SUM UP MOMENTUM, ENERGY AND CHARGE FOR STARTING ENTRIES DO 110 I=1,2 DO 110 J=1,5 110 PSUM(I,J)=0. ICON=0 DO 130 I=1,N IF(K(I,1).GE.20000) GOTO 130 DO 120 J=1,4 120 PSUM(1,J)=PSUM(1,J)+P(I,J) PSUM(1,5)=PSUM(1,5)+LUCHGE(K(I,2)) IF(I.EQ.N) GOTO 130 IF(K(I+1,1)/10000.EQ.6) PSUM(1,5)=PSUM(1,5)+LUCHGE(K(I+1,2)) 130 CONTINUE C...CHECK AND PREPARE SYSTEM FOR SUBSEQUENT FRAGMENTATION/DECAY CALL LUPREP MST(1)=0 IF(MST(23).EQ.1.AND.MST(26).NE.0.AND.MST(35).LT.5) THEN MST(35)=MST(35)+1 WRITE(MST(20),1000) MST(34) IF(MST(26).EQ.1) WRITE(MST(20),1100) IF(MST(26).EQ.2) WRITE(MST(20),1200) IF(MST(26).EQ.3) WRITE(MST(20),1300) IF(MST(26).EQ.4) WRITE(MST(20),1400) MST(26)=0 ENDIF C...ADMINISTRATE JET FRAGMENTATION AND PARTICLE DECAY CHAIN IP=0 140 IP=IP+1 IF(K(IP,1).GE.20000) THEN ELSEIF(IABS(K(IP,2)).LT.500) THEN C...PARTICLE DECAY IF UNSTABLE KFA=IABS(K(IP,2)) IF(KFA.GT.100) CALL LUIFLV(KFA,IFLA,IFLB,IFLC,KSP) IF(KFA.GT.100) KFA=76+5*IFLA+KSP IF(MST(7).GE.1.AND.IDB(KFA).GE.1) CALL LUDECY(IP) ELSEIF(IABS(K(IP,2)).LE.600) THEN C...JET FRAGMENTATION: ONE JET OR SYSTEM MOS=MIN(MST(5),2) IF(MOS.EQ.2.AND.MST(6).GT.0) MOS=3 IF(MST(5).GE.1.AND.K(IP,1).LT.10000) MOS=2 IF(MST(7).GE.2.AND.K(IP,1).GE.10000.AND.N.GT.IP) THEN KH=MOD(K(IP,1),10000) IF(K(IP+1,1).LT.10000.AND.KH.GT.0.AND.KH.LT.IP) THEN IF(K(KH,1).LT.40000.AND.IABS(K(KH,2)).LT.400) MOS=1 ENDIF ENDIF IF(MOS.EQ.1) CALL LUSYSJ(IP) IF(MOS.EQ.2) CALL LUONEJ(IP) IF(MOS.EQ.3) CALL LUCONS(IP) IF(MOS.EQ.2) ICON=1 IF(MOS.EQ.3.AND.(MST(6).LE.0.OR.MOD(MST(6),5).EQ.0)) ICON=1 ENDIF C...ERROR CHECKS AND PRINTOUT IF(N.GE.MST(30)-20-MST(31).AND.IP.LT.N.AND.MST(24).EQ.NERR) &THEN MST(24)=MST(24)+1 MST(25)=1 ENDIF IF((MST(23).EQ.1.AND.MST(24).GT.NERR).OR.(MST(23).GE.2.AND. &MST(24).GE.2)) THEN WRITE(MST(20),1500) MST(24),MST(34) IF(MST(25).EQ.1) WRITE(MST(20),1100) IF(MST(25).EQ.2) WRITE(MST(20),1200) IF(MST(25).EQ.3) WRITE(MST(20),1300) IF(MST(25).EQ.4) WRITE(MST(20),1600) IF(MST(25).EQ.5) WRITE(MST(20),1700) ENDIF IF((MST(23).EQ.1.AND.MST(24).GE.5).OR.(MST(23).GE.2.AND. &MST(24).GE.2)) THEN WRITE(MST(20),1800) MST(1)=0 MST(2)=0 CALL LULIST(11) STOP ELSEIF(MST(23).GE.1.AND.MST(24).GT.NERR) THEN RETURN ENDIF IF(IP.LT.N) GOTO 140 C...CHECK THAT MOMENTUM, ENERGY AND CHARGE WERE CONSERVED DO 160 I=1,N IF(K(I,1).GE.20000) GOTO 160 DO 150 J=1,4 150 PSUM(2,J)=PSUM(2,J)+P(I,J) PSUM(2,5)=PSUM(2,5)+LUCHGE(K(I,2)) IF(I.EQ.N) GOTO 160 IF(K(I+1,1)/10000.EQ.6) PSUM(2,5)=PSUM(2,5)+LUCHGE(K(I+1,2)) 160 CONTINUE PDEV=(ABS(PSUM(2,1)-PSUM(1,1))+ABS(PSUM(2,2)-PSUM(1,2))+ &ABS(PSUM(2,3)-PSUM(1,3))+ABS(PSUM(2,4)-PSUM(1,4)))/ &(1.+ABS(PSUM(2,4))+ABS(PSUM(1,4))) IF(ICON.EQ.0.AND.(PDEV.GT.PAR(74).OR.ABS(PSUM(2,5)-PSUM(1,5)). >.0.25)) THEN MST(24)=MST(24)+1 MST(25)=6 ENDIF IF((MST(23).EQ.1.AND.MST(24).GT.NERR).OR.(MST(23).GE.2.AND. &MST(24).GE.2)) THEN WRITE(MST(20),1500) MST(24),MST(34) WRITE(MST(20),1900) ((PSUM(I,J),J=1,4),PSUM(I,5)/3.,I=1,2) ENDIF IF((MST(23).EQ.1.AND.MST(24).GE.5).OR.(MST(23).GE.2.AND. &MST(24).GE.2)) THEN WRITE(MST(20),1800) CALL LULIST(11) STOP ENDIF C...FORMAT STATEMENTS FOR ERROR WARNINGS 1000 FORMAT(/5X,'WARNING! MST(26) FLAG WAS SET AT LUEXEC ', &'CALL NO',I8,'; ERROR TYPE IS') 1100 FORMAT(5X,'1: NOT ENOUGH MEMORY AVAILABLE IN COMMONBLOCK LUJETS') 1200 FORMAT(5X,'2: UNPHYSICAL FLAVOUR SETUP OF JET SYSTEM') 1300 FORMAT(5X,'3: NOT ENOUGH ENERGY AVAILABLE IN JET SYSTEM ', &'(STRING FRAGMENTATION)') 1400 FORMAT(5X,'4: INCONSISTENT KINEMATICS FOR DEFINITION OF JET ', &'CONFIGURATION') 1500 FORMAT(/5X,'WARNING! ERROR NO',I2,' HAS OCCURED IN LUEXEC ', &'CALL NO',I8,'; ERROR TYPE IS') 1600 FORMAT(5X,'4: NOT ENOUGH ENERGY AVAILABLE IN JET SYSTEM ', &'(INDEPENDENT FRAGMENTATION)') 1700 FORMAT(5X,'5: NO KINEMATICALLY ALLOWED DECAYS ARE FOUND FOR ', &'THIS PARTICLE') 1800 FORMAT(5X,'EXECUTION WILL BE STOPPED AFTER PRINTOUT OF ', &'EVENT LISTING') 1900 FORMAT(5X,'6: MOMENTUM, ENERGY AND/OR CHARGE WERE NOT CONSERVED'/ &5X,'SUM OF',9X,'PX',11X,'PY',11X,'PZ',11X,'E',8X,'CHARGE'/ &5X,'BEFORE',2X,4(1X,F12.5),1X,F8.2/5X,'AFTER',3X,4(1X,F12.5),1X, &F8.2) RETURN END C********************************************************************* SUBROUTINE LUPREP COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600) DIMENSION PS(5),PC(5),UE(3) C...REARRANGE PARTON SHOWER PRODUCT LISTING ALONG STRINGS: BEGIN LOOP NS=N DO 120 IQG=1,2 DO 120 I=1,NS-1 IF(K(I+1,1)/10000.NE.7.OR.K(I,1).GE.20000.OR.IABS(K(I,2)).LT. &500.OR.(IQG.EQ.1.AND.IABS(K(I,2)).EQ.500)) GOTO 120 C...PICK UP LOOSE STRING END, COPY UNDECAYED PARTON KCS=(3-ISIGN(1,K(I,2)*(510-IABS(K(I,2)))))/2 IA=I NL=0 100 NL=NL+1 IF(NL.GT.2*NS) THEN MST(26)=2 RETURN ENDIF IF(K(IA,1).LT.20000) THEN N=N+1 IF(N.GE.MST(30)-5-MST(31)) THEN MST(26)=1 RETURN ENDIF K(N,1)=10000 IF(NL.GE.2.AND.IABS(K(IA,2)).GT.500) K(N,1)=0 K(N,1)=K(N,1)+MAX(0,K(IA+1,2)-1000) K(N,2)=K(IA,2) DO 110 J=1,5 110 P(N,J)=P(IA,J) K(IA,1)=K(IA,1)+20000 IF(K(N,1).LT.10000) GOTO 120 ENDIF C...GO TO NEXT PARTON IN COLOUR SPACE IB=IA IF(P(IB+1,KCS+2).GT.0.5) THEN IA=NINT(P(IB+1,KCS+2)) P(IB+1,KCS+2)=-P(IB+1,KCS+2) MM=0 ELSE IF(P(IB+1,KCS).LT.0.5) KCS=3-KCS IA=NINT(P(IB+1,KCS)) P(IB+1,KCS)=-P(IB+1,KCS) MM=1 ENDIF IF(IA.LE.0.OR.IA.GT.MIN(NS,MST(30)-MST(31))) THEN MST(26)=2 RETURN ENDIF IF(NINT(P(IA+1,1)).EQ.IB.OR.NINT(P(IA+1,2)).EQ.IB) THEN IF(MM.EQ.1) KCS=3-KCS IF(NINT(P(IA+1,KCS)).NE.IB) KCS=3-KCS P(IA+1,KCS)=-P(IA+1,KCS) ELSE IF(MM.EQ.0) KCS=3-KCS IF(NINT(P(IA+1,KCS+2)).NE.IB) KCS=3-KCS P(IA+1,KCS+2)=-P(IA+1,KCS+2) ENDIF IF(IA.NE.I) GOTO 100 K(N,1)=K(N,1)-10000 120 CONTINUE IF(MST(21).GE.1) THEN C...DELETE UNNECESSARY PARTON SHOWER EVOLUTION INFORMATION K(N+1,1)=0 I1=0 DO 140 I=1,N KS=K(I,1)/10000 IF(KS.GE.7.OR.(MST(21).GE.3.AND.KS.GE.2.AND.KS.LE.5)) GOTO 140 IF(KS.GE.2.AND.I.LT.N.AND.K(I+1,1)/10000.EQ.7) THEN IF(MST(21).GE.2.AND.KS.NE.6) GOTO 140 IF(KS.LE.3.AND.I.GT.MST(1)) GOTO 140 IF(KS.LE.3) K(I,1)=40000 ENDIF I1=I1+1 K(I1,1)=K(I,1) IF(I.LT.N.AND.K(I+1,1)/10000.EQ.7) K(I1,1)= & 10000*(K(I1,1)/10000)+MAX(0,K(I+1,2)-1000) K(I1,2)=K(I,2) DO 130 J=1,5 130 P(I1,J)=P(I,J) 140 CONTINUE N=I1 ENDIF C...FIND LOWEST-MASS COLOUR SINGLET JET SYSTEM, OK IF ABOVE THRESHOLD IF(MST(12).LE.0) GOTO 310 NS=N 150 NSIN=N-NS PDM=1.+PAR(22) IC=0 DO 200 I=1,NS IF(K(I,1).GE.20000) GOTO 200 IF(K(I,1).GE.10000.AND.IC.EQ.0) THEN NSIN=NSIN+1 IC=I DO 160 J=1,4 160 PS(J)=P(I,J) PS(5)=ULMASS(0,K(I,2)) ELSEIF(K(I,1).GE.10000) THEN DO 170 J=1,4 170 PS(J)=PS(J)+P(I,J) ELSEIF(IC.NE.0) THEN DO 180 J=1,4 180 PS(J)=PS(J)+P(I,J) PS(5)=PS(5)+ULMASS(0,K(I,2)) PD=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))-PS(5) IF(PD.LT.PDM) THEN PDM=PD DO 190 J=1,5 190 PC(J)=PS(J) ICL=IC ICU=I ENDIF IC=0 ELSE NSIN=NSIN+1 ENDIF 200 CONTINUE IF(PDM.GE.PAR(22)) GOTO 310 C...FORM TWO PARTICLES FROM FLAVOURS OF LOWEST-MASS SYSTEM, IF FEASIBLE PCM=SQRT(MAX(0.,PC(4)**2-PC(1)**2-PC(2)**2-PC(3)**2)) K(N+1,1)=ICL K(N+2,1)=ICU IF(K(ICL+1,1)/10000.EQ.6.OR.(ICU.LT.N.AND.K(ICU+1,1)/10000. &EQ.6)) THEN GOTO 310 ELSEIF(IABS(K(ICL,2)).GT.500) THEN IF(MOD(K(ICL,2),500)*MOD(K(ICU,2),500)*(510-IABS(K(ICL,2)))* & (510-IABS(K(ICU,2))).GE.0) GOTO 310 210 CALL LUIFLD(MOD(K(ICL,2),500),0,0,IFLN,K(N+1,2)) IF(IABS(IFLN).GE.100.OR.(IABS(IFLN).GT.10.AND.IABS(K(ICU,2)). & GT.510)) GOTO 210 CALL LUIFLD(MOD(K(ICU,2),500),0,-IFLN,IFLDMP,K(N+2,2)) ELSE IF(IABS(K(ICU,2)).NE.500) GOTO 310 220 CALL LUIFLD(1+INT((2.+PAR(2))*RLU(0)),0,0,IFLN,KDUMP) IF(IABS(IFLN).GE.100) GOTO 220 CALL LUIFLD(IFLN,0,0,IFLM,K(N+1,2)) IF(IABS(IFLM).GE.100) GOTO 220 CALL LUIFLD(-IFLN,0,-IFLM,IFLDMP,K(N+2,2)) ENDIF P(N+1,5)=ULMASS(1,K(N+1,2)) P(N+2,5)=ULMASS(1,K(N+2,2)) IF(P(N+1,5)+P(N+2,5)+DPAR(14).GE.PCM.AND.NSIN.EQ.1) GOTO 310 IF(P(N+1,5)+P(N+2,5)+DPAR(14).GE.PCM) GOTO 260 C...PERFORM TWO-PARTICLE DECAY OF JET SYSTEM, IF POSSIBLE IF(PCM.GE.0.02*PC(4)) THEN PA=SQRT((PCM**2-(P(N+1,5)+P(N+2,5))**2)*(PCM**2- & (P(N+1,5)-P(N+2,5))**2))/(2.*PCM) UE(3)=2.*RLU(0)-1. PHI=PAR(72)*RLU(0) UE(1)=SQRT(1.-UE(3)**2)*COS(PHI) UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI) DO 230 J=1,3 P(N+1,J)=PA*UE(J) 230 P(N+2,J)=-PA*UE(J) P(N+1,4)=SQRT(PA**2+P(N+1,5)**2) P(N+2,4)=SQRT(PA**2+P(N+2,5)**2) MST1S=MST(1) MST(1)=N+1 N=N+2 CALL LUROBO(0.,0.,PC(1)/PC(4),PC(2)/PC(4),PC(3)/PC(4)) MST(1)=MST1S ELSE NP=0 DO 240 I=ICL,ICU 240 IF(K(I,1).LT.20000) NP=NP+1 HA=P(ICL,4)*P(ICU,4)-P(ICL,1)*P(ICU,1)-P(ICL,2)*P(ICU,2)- & P(ICL,3)*P(ICU,3) IF(NP.GE.3.OR.HA.LE.1.25*P(ICL,5)*P(ICU,5)) GOTO 260 HD1=0.5*(P(N+1,5)**2-P(ICL,5)**2) HD2=0.5*(P(N+2,5)**2-P(ICU,5)**2) HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+1,5)*P(N+2,5))**2)/ & (HA**2-(P(ICL,5)*P(ICU,5))**2)))-1. HC=P(ICL,5)**2+2.*HA+P(ICU,5)**2 HK1=((P(ICU,5)**2+HA)*HR+HD1-HD2)/HC HK2=((P(ICL,5)**2+HA)*HR+HD2-HD1)/HC DO 250 J=1,4 P(N+1,J)=(1.+HK1)*P(ICL,J)-HK2*P(ICU,J) 250 P(N+2,J)=(1.+HK2)*P(ICU,J)-HK1*P(ICL,J) N=N+2 ENDIF GOTO 290 C...ELSE FORM ONE PARTICLE FROM THE FLAVOURS AVAILABLE, IF POSSIBLE 260 IF(IABS(K(ICL,2)).GT.510.AND.IABS(K(ICU,2)).GT.510) THEN GOTO 310 ELSEIF(IABS(K(ICL,2)).GT.500) THEN CALL LUIFLD(MOD(K(ICL,2),500),0,MOD(K(ICU,2),500), & IFLDMP,K(N+1,2)) ELSE IFLN=1+INT((2.+PAR(2))*RLU(0)) CALL LUIFLD(IFLN,0,-IFLN,IFLDMP,K(N+1,2)) ENDIF P(N+1,5)=ULMASS(1,K(N+1,2)) C...FIND PARTON/PARTICLE WHICH COMBINES TO LARGEST EXTRA MASS IR=0 HA=0. DO 275 ILP=1,3 IF(IR.NE.0) GOTO 275 DO 270 I=1,N IF(K(I,1).GE.20000.OR.(I.GE.ICL.AND.I.LE.ICU)) GOTO 270 IF(ILP.EQ.1.AND.IABS(K(I,2)).LT.500.AND.I.LE.NS) GOTO 270 IF(ILP.EQ.2.AND.IABS(K(I,2)).LT.17) GOTO 270 PCR=PC(4)*P(I,4)-PC(1)*P(I,1)-PC(2)*P(I,2)-PC(3)*P(I,3) IF(PCR.GT.HA) THEN IR=I HA=PCR ENDIF 270 CONTINUE 275 CONTINUE C...SHUFFLE ENERGY AND MOMENTUM TO PUT NEW PARTICLE ON MASS SHELL HB=PCM**2+HA HC=P(N+1,5)**2+HA HD=P(IR,5)**2+HA HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+1,5)**2)/ &(HA**2-(PCM*P(IR,5))**2))-(HB+HC))/(HB+HD) HK1=(0.5*(P(N+1,5)**2-PCM**2)+HD*HK2)/HB DO 280 J=1,4 P(N+1,J)=(1.+HK1)*PC(J)-HK2*P(IR,J) 280 P(IR,J)=(1.+HK2)*P(IR,J)-HK1*PC(J) N=N+1 C...MARK COLLAPSED SYSTEM, ITERATE 290 DO 300 I=ICL,ICU 300 IF(K(I,1).LE.20000.AND.IABS(K(I,2)).GE.500) K(I,1)=K(I,1)+20000 IF(N.LT.MST(30)-5-MST(31)) GOTO 150 C...CHECK FLAVOURS AND INVARIANT MASSES IN STRING SYSTEMS 310 NP=0 KFN=0 KFS=0 DO 320 J=1,5 320 PS(J)=0. DO 350 I=1,N IF(K(I,1).GE.20000.OR.IABS(K(I,2)).LT.500) GOTO 350 NP=NP+1 IF(IABS(K(I,2)).GT.500) THEN KFN=KFN+1 KFS=KFS+ISIGN(1,K(I,2)*(510-IABS(K(I,2)))) IF(N.GT.I.AND.K(I+1,1)/10000.EQ.6) KFS=KFS+ISIGN(1, & MOD(K(I+1,2),10)) PS(5)=PS(5)+ULMASS(0,K(I,2)) ENDIF DO 330 J=1,4 330 PS(J)=PS(J)+P(I,J) IF(K(I,1).LT.10000) THEN IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KFS.NE.0)) MST(26)=2 IF(NP.NE.1.AND.PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2.LT.(PAR(22)+ & PS(5))**2) MST(26)=3 NP=0 KFN=0 KFS=0 DO 340 J=1,5 340 PS(J)=0. ENDIF 350 CONTINUE RETURN END C********************************************************************* SUBROUTINE LUCONS(IP) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) DIMENSION PS2(4),NFL(3),IFET(3),IFLF(3),TE(3),TD(3,3) DOUBLE PRECISION DPS1(4),DP(4),DBE(3),DGA,DBEP,DGABEP C...RESET COUNTERS, IDENTIFY PARTON SYSTEM, BOOST TO CM FRAME NTRY=0 100 NTRY=NTRY+1 IF(NTRY.GT.200) THEN MST(24)=MST(24)+1 MST(25)=4 IF(MST(23).GE.1) RETURN ENDIF DO 110 J=1,3 NFL(J)=0 IFET(J)=0 110 IFLF(J)=0 IF(NTRY.EQ.1) THEN DO 120 J=1,4 120 DPS1(J)=0. IN=IP-1 NJET=0 130 IN=IN+1 IF(IN.GT.MIN(N,MST(30)-MST(31))) THEN MST(24)=MST(24)+1 MST(25)=2 IF(MST(23).GE.1) RETURN ENDIF IF(K(IN,1).GE.20000.OR.IABS(K(IN,2)).LT.500) GOTO 130 NJET=NJET+1 DO 140 J=1,4 140 DPS1(J)=DPS1(J)+P(IN,J) IF(K(IN,1).GE.10000.OR.(MST(6).LE.4.AND.N.GT.IN.AND. & K(IN+1,1)/10000.EQ.1)) GOTO 130 NSYS=1+IN-IP MST(1)=IP MST(2)=IN DO 150 J=1,3 150 DBE(J)=DPS1(J)/DPS1(4) DGA=1D0/DSQRT(1D0-DBE(1)**2-DBE(2)**2-DBE(3)**2) DO 180 I=IP,IN IF(MOD(K(I,1)/10000,10).GE.6) GOTO 180 DO 160 J=1,4 160 DP(J)=P(I,J) DBEP=-(DBE(1)*DP(1)+DBE(2)*DP(2)+DBE(3)*DP(3)) DGABEP=DGA*(DGA*DBEP/(1D0+DGA)+DP(4)) DO 170 J=1,3 170 P(I,J)=DP(J)-DGABEP*DBE(J) P(I,4)=DGA*(DP(4)+DBEP) 180 CONTINUE C...TAKE OR RESTORE SPARE COPY OF PARTONS BEFORE TREATMENT IF(N+NSYS.GE.MST(30)-5-MST(31)) THEN MST(24)=MST(24)+1 MST(25)=1 IF(MST(23).GE.1) RETURN ENDIF ECM=0. DO 190 I=IP,IN IF(K(I,1).LT.20000.AND.IABS(K(I,2)).GE.500) ECM=ECM+P(I,4) DO 190 J=1,5 190 P(N+1+I-IP,J)=P(I,J) N=N+NSYS NSAV=N ELSE N=NSAV DO 200 I=IP,IN IF(K(I,1).GE.100000) K(I,1)=K(I,1)-120000 DO 200 J=1,5 200 P(I,J)=P(NSAV+I-IN,J) ENDIF IF(MST(6).GE.10.AND.NTRY.EQ.1.AND.NJET.GE.3) THEN C...BOOST TO FRAME WHERE STRING TENSIONS BALANCE FOR MONTVAY SCHEME PHI=ULANGL(P(IP,1),P(IP,2)) CALL LUROBO(0.,-PHI,0.,0.,0.) THE=ULANGL(P(IP,3),P(IP,1)) CALL LUROBO(-THE,0.,0.,0.,0.) CHI=ULANGL(P(IP+1,1),P(IP+1,2)) CALL LUROBO(0.,-CHI,0.,0.,0.) NBAL=0 210 NBAL=NBAL+1 DO 220 J1=1,3 TE(J1)=0. DO 220 J2=1,3 220 TD(J1,J2)=0. DO 240 I=IP,IN IF(K(I,1).GE.20000.OR.IABS(K(I,2)).LT.500) GOTO 240 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) TEN=MIN(1.,PA/PAR(18)) IF(IABS(K(I,2)).EQ.500) TEN=PAR(17)*TEN DO 230 J1=1,3 TE(J1)=TE(J1)+TEN*P(I,J1)/PA TD(J1,J1)=TD(J1,J1)+TEN*P(I,4)/PA DO 230 J2=1,3 230 TD(J1,J2)=TD(J1,J2)-TEN*P(I,4)*P(I,J1)*P(I,J2)/PA**3 240 CONTINUE IF(TE(1)**2+TE(2)**2+TE(3)**2.LT.1E-3) GOTO 260 IF(NBAL.GE.MST(13)) GOTO 100 DO 250 JL=1,2 DO 250 J1=JL+1,3 TE(J1)=TE(J1)-(TD(J1,JL)/TD(JL,JL))*TE(JL) DO 250 J2=JL+1,3 250 TD(J1,J2)=TD(J1,J2)-(TD(J1,JL)/TD(JL,JL))*TD(JL,J2) TE(3)=TE(3)/TD(3,3) TE(2)=(TE(2)-TD(2,3)*TE(3))/TD(2,2) TE(1)=(TE(1)-TD(1,2)*TE(2)-TD(1,3)*TE(3))/TD(1,1) TER=1.+SQRT(TE(1)**2+TE(2)**2+TE(3)**2) CALL LUROBO(0.,0.,-TE(1)/TER,-TE(2)/TER,-TE(3)/TER) GOTO 210 ENDIF C...SUM AND CHECK JET FLAVOURS, FRAGMENT JETS INDEPENDENTLY 260 MST(1)=0 MST(2)=0 KFSUM=0 DO 270 I=IP,IN KFA=IABS(K(I,2)) IF(K(I,1).GE.20000.OR.KFA.LT.500) GOTO 270 IF(KFA.GE.501) KFSUM=KFSUM+ISIGN(1,K(I,2)*(510-KFA)) IFL=MOD(KFA,10) IF(IFL.NE.0.AND.IFL.LE.3) NFL(IFL)=NFL(IFL)+ISIGN(1,K(I,2)) IFL=MOD(KFA,100)/10 IF(IFL.NE.0.AND.IFL.LE.3) NFL(IFL)=NFL(IFL)+ISIGN(1,K(I,2)) IFL=MOD(IABS(K(I+1,2)),10) IF(N.GT.I.AND.K(I+1,1)/10000.EQ.6.AND.IFL.NE.0) THEN KFSUM=KFSUM+ISIGN(1,IFL) NFL(IFL)=NFL(IFL)+ISIGN(1,K(I+1,2)) ENDIF CALL LUONEJ(I) K(I,1)=K(I,1)+100000 270 CONTINUE IF(KFSUM.NE.0) THEN MST(24)=MST(24)+1 MST(25)=2 IF(MST(23).GE.1) RETURN ENDIF IF(MOD(MST(6),5).NE.0.AND.N-NSAV.LT.2) GOTO 100 IF(MST(6).GE.10.AND.NTRY.EQ.1.AND.NJET.GE.3) THEN C...BOOST BACK TO CM FRAME FOR MONTVAY SCHEME DO 280 J=1,4 PS2(J)=0. DO 280 I=IP,IN 280 IF(K(I,1).GE.100000) PS2(J)=PS2(J)+P(I,J) MST(1)=IP MST(2)=IN CALL LUROBO(0.,0.,-PS2(1)/PS2(4),-PS2(2)/PS2(4),-PS2(3)/PS2(4)) PHIR=ULANGL(P(IP,1),P(IP,2)) CALL LUROBO(0.,-PHIR,0.,0.,0.) THER=ULANGL(P(IP,3),P(IP,1)) CALL LUROBO(-THER,0.,0.,0.,0.) CHIR=ULANGL(P(IP+1,1),P(IP+1,2)) CALL LUROBO(0.,-CHIR,0.,0.,0.) CALL LUROBO(0.,CHI,0.,0.,0.) CALL LUROBO(THE,PHI,0.,0.,0.) MST(1)=NSAV+1 MST(2)=0 CALL LUROBO(0.,0.,-PS2(1)/PS2(4),-PS2(2)/PS2(4),-PS2(3)/PS2(4)) CALL LUROBO(0.,-PHIR,0.,0.,0.) CALL LUROBO(-THER,0.,0.,0.,0.) CALL LUROBO(0.,-CHIR,0.,0.,0.) CALL LUROBO(0.,CHI,0.,0.,0.) CALL LUROBO(THE,PHI,0.,0.,0.) MST(1)=0 ENDIF IF(MOD(MST(6),10).NE.0) THEN C...SUBTRACT OFF PRODUCED HADRON FLAVOURS, FINISHED IF ZERO DO 290 I=NSAV+1,N CALL LUIFLV(K(I,2),IFLA,IFLB,IFLC,KSP) IF(IABS(IFLA).LE.3) NFL(IABS(IFLA))=NFL(IABS(IFLA))-ISIGN(1, & IFLA) IF(IABS(IFLB).LE.3) NFL(IABS(IFLB))=NFL(IABS(IFLB))-ISIGN(1, & IFLB) 290 IF(IFLC.NE.0) NFL(IABS(IFLC))=NFL(IABS(IFLC))-ISIGN(1,IFLC) 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 370 C...TAKE AWAY FLAVOUR OF LOW-MOMENTUM PARTICLES UNTIL ENOUGH FREEDOM NREM=0 300 IREM=0 P2MIN=ECM**2 DO 310 I=NSAV+1,N P2=P(I,1)**2+P(I,2)**2+P(I,3)**2 IF(K(I,1).LT.100000.AND.P2.LT.P2MIN) IREM=I 310 IF(K(I,1).LT.100000.AND.P2.LT.P2MIN) P2MIN=P2 IF(IREM.EQ.0) GOTO 100 K(IREM,1)=K(IREM,1)+100000 CALL LUIFLV(K(IREM,2),IFLA,IFLB,IFLC,KSP) IF(IABS(IFLA).GE.4) K(IREM,1)=K(IREM,1)+100000 IF(IABS(IFLA).GE.4) GOTO 300 NFL(IABS(IFLA))=NFL(IABS(IFLA))+ISIGN(1,IFLA) NFL(IABS(IFLB))=NFL(IABS(IFLB))+ISIGN(1,IFLB) IF(IFLC.NE.0) NFL(IABS(IFLC))=NFL(IABS(IFLC))+ISIGN(1,IFLC) 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 300 DO 320 I=NSAV+1,N 320 IF(K(I,1).GE.200000) K(I,1)=K(I,1)-200000 C...GIVE LOW-MOMENTUM PARTICLES NEW FLAVOURS VIA RANDOM COMBINATIONS 330 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 340 J=1,NFET IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0) IFLF(J)=ISIGN(1,NFL(1)) IF(IFET(J).GT.IABS(NFL(1))) IFLF(J)=ISIGN(2,NFL(2)) 340 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) IFLF(J)=ISIGN(3,NFL(3)) IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.IFLF(1)*IFLF(2).GT.0)) & GOTO 330 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR. & IFET(2).EQ.IFET(3).OR.IFLF(1)*IFLF(2).LT.0.OR.IFLF(1)*IFLF(3). & LT.0.OR.IFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 330 IF(NFET.EQ.0) IFLF(1)=1+INT((2.+PAR(2))*RLU(0)) IF(NFET.EQ.0) IFLF(2)=-IFLF(1) IF(NFET.EQ.1) IFLF(2)=ISIGN(1+INT((2.+PAR(2))*RLU(0)),-IFLF(1)) IF(NFET.LE.2) IFLF(3)=0 CALL LUIFLD(IFLF(1),IFLF(3),IFLF(2),IFLDMP,KF) IF(KF.EQ.0) GOTO 330 DO 350 J=1,MAX(2,NFET) 350 NFL(IABS(IFLF(J)))=NFL(IABS(IFLF(J)))-ISIGN(1,IFLF(J)) NPOS=MIN(1+INT(RLU(0)*NREM),NREM) DO 360 I=NSAV+1,N IF(K(I,1).GE.100000) NPOS=NPOS-1 IF(K(I,1).LT.100000.OR.NPOS.NE.0) GOTO 360 K(I,1)=K(I,1)-100000 K(I,2)=KF P(I,5)=ULMASS(1,K(I,2)) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) 360 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 330 ENDIF 370 IF(MOD(MST(6),5).NE.0.AND.MOD(MST(6),5).NE.4) THEN C...COMPENSATE FOR MISSING MOMENTUM IN GLOBAL SCHEME (3 OPTIONS) DO 380 J=1,3 PS2(J)=0. DO 380 I=NSAV+1,N 380 PS2(J)=PS2(J)+P(I,J) PS2(4)=PS2(1)**2+PS2(2)**2+PS2(3)**2 PDS=0. DO 390 I=NSAV+1,N IF(MOD(MST(6),5).EQ.1) PDS=PDS+P(I,4) IF(MOD(MST(6),5).EQ.2) PDS=PDS+SQRT(P(I,5)**2+(PS2(1)*P(I,1)+ & PS2(2)*P(I,2)+PS2(3)*P(I,3))**2/PS2(4)) 390 IF(MOD(MST(6),5).EQ.3) PDS=PDS+1. DO 410 I=NSAV+1,N IF(MOD(MST(6),5).EQ.1) PDM=P(I,4) IF(MOD(MST(6),5).EQ.2) PDM=SQRT(P(I,5)**2+(PS2(1)*P(I,1)+ & PS2(2)*P(I,2)+PS2(3)*P(I,3))**2/PS2(4)) IF(MOD(MST(6),5).EQ.3) PDM=1. DO 400 J=1,3 400 P(I,J)=P(I,J)-PS2(J)*PDM/PDS 410 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) ELSEIF(MOD(MST(6),5).EQ.4) THEN C...COMPENSATE FOR MISSING MOMENTUM WITHIN EACH JET DO 420 I=N+1,N+NSYS K(I,1)=0 DO 420 J=1,5 420 P(I,J)=0. DO 440 I=NSAV+1,N IR1=K(I,1) IR2=N+1+IR1-IP 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 430 J=1,3 430 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J) P(IR2,4)=P(IR2,4)+P(I,4) 440 P(IR2,5)=P(IR2,5)+PLS HSS=0. DO 450 I=N+1,N+NSYS 450 IF(K(I,1).NE.0) HSS=HSS+P(I,4)/(ECM*(0.8*P(I,5)+0.2)) DO 470 I=NSAV+1,N IR1=K(I,1) IR2=N+1+IR1-IP 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 460 J=1,3 460 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*HSS)-1.)*PLS* & P(IR1,J) 470 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) ENDIF IF(MOD(MST(6),5).NE.0) THEN C...SCALE MOMENTA FOR ENERGY CONSERVATION PMS=0. PES=0. PQS=0. DO 480 I=NSAV+1,N PMS=PMS+P(I,5) PES=PES+P(I,4) 480 PQS=PQS+P(I,5)**2/P(I,4) IF(PMS.GE.ECM) GOTO 100 NECO=0 490 NECO=NECO+1 FAC=(ECM-PQS)/(PES-PQS) PES=0. PQS=0. DO 510 I=NSAV+1,N DO 500 J=1,3 500 P(I,J)=FAC*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) 510 PQS=PQS+P(I,5)**2/P(I,4) IF(NECO.LT.10.AND.ABS(ECM-PES).GT.2E-6*ECM) GOTO 490 ENDIF C...BOOST BACK JETS AND PARTICLES, REMOVE SPARE COPY DO 540 I=IP,IN IF(K(I,1).GE.100000) K(I,1)=K(I,1)-100000 IF(MOD(K(I,1)/10000,10).GE.6) GOTO 540 DO 520 J=1,4 520 DP(J)=P(I,J) DBEP=DBE(1)*DP(1)+DBE(2)*DP(2)+DBE(3)*DP(3) DGABEP=DGA*(DGA*DBEP/(1D0+DGA)+DP(4)) DO 530 J=1,3 530 P(I,J)=DP(J)+DGABEP*DBE(J) P(I,4)=DGA*(DP(4)+DBEP) 540 CONTINUE DO 580 I=NSAV+1,N K(I-NSYS,1)=K(I,1) K(I-NSYS,2)=K(I,2) DO 550 J=1,5 550 P(I-NSYS,J)=P(I,J) IF(MOD(K(I,1)/10000,10).GE.6) GOTO 580 DO 560 J=1,4 560 DP(J)=P(I,J) DBEP=DBE(1)*DP(1)+DBE(2)*DP(2)+DBE(3)*DP(3) DGABEP=DGA*(DGA*DBEP/(1D0+DGA)+DP(4)) DO 570 J=1,3 570 P(I-NSYS,J)=DP(J)+DGABEP*DBE(J) P(I-NSYS,4)=DGA*(DP(4)+DBEP) 580 CONTINUE N=N-NSYS RETURN END C********************************************************************* SUBROUTINE LUONEJ(IP) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) DIMENSION IFLF(3),IFLO(2),PXO(2),PYO(2),ZO(2),WO(2) C...INITIAL FLAVOUR AND MOMENTUM VALUES, JET ALONG +Z AXIS MST(1)=N+1 IFLF(1)=MOD(K(IP,2),500) IFLF(2)=0 IFLF(3)=0 IFLO(2)=0 WF=P(IP,4)+SQRT(P(IP,1)**2+P(IP,2)**2+P(IP,3)**2) ZJ=0. ZI=0. 100 IF(IFLF(1).EQ.0.AND.MST(5).LE.2) THEN C...INITIAL VALUES AND FIRST RANK HADRON IN GLUON JET (LUND MODEL) NS=2 I=N+1 K(I,1)=IP CALL LUIFLD(INT(1.+(2.+PAR(2))*RLU(0)),0,0,IFLO(1),KDUMP) CALL LUIFLD(-INT(1.+(2.+PAR(2))*RLU(0)),0,0,IFLO(2),KDUMP) IF(IABS(IFLO(2)).LT.100) IFLO(2)=-MOD(IFLO(1),100) IF(IABS(IFLO(2)).GT.100) IFLO(1)=-MOD(IFLO(2),100) CALL LUIFLD(IFLO(1),0,0,IFL1,K(I,2)) IFLO(1)=-IFL1 P(I,5)=ULMASS(1,K(I,2)) CALL LUPTDI(IFLO(1),PXO(1),PYO(1)) CALL LUPTDI(IFLO(2),PXO(2),PYO(2)) PR=P(I,5)**2+(PXO(1)+PXO(2))**2+(PYO(1)+PYO(2))**2 PRDIV=RLU(0)*PR DO 110 JT=1,2 CALL LUZDIS(IFLO(JT),0,0.6*((2-JT)*PR+(2*JT-3)*PRDIV),ZO(JT)) 110 WO(JT)=0.5*(1.-ZO(JT))*WF C...FOUR-MOMENTUM FOR HADRON, OPTIONALLY SKIP IT IF MOVING BACKWARDS P(I,1)=-(PXO(1)+PXO(2)) P(I,2)=-(PYO(1)+PYO(2)) P(I,3)=0.25*(ZO(1)+ZO(2))*WF-PR/((ZO(1)+ZO(2))*WF) P(I,4)=0.25*(ZO(1)+ZO(2))*WF+PR/((ZO(1)+ZO(2))*WF) IF(MST(5).GE.2.AND.MST(6).GE.0.AND.P(I,3).LT.0.) I=I-1 N=I ELSEIF(IFLF(1).EQ.0.AND.(MST(5).EQ.3.OR.MST(5).EQ.4)) THEN C...GLUON TREATED LIKE RANDOM QUARK (OR ANTIQUARK) JET NS=1 IF(MST(5).EQ.4) MST(32)=1 IFLO(1)=INT(1.+(2.+PAR(2))*RLU(0))*(-1)**INT(RLU(0)+0.5) CALL LUPTDI(93,PXO(1),PYO(1)) WO(1)=WF ELSEIF(IFLF(1).EQ.0.AND.MST(5).GE.5) THEN C...GLUON TREATED LIKE QUARK-ANTIQUARK JET PAIR, SHARING ENERGY C...ACCORDING TO ALTARELLI-PARISI SPLITTING FUNCTION NS=2 IF(MST(5).EQ.6) MST(32)=1 IFLO(1)=INT(1.+(2.+PAR(2))*RLU(0))*(-1)**INT(RLU(0)+0.5) IFLO(2)=-IFLO(1) CALL LUPTDI(93,PXO(1),PYO(1)) PXO(2)=-PXO(1) PYO(2)=-PYO(1) WO(1)=WF*RLU(0)**(1./3.) WO(2)=WF-WO(1) ELSE C...INITIAL VALUES FOR QUARK, DIQUARK OR HADRON JET NS=1 IFLO(1)=IFLF(1) CALL LUPTDI(93,PXO(1),PYO(1)) WO(1)=WF IF(MOD(MST(10),2).EQ.1.AND.IABS(IFLF(1)).GT.10) THEN C...ORDER AND POSITION OF QUARKS IN DIQUARK (L AND J QUARKS) IFLA=IFLF(1)/10 IFLB=IFLF(1)-10*IFLA IFLF(2)=IFLA+INT(RLU(0)+0.5)*(IFLB-IFLA) IF(N.GT.IP.AND.K(IP+1,1)/10000.EQ.6.AND.IABS(K(IP+1,2)).GE. & 610) IFLF(2)=MOD(K(IP+1,2)/10,10) IFLO(1)=IFLA+IFLB-IFLF(2) CALL LUZDIS(0,1,0.,ZJ) IF(N.GT.IP.AND.K(IP+1,1)/10000.EQ.6) P(IP+1,1)=ZJ ENDIF C...FLAVOUR AND POSITION OF EXTRA QUARK IN HADRON JET (I QUARK) IF(N.GT.IP.AND.K(IP+1,1)/10000.EQ.6) IFLF(3)=MOD(K(IP+1,2),10) IF(IFLF(3).NE.0) THEN CALL LUZDIS(0,2+(90+IABS(IFLF(1)))/100,0.,ZI) IF(IABS(IFLF(1)).GT.10.AND.MOD(MST(10),2).EQ.1) ZI=ZI*ZJ P(IP+1,3)=ZI ENDIF ENDIF C...INITIAL VALUES FOR RANK, FLAVOUR, PT (INCLUDING RELATIVE PT C...IN DIQUARK) AND LONGITUDINAL FRAGMENTATION VARIABLES DO 140 JT=1,NS 120 I=N LRK=0 IFL1=IFLO(JT) IFLJ=IFLF(2) IFLI=IFLF(3) IF(IFLJ.EQ.0) THEN PX1=PXO(JT) PY1=PYO(JT) PXJ=0. PYJ=0. ELSE CALL LUPTDI(94,PXR,PYR) PX1=0.5*PXO(JT)+PXR PY1=0.5*PYO(JT)+PYR PXJ=0.5*PXO(JT)-PXR PYJ=0.5*PYO(JT)-PYR IF(N.GT.IP.AND.K(IP+1,1)/10000.EQ.6) P(IP+1,2)=0. ENDIF IF(IFLF(3).NE.0) P(IP+1,4)=0. W=WO(JT) C...NEW HADRON: GENERATE PT 130 I=I+1 IF(I.GE.MST(30)-5-MST(31)) THEN MST(24)=MST(24)+1 MST(25)=1 IF(MST(23).GE.1) RETURN ENDIF LRK=LRK+1 K(I,1)=IP CALL LUPTDI(IFL1,PX2,PY2) MQJ=0 MQI=0 C...CHECK IF J OR I QUARK TO BE INCLUDED, GENERATE FLAVOUR AND HADRON IF(IFLJ.NE.0.OR.IFLI.NE.0) THEN PRJI=PAR(37)**2+(PX1+PX2)**2+(PY1+PY2)**2 CALL LUZDIS(IFL1,IFLJ+IFLI,PRJI,Z) IF(IFLJ.NE.0.AND.(1.-Z)*W.LE.ZJ*WF) MQJ=1 IF(MQJ.EQ.1.AND.IABS(IFL1).GT.10) GOTO 120 IF(MQJ.EQ.1.AND.LRK.EQ.1) IFL1=IFLF(1) IF(IFLI.NE.0.AND.(1.-Z)*W.LE.ZI*WF) MQI=1 IF(MQI.EQ.1.AND.IABS(IFL1).GT.100) GOTO 120 ENDIF CALL LUIFLD(IFL1,MQJ*IFLJ,MQI*IFLI,IFL2,K(I,2)) IF(K(I,2).EQ.0) GOTO 120 P(I,5)=ULMASS(1,K(I,2)) PR=P(I,5)**2+(PX1+PX2+MQJ*PXJ)**2+(PY1+PY2+MQJ*PYJ)**2 C...FOUR-MOMENTUM FOR HADRON, OPTIONALLY SKIP IT IF MOVING BACKWARDS; C...POSITION OF J AND I QUARK IF(IFLJ.EQ.0.AND.IFLI.EQ.0) THEN CALL LUZDIS(IFL1,0,PR,Z) ELSEIF(MST(4).EQ.1.OR.MST(4).EQ.3) THEN GAMJI=(1.+PAR(35))/PAR(36) ZBC=(PR-PRJI-Z*GAMJI+PRJI/Z)/(2.*GAMJI) Z=SQRT(ZBC**2+PR/GAMJI)-ZBC ENDIF P(I,1)=PX1+PX2+MQJ*PXJ P(I,2)=PY1+PY2+MQJ*PYJ P(I,3)=0.5*(Z*W-PR/(Z*W)) P(I,4)=0.5*(Z*W+PR/(Z*W)) IF(MOD(MST(6),10).GT.0.AND.LRK.EQ.1.AND.MAX(MOD(IABS(IFLF(1)), &10),IABS(IFLF(1))/10).GE.4.AND.P(I,3).LE.0.001) THEN IF(W.GE.P(I,5)+0.5*PAR(22)) GOTO 120 P(I,3)=0.0001 P(I,4)=SQRT(PR) Z=P(I,4)/W ENDIF IF(MST(5).GE.2.AND.MST(6).GE.0.AND.P(I,3).LT.0.) I=I-1 IF(I.EQ.N+LRK.AND.MQJ*N.GT.IP.AND.K(IP+1,1)/10000.EQ.6) &P(IP+1,2)=I IF(I.EQ.N+LRK.AND.MQI.EQ.1) P(IP+1,4)=I C...REMAINING FLAVOUR AND MOMENTUM, GO BACK AND GENERATE NEW HADRON IFL1=-IFL2 IF(MQI.EQ.1) CALL LUIFLD((-1)**INT(RLU(0)+0.5),0,0,IFL1,KDUMP) IF(MQJ.EQ.1) IFLJ=0 IF(MQI.EQ.1) IFLI=0 PX1=-PX2 PY1=-PY2 W=(1.-Z)*W IF(MST(10).LE.1.AND.W.GT.PAR(21)) GOTO 130 IF(MST(10).GE.2.AND.(IFLJ.NE.0.OR.IFLI.NE.0)) GOTO 130 140 N=I C...ROTATE JET TO RIGHT DIRECTION IF(MOD(MST(6),5).EQ.4.AND.MST(1).EQ.N+1) WF=WF+0.1*PAR(22) IF(MOD(MST(6),5).EQ.4.AND.MST(1).EQ.N+1) GOTO 100 THE=ULANGL(P(IP,3),SQRT(P(IP,1)**2+P(IP,2)**2)) PHI=ULANGL(P(IP,1),P(IP,2)) CALL LUROBO(THE,PHI,0.,0.,0.) MST(1)=0 MST(32)=0 K(IP,1)=K(IP,1)+20000 RETURN END C********************************************************************* SUBROUTINE LUSYSJ(IP) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) DIMENSION PS(5),IFL(3),PX(4),PY(4),GAM(3),PR(2),IN(9),HM(4),HG(4), &LRK(2),IE(2),IFLF(3),IFLJ(2),IFLI(2),PXJ(2),PYJ(2),ZJ(2),ZI(2), &ZPOS(2),PMQ(3) DOUBLE PRECISION DP(5,5),DFOUR,HKC,HKS,HK1,HK2,HC12,HCX1,HCX2, &HCXX,HCY1,HCY2,HCYX,HCYY 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...BEGIN KINEMATICS DEFINITION: IDENTIFY JETS IN SYSTEM NTRY=0 NP=0 DO 100 J=1,5 100 PS(J)=0. I=IP-1 110 I=I+1 IF(I.GT.MIN(N,MST(30)-NP-5-MST(31))) THEN MST(24)=MST(24)+1 MST(25)=2 IF(I.LE.N) MST(25)=1 IF(MST(23).GE.1) RETURN ENDIF IF(K(I,1).GE.20000.OR.IABS(K(I,2)).LT.500) GOTO 110 NP=NP+1 K(N+NP,1)=I K(N+NP,2)=K(I,2) DO 120 J=1,5 P(N+NP,J)=P(I,J) 120 PS(J)=PS(J)+P(I,J) 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) PS(4)=PS(4)+MAX(0.,P(N+NP,4)-P(I,4)) ENDIF IF(K(I,1).GE.10000) GOTO 110 C...BOOST TO CM FRAME FOR RAPIDLY MOVING SYSTEM MBST=0 IF(PS(1)**2+PS(2)**2+PS(3)**2.GT.0.5*PS(4)**2) THEN MBST=1 PEBST=MAX(PS(4),1.0001*SQRT(PS(1)**2+PS(2)**2+PS(3)**2)) MST(1)=N+1 MST(2)=N+NP CALL LUROBO(0.,0.,-PS(1)/PEBST,-PS(2)/PEBST,-PS(3)/PEBST) ENDIF C...SEARCH FOR VERY NEARBY PARTONS THAT MAY BE RECOMBINED NR=NP 130 IF(NR.LE.2) GOTO 180 DRMIN=2.*PAR(59) DO 140 I=N+1,N+NR IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.500) GOTO 140 I1=I+1-NR*(I/(N+NR)) 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) DR=4.*(PAP-PVP)**2/(PAR(60)**2*PAP+2.*(PAP-PVP)) IF(DR.LT.DRMIN) THEN IR=I DRMIN=DR ENDIF 140 CONTINUE C...RECOMBINE VERY NEARBY PARTONS TO AVOID MACHINE PRECISION PROBLEMS IF(DRMIN.LT.PAR(59).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(DRMIN.LT.PAR(59)) 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 GOTO 130 ENDIF 180 IF(N+5*NR+11.GE.MST(30)-5-MST(31)) THEN MST(24)=MST(24)+1 MST(25)=1 IF(MST(23).GE.1) RETURN ENDIF C...OPEN VERSUS CLOSED STRINGS, CHOOSE BREAKUP REGION FOR LATTER IF(IABS(K(N+1,2)).NE.500) THEN NS=NR-1 NB=1 ELSE NS=NR+1 W2SUM=0. DO 190 IS=1,NR P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR)) 190 W2SUM=W2SUM+P(N+NR+IS,1) W2RAN=RLU(0)*W2SUM NB=0 200 NB=NB+1 W2SUM=W2SUM-P(N+NR+NB,1) IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 200 ENDIF C...FIND LONGITUDINAL STRING DIRECTIONS (I.E. LIGHTLIKE FOUR-VECTORS) DO 220 IS=1,NS IS1=N+IS+NB-1-NR*((IS+NB-2)/NR) IS2=N+IS+NB-NR*((IS+NB-1)/NR) DO 210 J=1,5 DP(1,J)=P(IS1,J) IF(IABS(K(IS1,2)).EQ.500) DP(1,J)=0.5*DP(1,J) DP(2,J)=P(IS2,J) 210 IF(IABS(K(IS2,2)).EQ.500) DP(2,J)=0.5*DP(2,J) DP(3,5)=DFOUR(1,1) DP(4,5)=DFOUR(2,2) HKC=DFOUR(1,2) IF(DP(3,5)+2.*HKC+DP(4,5).LE.0.) THEN DP(3,5)=DP(1,5)**2 DP(4,5)=DP(2,5)**2 DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2) DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2) HKC=DFOUR(1,2) ENDIF HKS=DSQRT(HKC**2-DP(3,5)*DP(4,5)) HK1=0.5*((DP(4,5)+HKC)/HKS-1.) HK2=0.5*((DP(3,5)+HKC)/HKS-1.) IN1=N+NR+4*IS-3 P(IN1,5)=SQRT(DP(3,5)+2.*HKC+DP(4,5)) DO 220 J=1,4 P(IN1,J)=(1.+HK1)*DP(1,J)-HK2*DP(2,J) 220 P(IN1+1,J)=(1.+HK2)*DP(2,J)-HK1*DP(1,J) NRS=NR+4*NS+7 C...BEGIN INITIALIZATION: SUM UP ENERGY, SET STARTING POSITIONS 230 NTRY=NTRY+1 IF(NTRY.GT.200) THEN MST(24)=MST(24)+1 MST(25)=3 IF(MST(23).GE.1) RETURN ENDIF I=N+NRS DO 240 J=1,4 P(I,J)=0. DO 240 IS=1,NR 240 P(I,J)=P(I,J)+P(N+IS,J) DO 250 JT=1,2 LRK(JT)=0 IE(JT)=K(N+1+(JT/2)*(NP-1),1) IFLJ(JT)=0 IFLI(JT)=0 PXJ(JT)=0. PYJ(JT)=0. ZJ(JT)=0. ZI(JT)=0. ZPOS(JT)=1. 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 250 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4 P(IN1,1)=2-JT P(IN1,2)=JT-1 250 P(IN1,3)=1. IFLSTR=0 IF(NS.EQ.NR-1) THEN C...INITIALIZE FLAVOUR AND PT VARIABLES FOR OPEN STRING PX(1)=0. PY(1)=0. IF(NS.EQ.1) CALL LUPTDI(93,PX(1),PY(1)) PX(2)=-PX(1) PY(2)=-PY(1) KFSUM=0 DO 260 JT=1,2 IFLF(JT)=MOD(K(IE(JT),2),500) KFSUM=KFSUM+ISIGN(1,IFLF(JT)*(10-IABS(IFLF(JT)))) IFL(JT)=IFLF(JT) GAM(JT)=0. C...ORDER AND POSITION OF QUARKS IN DIQUARK, RELATIVE PT IN DIQUARK IF(MOD(MST(10),2).EQ.1.AND.IABS(IFLF(JT)).GE.10) THEN IFLA=IFLF(JT)/10 IFLB=IFLF(JT)-10*IFLA IFLJ(JT)=IFLA+INT(RLU(0)+0.5)*(IFLB-IFLA) IF(N.GT.IE(JT).AND.K(IE(JT)+1,1)/10000.EQ.6.AND.IABS(K(IE(JT)+ & 1,2)).GE.610) IFLJ(JT)=MOD(K(IE(JT)+1,2)/10,10) IFL(JT)=IFLA+IFLB-IFLJ(JT) CALL LUZDIS(0,1,0.,ZJ(JT)) CALL LUPTDI(94,PXR,PYR) PX(JT)=0.5*PX(JT)+PXR PY(JT)=0.5*PY(JT)+PYR PXJ(JT)=PX(JT)-2.*PXR PYJ(JT)=PY(JT)-2.*PYR IF(N.GT.IE(JT).AND.K(IE(JT)+1,1)/10000.EQ.6) P(IE(JT)+1,1)= & ZJ(JT) ENDIF PMQ(JT)=ULMASS(2,IFL(JT)) C...FLAVOUR AND POSITION OF EXTRA QUARKS IN HADRON JETS (I QUARKS) IF(N.GT.IE(JT).AND.K(IE(JT)+1,1)/10000.EQ.6) IFLI(JT)= & MOD(K(IE(JT)+1,2),10) IF(IFLI(JT).NE.0) THEN KFSUM=KFSUM+ISIGN(1,IFLI(JT)) CALL LUZDIS(0,2+(90+IABS(IFLF(JT)))/100,0.,ZI(JT)) IF(IABS(IFLF(JT)).GT.10.AND.MOD(MST(10),2).EQ.1) ZI(JT)= & ZI(JT)*ZJ(JT) P(IE(JT)+1,3)=ZI(JT) ENDIF CALL LUIFLD(INT(1.+(2.+PAR(2))*RLU(0))*(-1)**INT(RLU(0)+0.5), & 0,0,IFLF(3),KDUMP) 260 IFLF(3)=MOD(IFLF(3),100) IF(KFSUM.NE.0) THEN MST(24)=MST(24)+1 MST(25)=2 IF(MST(23).GE.1) RETURN ENDIF ELSE C...CLOSED STRING: RANDOM INITIAL BREAKUP FLAVOUR, PT AND VERTEX IFL(3)=INT(1.+(2.+PAR(2))*RLU(0))*(-1)**INT(RLU(0)+0.5) CALL LUIFLD(IFL(3),0,0,IFL(1),KDUMP) CALL LUIFLD(-IFL(3),0,0,IFL(2),KDUMP) IF(IABS(IFL(2)).LT.100) IFL(2)=-MOD(IFL(1),100) IF(IABS(IFL(2)).GT.100) IFL(1)=-MOD(IFL(2),100) IFLSTR=(IABS(IFL(1))+90)/100 CALL LUPTDI(IFL(1),PX(1),PY(1)) PX(2)=-PX(1) PY(2)=-PY(1) PR3=MIN(25.,0.1*P(N+NR+1,5)**2) 270 CALL LUZDIS(IFL(1),0,PR3,Z) ZR=PR3/(Z*P(N+NR+1,5)**2) IF(ZR.GE.1.) GOTO 270 DO 280 JT=1,2 PMQ(JT)=ULMASS(2,IFL(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 280 P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR ENDIF C...FIND INITIAL TRANSVERSE DIRECTIONS (I.E. SPACELIKE FOUR-VECTORS) DO 320 JT=1,2 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN IN1=IN(3*JT+1) IN3=IN(3*JT+3) DO 290 J=1,4 DP(1,J)=P(IN1,J) DP(2,J)=P(IN1+1,J) DP(3,J)=0. 290 DP(4,J)=0. DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) DP(2,4)=DSQRT(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. HC12=DFOUR(1,2) HCX1=DFOUR(3,1)/HC12 HCX2=DFOUR(3,2)/HC12 HCXX=1./DSQRT(1.+2.*HCX1*HCX2*HC12) HCY1=DFOUR(4,1)/HC12 HCY2=DFOUR(4,2)/HC12 HCYX=HCXX*(HCX1*HCY2+HCX2*HCY1)*HC12 HCYY=1./DSQRT(1.+2.*HCY1*HCY2*HC12-HCYX**2) DO 300 J=1,4 DP(3,J)=HCXX*(DP(3,J)-HCX2*DP(1,J)-HCX1*DP(2,J)) P(IN3,J)=DP(3,J) 300 P(IN3+1,J)=HCYY*(DP(4,J)-HCY2*DP(1,J)-HCY1*DP(2,J)- & HCYX*DP(3,J)) ELSE DO 310 J=1,4 P(IN3+2,J)=P(IN3,J) 310 P(IN3+3,J)=P(IN3+1,J) ENDIF 320 CONTINUE C...PRODUCE NEW PARTICLE: SIDE, PT 330 I=I+1 IF(I.GE.MST(30)-5-MST(31)) THEN MST(24)=MST(24)+1 MST(25)=1 IF(MST(23).GE.1) RETURN ENDIF JT=1.5+RLU(0) IF(IABS(IFL(3-JT)).GT.100) JT=3-JT LRK(JT)=LRK(JT)+1 JR=3-JT JS=3-2*JT K(I,1)=IE(JT) CALL LUPTDI(IFL(JT),PX(3),PY(3)) PX(4)=PX(3) PY(4)=PY(3) MQJ=0 MQI=0 C...CHECK IF J OR I QUARK TO BE INCLUDED, GENERATE FLAVOUR AND HADRON IF(IFLJ(JT).NE.0.OR.IFLI(JT).NE.0) THEN PRJI=PAR(37)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2 CALL LUZDIS(IFL(JT),IFLJ(JT)+IFLI(JT),PRJI,Z) IF(IFLJ(JT).NE.0.AND.(1.-Z)*ZPOS(JT).LE.ZJ(JT)) MQJ=1 IF(MQJ.EQ.1.AND.IABS(IFL(JT)).GT.10) GOTO 230 IF(MQJ.EQ.1.AND.LRK(JT).EQ.1) IFL(JT)=IFLF(JT) IF(MQJ.EQ.1.AND.LRK(JT).EQ.1) PMQ(JT)=ULMASS(2,IFL(JT)) IF(IFLI(JT).NE.0.AND.(1.-Z)*ZPOS(JT).LE.ZI(JT)) MQI=1 IF(MQI.EQ.1.AND.IABS(IFL(JT)).GT.100) GOTO 230 IF(MQJ.EQ.1) PX(JT)=PX(JT)+PXJ(JT) IF(MQJ.EQ.1) PY(JT)=PY(JT)+PYJ(JT) IF(MQJ*N.GT.IE(JT).AND.K(IE(JT)+1,1)/10000.EQ.6) P(IE(JT)+1,2)= & I-NRS IF(MQI.EQ.1) P(IE(JT)+1,4)=I-NRS ENDIF CALL LUIFLD(IFL(JT),MQJ*IFLJ(JT),MQI*IFLI(JT),IFL(3),K(I,2)) IF(K(I,2).EQ.0) GOTO 230 PMQ(3)=ULMASS(2,IFL(3)) C...FINAL HADRONS FOR SMALL INVARIANT MASS, PARTICLE MASS WMIN=PAR(22+MST(4))+PMQ(1)+PMQ(2)+PAR(26)*PMQ(3) IF(IFLJ(JT).NE.0.AND.MQJ.EQ.0) WMIN=WMIN+ULMASS(2,IFLJ(JT)) IF(IFLJ(JR).NE.0) WMIN=WMIN+ULMASS(2,IFLJ(JR)) IF(IABS(IFL(JT)).GT.100) WMIN=WMIN+PAR(26)*(ULMASS(2,MST(33))- &PMQ(3)) WREM2=FOUR(N+NRS,N+NRS) IF(WREM2.LT.0.10) GOTO 230 IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PAR(27)), &PAR(22)+PMQ(1)+PMQ(2))**2) GOTO 460 P(I,5)=ULMASS(1,K(I,2)) PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2 C...CHOOSE Z (GIVES GAMMA), SHIFT Z FOR HEAVY FLAVOURS, I AND J QUARKS IF(IFLJ(JT).EQ.0.AND.IFLI(JT).EQ.0) THEN CALL LUZDIS(IFL(JT),0,PR(JT),Z) IF(MAX(MOD(IABS(IFL(1)),10),MOD(IABS(IFL(2)),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)+PAR(22+MST(4)))**2+(PX(JR)-PX(3))**2+ & (PY(JR)-PY(3))**2 IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 460 ENDIF ELSEIF(MST(4).EQ.1.OR.MST(4).EQ.3) THEN GAMJI=(1.+PAR(35))/PAR(36) ZBC=(PR(JT)-PRJI-Z*GAMJI+PRJI/Z)/(2.*GAMJI) Z=SQRT(ZBC**2+PR(JT)/GAMJI)-ZBC ENDIF GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z) DO 340 J=1,3 340 IN(J)=IN(3*JT+J) C...STEPPING WITHIN OR FROM 'LOW' 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 350 J=1,4 350 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J) GOTO 420 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 230 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 FOUR-VECTORS) 360 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 230 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) 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)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) HC12=DFOUR(1,2) IF(HC12.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 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. HCX1=DFOUR(3,1)/HC12 HCX2=DFOUR(3,2)/HC12 HCXX=1./DSQRT(1.+2.*HCX1*HCX2*HC12) HCY1=DFOUR(4,1)/HC12 HCY2=DFOUR(4,2)/HC12 HCYX=HCXX*(HCX1*HCY2+HCX2*HCY1)*HC12 HCYY=1./DSQRT(1.+2.*HCY1*HCY2*HC12-HCYX**2) DO 380 J=1,4 DP(3,J)=HCXX*(DP(3,J)-HCX2*DP(1,J)-HCX1*DP(2,J)) P(IN(3),J)=DP(3,J) 380 P(IN(3)+1,J)=HCYY*(DP(4,J)-HCY2*DP(1,J)-HCY1*DP(2,J)- & HCYX*DP(3,J)) C...EXPRESS PT WITH RESPECT TO NEW AXES IF SENSIBLE PX(3)=-(PX(4)*FOUR(IN(3*JT+3),IN(3))+PY(4)* & FOUR(IN(3*JT+3)+1,IN(3))) PY(3)=-(PX(4)*FOUR(IN(3*JT+3),IN(3)+1)+PY(4)* & FOUR(IN(3*JT+3)+1,IN(3)+1)) IF(ABS(PX(3)**2+PY(3)**2-PX(4)**2-PY(4)**2).GT.0.01) THEN PX(3)=PX(4) PY(3)=PY(4) ENDIF ENDIF C...SUM UP KNOWN FOUR-MOMENTUM, GIVES COEFFICIENTS FOR M2 EXPRESSION DO 400 J=1,4 HG(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 390 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS 390 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) DO 400 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS 400 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) HM(1)=FOUR(I,I) HM(2)=2.*FOUR(I,IN(1)) HM(3)=2.*FOUR(I,IN(2)) HM(4)=2.*FOUR(IN(1),IN(2)) C...FIND COEFFICIENTS FOR GAMMA EXPRESSION DO 410 IN2=IN(1)+1,IN(2),4 DO 410 IN1=IN(1),IN2-1,4 HC=2.*FOUR(IN1,IN2) HG(1)=HG(1)+P(IN1+2,JT)*P(IN2+2,JT)*HC IF(IN1.EQ.IN(1)) HG(2)=HG(2)-JS*P(IN2+2,JT)*HC IF(IN2.EQ.IN(2)) HG(3)=HG(3)+JS*P(IN1+2,JT)*HC 410 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) HG(4)=HG(4)-HC C...SOLVE MASS-SQUARE, GAMMA EQUATION SYSTEM FOR ENERGIES TAKEN HS1=HM(JR+1)*HG(4)-HM(4)*HG(JR+1) IF(ABS(HS1).LT.1E-4) GOTO 230 HS2=HM(4)*(GAM(3)-HG(1))-HM(JT+1)*HG(JR+1)-HG(4)* &(P(I,5)**2-HM(1))+HG(JT+1)*HM(JR+1) HS3=HM(JT+1)*(GAM(3)-HG(1))-HG(JT+1)*(P(I,5)**2-HM(1)) P(IN(JR)+2,4)=0.5*(SQRT(MAX(0.,HS2**2-4.*HS1*HS3))/ABS(HS1)- &HS2/HS1) IF(HM(JT+1)+HM(4)*P(IN(JR)+2,4).LE.0.) GOTO 230 P(IN(JT)+2,4)=(P(I,5)**2-HM(1)-HM(JR+1)*P(IN(JR)+2,4))/ &(HM(JT+1)+HM(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 230 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 360 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 360 ENDIF C...FOUR-MOMENTUM OF PARTICLE, REMAINING QUANTITIES, 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 P(N+NRS,J)=P(N+NRS,J)-P(I,J) IF(P(I,4).LE.0.) GOTO 230 IFL(JT)=-IFL(3) PMQ(JT)=PMQ(3) IF(MQI.EQ.1) IFL(JT)=IFLF(3)*(-1)**JT IF(MQI.EQ.1) PMQ(JT)=ULMASS(2,IFL(JT)) IF(MQJ.EQ.1) IFLJ(JT)=0 IF(MQI.EQ.1) IFLI(JT)=0 ZPOS(JT)=(1.-Z)*ZPOS(JT) PX(JT)=-PX(3) PY(JT)=-PY(3) GAM(JT)=GAM(3) IF(IN(3).NE.IN(3*JT+3)) THEN DO 440 J=1,4 P(IN(3*JT+3),J)=P(IN(3),J) 440 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J) ENDIF DO 450 JQ=1,2 IN(3*JT+JQ)=IN(JQ) P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) 450 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4) GOTO 330 C...FINAL TWO HADRONS: SIDE INFORMATION FOR LAST ONE 460 IF(MAX(IABS(IFL(JR)),IABS(IFL(3))).GT.100) GOTO 230 DO 470 JF=JT,JR,JS IF(JF.EQ.JR) I=I+1 IF(JF.EQ.JR) LRK(JF)=LRK(JF)+1 IF(JF.EQ.JR) K(I,1)=IE(JF) C...ACCEPT GENERATED FLAVOUR WHEN NO J OR I QUARKS REMAINING IF(JF.EQ.JT.AND.(1-MQJ)*IFLJ(JF).EQ.0.AND.(1-MQI)*IFLI(JF). &EQ.0.AND.IFLI(3-JF).EQ.0) THEN ELSEIF(JF.EQ.JR.AND.IFLJ(JF).EQ.0.AND.IFLI(JF).EQ.0.AND. &IFLI(3-JF).EQ.0) THEN IF(MIN(IABS(IFL(JF)),IABS(IFL(3))).GT.10) GOTO 230 CALL LUIFLD(IFL(JF),0,-IFL(3),IFLDMP,K(I,2)) C...ELSE GENERATE NEW FLAVOUR INCLUDING J AND I QUARKS ELSE IF(IABS(IFL(JF)).GT.100) GOTO 230 IF(IFLJ(JF).NE.0.AND.IABS(IFL(JF)).GT.10) GOTO 230 IF(IFLJ(JF).NE.0.AND.LRK(JF).EQ.1) IFL(JF)=IFLF(JF) IFL3=IFLI(JF) IF(JF.EQ.JR.AND.IFL3.EQ.0) IFL3=-IFL(3) IF(IFLI(JF).EQ.0.AND.IFLI(3-JF).NE.0) IFL3=-IFLF(3)*(-1)**JF IF((IABS(IFL(JF)).GT.10.OR.IFLJ(JF).NE.0).AND.IABS(IFL3).GT.10) & GOTO 230 CALL LUIFLD(IFL(JF),IFLJ(JF),IFL3,IFL(3),K(I,2)) IF(K(I,2).EQ.0) GOTO 230 IF(IFLJ(JF).NE.0.AND.MQJ*JF.NE.JT) PX(JF)=PX(JF)+PXJ(JF) IF(IFLJ(JF).NE.0.AND.MQJ*JF.NE.JT) PY(JF)=PY(JF)+PYJ(JF) IF(IFLJ(JF).NE.0.AND.N.GT.IE(JF).AND.K(IE(JF)+1,1)/10000.EQ.6) & P(IE(JF)+1,2)=I-NRS IF(IFLI(JF).NE.0) P(IE(JF)+1,4)=I-NRS ENDIF C...FIND MASSES AND TRANSVERSE MOMENTA P(I,5)=ULMASS(1,K(I,2)) IF(JF.EQ.JT) PR(JF)=P(I,5)**2+(PX(JF)+PX(3))**2+(PY(JF)+PY(3))**2 470 IF(JF.EQ.JR) PR(JF)=P(I,5)**2+(PX(JF)-PX(3))**2+(PY(JF)-PY(3))**2 C...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 HC12=FOUR(IN(3*JQ+1),IN(3*JQ+2)) HR1=FOUR(N+NRS,IN(3*JQ+2))/HC12 HR2=FOUR(N+NRS,IN(3*JQ+1))/HC12 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 (IF POSSIBLE) WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2 HD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2) IF(HD.GE.1.) GOTO 230 HA=WREM2+PR(JT)-PR(JR) IF(MST(4).EQ.2) PREV=0.5*HD**PAR(27+MST(4)) IF(MST(4).NE.2) PREV=0.5*EXP(MAX(-100.,ALOG(HD)*PAR(27+MST(4))* &(PR(1)+PR(2))**2)) HB=SIGN(SQRT(MAX(0.,HA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV)) IF(MAX(MOD(IABS(IFL(1)),10),MOD(IABS(IFL(2)),10)).GE.6) &HB=SIGN(SQRT(MAX(0.,HA**2-4.*WREM2*PR(JT))),FLOAT(JS)) DO 480 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*(HR1*(HA+HB)*P(IN(3*JQ+1),J)+ &HR2*(HA-HB)*P(IN(3*JQ+2),J))/WREM2 480 P(I,J)=P(N+NRS,J)-P(I-1,J) C...BOOST BACK FOR RAPIDLY MOVING SYSTEM IF(MBST.EQ.1) THEN MST(1)=N+NRS+1 MST(2)=I CALL LUROBO(0.,0.,PS(1)/PEBST,PS(2)/PEBST,PS(3)/PEBST) MST(1)=0 MST(2)=0 ENDIF C...MARK JETS AS FRAGMENTED, MOVE UP PARTICLES NI=I-NRS DO 490 I=N+1,N+NP 490 K(K(I,1),1)=K(K(I,1),1)+20000 DO 500 I=N+1,NI K(I,1)=K(I+NRS,1) K(I,2)=K(I+NRS,2) DO 500 J=1,5 500 P(I,J)=P(I+NRS,J) C...OPTIONAL ORDERING ALONG CHAIN, I.E. IN RANK IF(MST(22).GE.1) THEN IF(2*NI-N.GE.MST(30)-5-MST(31)) THEN MST(24)=MST(24)+1 MST(25)=1 IF(MST(23).GE.1) RETURN ENDIF DO 510 I=N+1,NI K(I-N+NI,1)=K(I,1) K(I-N+NI,2)=K(I,2) DO 510 J=1,5 510 P(I-N+NI,J)=P(I,J) I1=N DO 530 I=NI+1,2*NI-N IF(K(I,1).NE.IE(1)) GOTO 530 I1=I1+1 K(I1,1)=K(I,1) K(I1,2)=K(I,2) DO 520 J=1,5 520 P(I1,J)=P(I,J) 530 CONTINUE DO 550 I=2*NI-N,NI+1,-1 IF(K(I,1).EQ.IE(1)) GOTO 550 I1=I1+1 K(I1,1)=K(I,1) K(I1,2)=K(I,2) DO 540 J=1,5 540 P(I1,J)=P(I,J) 550 CONTINUE ENDIF C...BRING BARYONS TOGETHER INSIDE GLUON LOOP IF(MST(22).GE.2.AND.IFLSTR.NE.0) THEN DO 560 I=N+1,N+IFLSTR K(I-N+NI,1)=K(I,1) K(I-N+NI,2)=K(I,2) DO 560 J=1,5 560 P(I-N+NI,J)=P(I,J) DO 570 I=N+1,NI K(I,1)=K(I+IFLSTR,1) K(I,2)=K(I+IFLSTR,2) DO 570 J=1,5 570 P(I,J)=P(I+IFLSTR,J) ENDIF N=NI RETURN END C********************************************************************* SUBROUTINE LUDECY(IP) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600) DIMENSION IFLO(4),IFL1(4),PV(10,5),RORD(10),UE(3),BE(3) C...FUNCTIONS : MOMENTUM IN TWO-PARTICLE DECAYS AND FOUR-PRODUCT 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) C...CHOOSE DECAY CHANNEL NTRY=0 NSAV=N KFA=IABS(K(IP,2)) KFS=ISIGN(1,K(IP,2)) 100 RBR=RLU(0) IF(KFA.LE.100) THEN IDC=IDB(KFA)-1 ELSE CALL LUIFLV(KFA,IFLA,IFLB,IFLC,KSP) IDC=IDB(76+5*IFLA+KSP)-1 ENDIF 110 IDC=IDC+1 IF(RBR.GT.CBR(IDC)) GOTO 110 C...START READOUT OF DECAY CHANNEL: MATRIX ELEMENT, RESET COUNTERS MMAT=IABS(KDP(4*IDC-3))/1000 120 NTRY=NTRY+1 IF(NTRY.GT.1000) THEN MST(24)=MST(24)+1 MST(25)=5 IF(MST(23).GE.1) RETURN ENDIF I=N NP=0 NQ=0 MBST=0 IF(MMAT.GE.5.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1 DO 130 J=1,4 PV(1,J)=0. 130 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. NM=0 DO 140 I1=4*IDC-3,4*IDC C...READ OUT DECAY PRODUCT, CONVERT TO STANDARD FLAVOUR CODE KP=MOD(KDP(I1),1000) IF(KP.EQ.0) GOTO 140 IF(IABS(KP).LE.100) THEN KFP=KFS*KP IF(MOD(KTYP(IABS(KP)),10).EQ.0) KFP=KP ELSEIF(IABS(KP).LT.590) THEN KFP=KFS*KP IF(KP.EQ.500) KFP=KP ELSEIF(IABS(KP).EQ.590) THEN IF(KSP.LE.1) KFP=KFS*(-500+IFLB) IF(KSP.EQ.3) KFP=KFS*(500+10*IFLC+IFLB) IF(KSP.EQ.2.OR.KSP.EQ.4) KFP=KFS*(500+10*IFLB+IFLC) ELSEIF(IABS(KP).EQ.591) THEN CALL LUIFLD(-KFS*INT(1.+(2.+PAR(2))*RLU(0)),0,0,KFP,KDUMP) IF(PV(1,5).LT.PAR(22)+2.*ULMASS(2,KFP)) GOTO 120 KFP=MOD(KFP,100)+ISIGN(500,KFP) ELSEIF(IABS(KP).EQ.592) THEN KFP=-KFP ENDIF C...ADD DECAY PRODUCT TO EVENT RECORD OR TO IFLO LIST IF(MMAT.GE.6.AND.MMAT.LE.8.AND.IABS(KFP).GE.500) THEN NQ=NQ+1 IFLO(NQ)=MOD(KFP,500) PSQ=PSQ+ULMASS(3,IFLO(NQ)) ELSEIF(MMAT.GE.12.AND.NP.EQ.3) THEN NQ=NQ-1 PS=PS-P(I,5) K(I,1)=IP CALL LUIFLD(MOD(KFP,500),0,MOD(K(I,2),500),IFLDMP,K(I,2)) P(I,5)=ULMASS(1,K(I,2)) PS=PS+P(I,5) ELSE I=I+1 NP=NP+1 IF(IABS(KFP).GE.500) NQ=NQ+1 K(I,1)=IP+10000*(NQ-2*(NQ/2)) K(I,2)=KFP P(I,5)=ULMASS(1+2*(IABS(KFP)/500),KFP) PS=PS+P(I,5) ENDIF 140 CONTINUE 150 IF(MMAT.GE.6.AND.MMAT.LE.8) THEN C...CHOOSE DECAY MULTIPLICITY IN PHASE SPACE MODEL PSP=PS CNDE=DPAR(11)*ALOG(MAX((PV(1,5)-PS-PSQ)/DPAR(12),1.1)) IF(MMAT.EQ.8) CNDE=CNDE+DPAR(13) 160 NTRY=NTRY+1 IF(NTRY.GT.1000) THEN MST(24)=MST(24)+1 MST(25)=5 IF(MST(23).GE.1) RETURN ENDIF GAUSS=SQRT(-2.*CNDE*ALOG(MAX(1E-10,RLU(0))))*SIN(PAR(72)*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 160 IF(MMAT.EQ.7.AND.ND.EQ.2) GOTO 160 C...FORM HADRONS FROM FLAVOUR CONTENT DO 170 JT=1,4 170 IFL1(JT)=IFLO(JT) IF(ND.EQ.NP+NQ/2) GOTO 190 DO 180 I=N+NP+1,N+ND-NQ/2 JT=1+INT((NQ-1)*RLU(0)) CALL LUIFLD(IFL1(JT),0,0,IFL2,K(I,2)) 180 IFL1(JT)=-IFL2 190 JT=2 JT2=3 JT3=4 IF(NQ.EQ.4.AND.RLU(0).LT.DPAR(16)) JT=4 IF(JT.EQ.4.AND.IFL1(1)*(10-IABS(IFL1(1)))*IFL1(JT)* & (10-IABS(IFL1(JT))).GT.0) JT=3 IF(JT.EQ.3) JT2=2 IF(JT.EQ.4) JT3=2 IF(MIN(IABS(IFL1(1)),IABS(IFL1(JT))).GT.10.OR.(NQ.EQ.4.AND. & MIN(IABS(IFL1(JT2)),IABS(IFL1(JT3))).GT.10)) GOTO 160 IF(MAX(IABS(IFL1(1)),IABS(IFL1(JT))).GT.100.OR.(NQ.EQ.4.AND. & MAX(IABS(IFL1(JT2)),IABS(IFL1(JT3))).GT.100)) GOTO 160 CALL LUIFLD(IFL1(1),0,IFL1(JT),IFLDMP,K(N+ND-NQ/2+1,2)) IF(NQ.EQ.4) CALL LUIFLD(IFL1(JT2),0,IFL1(JT3),IFLDMP,K(N+ND,2)) C...CHECK THAT SUM OF DECAY PRODUCT MASSES NOT TOO LARGE PS=PSP DO 200 I=N+NP+1,N+ND K(I,1)=IP P(I,5)=ULMASS(1,K(I,2)) 200 PS=PS+P(I,5) IF(PS+DPAR(14).GT.PV(1,5)) GOTO 160 ELSEIF(MMAT.EQ.5.OR.MMAT.EQ.11) THEN C...RESCALE ENERGY TO SUBTRACT OFF SPECTATOR QUARK MASS PS=PS-P(N+NP,5) PQT=(P(N+NP,5)+DPAR(15))/PV(1,5) DO 210 J=1,5 P(N+NP,J)=PQT*PV(1,J) 210 PV(1,J)=(1.-PQT)*PV(1,J) IF(PS+DPAR(14).GT.PV(1,5)) GOTO 120 ND=NP-1 ELSE C...FULLY SPECIFIED FINAL STATES, CHECK MASS BROADENING EFFECTS IF(NP.GE.2.AND.PS+DPAR(14).GT.PV(1,5)) GOTO 120 ND=NP ENDIF IF(ND.EQ.1) THEN C...KINEMATICS OF ONE-PARTICLE DECAYS DO 220 J=1,4 220 P(N+1,J)=P(IP,J) GOTO 430 ENDIF C...CALCULATE MAXIMUM WEIGHT ND-PARTICLE DECAY PV(ND,5)=P(N+ND,5) IF(ND.EQ.2) GOTO 280 WTMAX=1./DPAR(ND-2) PMAX=PV(1,5)-PS+P(N+ND,5) PMIN=0. DO 230 IL=ND-1,1,-1 PMAX=PMAX+P(N+IL,5) PMIN=PMIN+P(N+IL+1,5) 230 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5)) C...M-GENERATOR GIVES WEIGHT, IF REJECTED TRY AGAIN 240 RORD(1)=1. DO 260 IL1=2,ND-1 RSAV=RLU(0) DO 250 IL2=IL1-1,1,-1 IF(RSAV.LE.RORD(IL2)) GOTO 260 250 RORD(IL2+1)=RORD(IL2) 260 RORD(IL2+1)=RSAV RORD(ND)=0. WT=1. DO 270 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) 270 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) IF(WT.LT.RLU(0)*WTMAX) GOTO 240 C...PERFORM TWO-PARTICLE DECAYS IN RESPECTIVE CM FRAME 280 DO 300 IL=1,ND-1 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) UE(3)=2.*RLU(0)-1. PHI=PAR(72)*RLU(0) UE(1)=SQRT(1.-UE(3)**2)*COS(PHI) UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI) DO 290 J=1,3 P(N+IL,J)=PA*UE(J) 290 PV(IL+1,J)=-PA*UE(J) P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2) 300 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2) C...LORENTZ TRANSFORM DECAY PRODUCTS TO LAB FRAME DO 310 J=1,4 310 P(N+ND,J)=PV(ND,J) DO 340 IL=ND-1,1,-1 DO 320 J=1,3 320 BE(J)=PV(IL,J)/PV(IL,4) GA=PV(IL,4)/PV(IL,5) DO 340 I=N+IL,N+ND BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) DO 330 J=1,3 330 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J) 340 P(I,4)=GA*(P(I,4)+BEP) IF(MMAT.EQ.1) THEN C...MATRIX ELEMENTS FOR OMEGA AND PHI DECAYS 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*DPAR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 240 ELSEIF(MMAT.EQ.3) THEN C...MATRIX ELEMENT FOR S0 -> S1 + V1 -> S1 + S2 + S3 (S SCALAR, C...V VECTOR), OF FORM COS**2(THETA02) IN V1 REST FRAME IF(NM.NE.2) THEN IM=MOD(K(IP,1),10000) IF(IM.EQ.0) GOTO 360 DO 350 IL=MAX(IP-2,IM+1),MIN(IP+2,N) 350 IF(MOD(K(IL,1),10000).EQ.IM) NM=NM+1 CALL LUIFLV(K(IM,2),IFLAM,IFLBM,IFLCM,KSPM) IF(NM.NE.2.OR.KSPM.NE.0) GOTO 360 ENDIF 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 280 360 NM=0 ELSEIF(MMAT.GE.11) THEN C...MATRIX ELEMENTS FOR WEAK DECAYS (ONLY SEMILEPTONIC FOR C AND B) 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/DPAR(10)) GOTO 240 ENDIF IF(MMAT.EQ.5.OR.MMAT.EQ.11) THEN C...SCALE BACK ENERGY AND REATTACH SPECTATOR DO 370 J=1,5 370 PV(1,J)=PV(1,J)/(1.-PQT) ND=ND+1 ENDIF C...LOW INVARIANT MASS FOR SYSTEM WITH SPECTATOR QUARK GIVES PARTICLE, C...NOT TWO JETS, READJUST MOMENTA ACCORDINGLY IF(MMAT.EQ.5) THEN IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE. & (PAR(22)+ULMASS(0,K(N+2,2))+ULMASS(0,K(N+3,2)))**2) GOTO 430 K(N+2,1)=IP CALL LUIFLD(MOD(K(N+2,2),500),0,MOD(K(N+3,2),500),IFLDMP, & K(N+2,2)) P(N+2,5)=ULMASS(1,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 280 ELSEIF(MMAT.EQ.11) THEN IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE. & (PAR(22)+ULMASS(0,K(N+3,2))+ULMASS(0,K(N+4,2)))**2) GOTO 400 K(N+3,1)=IP CALL LUIFLD(MOD(K(N+3,2),500),0,MOD(K(N+4,2),500),IFLDMP, & K(N+3,2)) P(N+3,5)=ULMASS(1,K(N+3,2)) DO 380 J=1,3 380 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 390 J=1,3 PCOR=HH*(P(N+1,J)-P(N+2,J)) P(N+1,J)=P(N+1,J)+PCOR 390 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 400 IF(MMAT.GE.11.AND.IABS(K(N+1,2)).GE.500) THEN C...CHECK INVARIANT MASS OF W JETS, MAY GIVE ONE PARTICLE OR START OVER PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2))) IF(PMR.GT.PAR(22)+ULMASS(0,K(N+1,2))+ULMASS(0,K(N+2,2))) & GOTO 410 CALL LUIFLD(MOD(K(N+1,2),500),0,-ISIGN(1,K(N+1,2)),IFLDMP,KF1) CALL LUIFLD(MOD(K(N+2,2),500),0,-ISIGN(1,K(N+2,2)),IFLDMP,KF2) PSM=ULMASS(0,KF1)+ULMASS(0,KF2) IF(MMAT.LE.12.AND.PMR.GT.0.2*PAR(22)+PSM) GOTO 410 IF(MMAT.EQ.13.AND.PMR.GT.DPAR(14)+PSM) GOTO 410 IF(ND.EQ.4.OR.KFA.EQ.11) GOTO 120 K(N+1,1)=IP CALL LUIFLD(MOD(K(N+1,2),500),0,MOD(K(N+2,2),500),IFLDMP, & K(N+1,2)) P(N+1,5)=ULMASS(0,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 280 ENDIF 410 IF(MMAT.EQ.13) THEN C...PHASE SPACE DECAY OF PARTONS FROM W DECAY IFLO(1)=MOD(K(N+1,2),500) IFLO(2)=MOD(K(N+2,2),500) K(N+1,1)=K(N+3,1) K(N+1,2)=K(N+3,2) DO 420 J=1,5 PV(1,J)=P(N+1,J)+P(N+2,J) 420 P(N+1,J)=P(N+3,J) PV(1,5)=PMR N=N+1 NP=0 NQ=2 PS=0. PSQ=ULMASS(3,IFLO(1))+ULMASS(3,IFLO(2)) MMAT=6 GOTO 150 ENDIF C...BOOST BACK FOR RAPIDLY MOVING PARTICLE 430 N=N+ND IF(MBST.EQ.1) THEN DO 440 J=1,3 440 BE(J)=P(IP,J)/P(IP,4) GA=P(IP,4)/P(IP,5) DO 460 I=NSAV+1,N BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) DO 450 J=1,3 450 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J) 460 P(I,4)=GA*(P(I,4)+BEP) ENDIF K(IP,1)=K(IP,1)+20000 RETURN END C********************************************************************* SUBROUTINE LUIFLD(IFL1,IFL2,IFL3,IFL4,KF) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) C...PRELIMINARIES, OPTIONAL ENHANCEMENTS BEHIND HEAVY QUARK IFLA=IABS(IFL1) IFLB=IABS(IFL2) IFLC=IABS(IFL3) PAR1=PAR(1) PAR2=PAR(2) PAR3=PAR(3) PAR4=3.*PAR(4) IF(IFLA.GE.4.AND.IFLA.LT.10.AND.ABS(PAR(16)-1.).GT.0.1) THEN PAR1=2.5*(0.4*PAR(1))**(1./PAR(16)) PAR2=PAR(2)**(1./PAR(16)) PAR3=PAR(3)**(1./PAR(16)) PAR4=3.*PAR(4)**(1./PAR(16)) ENDIF C...MESON OR BARYON (FROM EXISTING DIQUARK OR NOT) TO BE GENERATED IFLG=0 IFLI=0 IFL4=0 KF=0 MB=1 IF(IFLA.GT.10.OR.IFLC.GT.10) MB=2 IF(IFLA.LT.10.AND.IFLB.EQ.0.AND.IFLC.EQ.0.AND. &(1.+PAR1)*RLU(0).LT.1.) MB=0 IF(IFLA.LT.10.AND.IFLB.EQ.0.AND.(IFLC+9)/10.EQ.1) MB=0 C...PARAMETER COMBINATIONS FOR BREAKING DIQUARK IF((IFLA.GT.100.OR.MB.EQ.1).AND.PAR(5).GT.0.) THEN PAR3M=SQRT(PAR(3)) PAR4M=1./(3.*SQRT(PAR(4))) PARDM=PAR(7)/(PAR(7)+PAR3M*PAR(6)) PARS0=PAR(5)*(2.+(1.+PAR2*PAR3M*PAR(7))*(1.+PAR4M)) PARS1=PAR(7)*PARS0/(2.*PAR3M)+PAR(5)*(PAR(6)*(1.+PAR4M)+ & PAR2*PAR3M*PAR(6)*PAR(7)) PARS2=PAR(5)*2.*PAR(6)*PAR(7)*(PAR2*PAR(7)+(1.+PAR4M)/PAR3M) PARSM=MAX(PARS0,PARS1,PARS2) PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M)) ENDIF IF(MB.EQ.0.OR.IFLA.GT.100) THEN C...FLAVOUR FOR MESON, POSSIBLY WITH NEW QUARK IF(MB.EQ.0) THEN IF(IFLC.EQ.0) IFL4=ISIGN(1+INT((2.+PAR2)*RLU(0)),-IFL1) IFLD=MAX(IFLA,IFLC+IABS(IFL4)) IFLE=MIN(IFLA,IFLC+IABS(IFL4)) ELSE C...SPLITTING OF DIQUARK INTO MESON PLUS NEW DIQUARK 100 IFLG=MOD(IFLA,10)+INT(RLU(0)+0.5)*((IFLA-100)/10-MOD(IFLA,10)) IFLH=MOD(IFLA,10)+(IFLA-100)/10-IFLG IF((IFLG.EQ.3.AND.RLU(0).GT.PARDM).OR.(IFLH.EQ.3.AND.RLU(0). & LT.PARDM)) THEN IFLI=IFLG IFLG=IFLH IFLH=IFLI ENDIF IFLI=1+INT((2.+PAR2*PAR3M*PAR(7))*RLU(0)) IF((IFLH.NE.IFLI.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)). & OR.(IFLH.EQ.IFLI.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M))) GOTO 100 IFLD=MAX(IFLG,IFLI) IFLE=MIN(IFLG,IFLI) IFL4=ISIGN(10*MIN(IFLI,IFLH)+MAX(IFLI,IFLH)+9*INT(RLU(0)+ & 1./(1.+PAR4M))*IABS(IFLI-IFLH),-IFL1) MST(33)=IFLI ENDIF C...FORM MESON WITH SPIN AND FLAVOUR MIXING FOR DIAGONAL STATES KSP=INT(PAR(8)+RLU(0)) IF(IFLD.EQ.3) KSP=INT(PAR(9)+RLU(0)) IF(IFLD.GE.4) KSP=INT(PAR(10)+RLU(0)) IF(IFLD.NE.IFLE) THEN KF=ISIGN(KFR(8*KSP+IFLD)+IFLE,(IFL1+IFL3+IFL4)*(2*IFLD-7)) IF(IFLA.GT.100.AND.IFLI.GT.IFLG) KF=-KF ELSE RFR=RLU(0) IF(IFLD.LE.3) KF=23+10*KSP+INT(RFR+CFR(6*KSP+2*IFLD-1))+ & INT(RFR+CFR(6*KSP+2*IFLD)) IF(IFLD.EQ.4) KF=26+10*KSP IF(IFLD.GE.5) KF=78+4*KSP+IFLD ENDIF ELSE 110 IF(IFLA.LT.10.AND.IFLB.EQ.0.AND.IFLC.EQ.0) THEN C...GENERATE DIQUARK FLAVOUR MB=3 IFLD=IFLA 120 IFLE=1+INT((2.+PAR2*PAR3)*RLU(0)) IFLF=1+INT((2.+PAR2*PAR3)*RLU(0)) IF(IFLE.GE.IFLF.AND.PAR4.LT.RLU(0)) GOTO 120 IF(IFLE.LT.IFLF.AND.PAR4*RLU(0).GT.1.) GOTO 120 IFL4=ISIGN(10*IFLE+IFLF,IFL1) ELSEIF(IFLA.LT.10.AND.IFLB.EQ.0) THEN C...TAKE DIQUARK FLAVOUR FROM INPUT IFLD=IFLA IFLE=IFLC/10 IFLF=MOD(IFLC,10) ELSEIF(IFLA.LT.10) THEN C...COMBINE DIQUARK FLAVOUR FROM INPUT (AND NEW-GENERATED QUARK) IFLD=IFLB IF(IFLC.EQ.0) IFL4=ISIGN(1+INT((2.+PAR2)*RLU(0)),IFL1) IFLE=IFLA+INT(RLU(0)+0.5)*(IFLC+IABS(IFL4)-IFLA) IFLF=IFLA+IFLC+IABS(IFL4)-IFLE ELSE C... GENERATE (OR TAKE FROM INPUT) QUARK TO GO WITH DIQUARK IF(IFLC.EQ.0) IFL4=ISIGN(1+INT((2.+PAR2)*RLU(0)),IFL1) IFLD=IFLC+IABS(IFL4) IFLE=IFLA/10 IFLF=MOD(IFLA,10) ENDIF C...SU(6) FACTORS FOR FORMATION OF BARYON, RETURN OR TRY AGAIN IF FAILS LFR=3+2*((2*(IFLE-IFLF))/(1+IABS(IFLE-IFLF))) IF(IFLD.NE.IFLE.AND.IFLD.NE.IFLF) LFR=LFR+1 WT=CFR(2*LFR+11)+PAR(11)*CFR(2*LFR+12) IF(MB.EQ.1.AND.IFLE.LT.IFLF) WT=WT/3. IF(MB.EQ.1.AND.IFLB.NE.0) WT=0.75*WT IF(MB.EQ.3.AND.PAR(5).GT.0.) THEN WTDQ=PARS0 IF(MAX(IFLE,IFLF).EQ.3) WTDQ=PARS1 IF(MIN(IFLE,IFLF).EQ.3) WTDQ=PARS2 IF(IFLE.LT.IFLF) WTDQ=WTDQ/(3.*PAR4M) IF((1.+WTDQ)*RLU(0).GT.1.) IFL4=IFL4+ISIGN(100,IFL1) IF(IFLE.GE.IFLF) WT=WT*(1.+WTDQ)/(1.+PARSM) IF(IFLE.LT.IFLF) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M)) ENDIF IF(IFLB.NE.0.AND.WT.LT.RLU(0)) RETURN IF(IFLB.EQ.0.AND.IFLC.EQ.0.AND.WT.LT.RLU(0)) GOTO 110 C...FORM BARYON IFLG=MAX(IFLD,IFLE,IFLF) IFLI=MIN(IFLD,IFLE,IFLF) IFLH=IFLD+IFLE+IFLF-IFLG-IFLI KSP=2+2*INT(1.-CFR(2*LFR+11)+(CFR(2*LFR+11)+PAR(11)* & CFR(2*LFR+12))*RLU(0)) IF(KSP.EQ.2.AND.IFLG.GT.IFLH.AND.IFLH.GT.IFLI) THEN C...DISTINGUISH LAMBDA- AND SIGMA-LIKE PARTICLES IF(IFLE.GT.IFLF.AND.IFLD.NE.IFLG) KSP=2+INT(0.75+RLU(0)) IF(IFLE.LT.IFLF.AND.IFLD.EQ.IFLG) KSP=3 IF(IFLE.LT.IFLF.AND.IFLD.NE.IFLG) KSP=2+INT(0.25+RLU(0)) ENDIF KF=ISIGN(KFR(16*KSP-16+IFLG)+KFR(16*KSP-8+IFLH)+IFLI,IFL1) ENDIF RETURN END C********************************************************************* FUNCTION ULMASS(MMASS,KF) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) KFA=IABS(KF) ULMASS=0. KTY=0 IF(MMASS.LE.1.AND.KFA.LE.100) THEN C...ORDINARY PARTICLE MASSES ULMASS=PMAS(KFA) KTY=KTYP(KFA)/10 ELSEIF(MMASS.LE.1.AND.KFA.LT.500) THEN C...HEAVY HADRON MASSES INCLUDING CHROMOMAGNETIC SPIN-SPIN INTERACTIONS CALL LUIFLV(KFA,IFLA,IFLB,IFLC,KSP) IF(KSP.EQ.2.AND.IFLA.EQ.IFLB) THEN IFLD=IFLA IFLA=IFLC IFLC=IFLD ENDIF PMA=PMAS(100+IFLA) PMB=PMAS(100+IABS(IFLB)) PMC=PMAS(100+IFLC) IF(KSP.LE.1) ULMASS=PMAS(113)+PMA+PMB+PMAS(115)*PMAS(101)**2* & CFR(25+KSP)/(PMA*PMB) IF(KSP.GE.2) ULMASS=PMAS(114)+PMA+PMB+PMC+PMAS(116)* & PMAS(101)**2*(CFR(21+3*KSP)/(PMA*PMB)+CFR(22+3*KSP)/(PMA*PMC)+ & CFR(23+3*KSP)/(PMB*PMC)) KTY=KTYP(100+IFLA)/10 ELSE C...QUARK AND DIQUARK MASSES: CONSTITUENT AND CURRENT ALGEBRA-LIKE KFA=MOD(KFA,100) IF(KFA.GE.1.AND.KFA.LE.10) THEN ULMASS=PMAS(100+KFA) IF(MMASS.EQ.3) ULMASS=ULMASS-PMAS(111) KTY=KTYP(100+KFA)/10 ELSEIF(KFA.GT.10) THEN KSP=0 IF(KFA/10.GE.MOD(KFA,10)) KSP=1 PMA=PMAS(100+KFA/10) PMB=PMAS(100+MOD(KFA,10)) ULMASS=PMA+PMB IF(MMASS.EQ.3) ULMASS=ULMASS-PMAS(112)+PMAS(116)*PMAS(101)**2* & CFR(25+KSP)/(PMA*PMB) KTY=KTYP(100+MAX(KFA/10,MOD(KFA,10)))/10 ENDIF ENDIF C...OPTIONAL MASS BROADENING (TRUNCATED BREIT-WIGNER SHAPE) IF(MST(8).EQ.1.AND.MMASS.GE.1.AND.KTY.GE.1) ULMASS=ULMASS+0.5* &PWID(2*KTY-1)*TAN((2.*RLU(0)-1.)*ATAN(2.*PWID(2*KTY)/ &PWID(2*KTY-1))) RETURN END C********************************************************************* SUBROUTINE LUPTDI(IFL,PX,PY) COMMON/LUDAT1/MST(40),PAR(80) IFLA=IABS(IFL) C...GENERATE PT ACCORDING TO GAUSSIAN, SOME CASES WITH DIFFERENT WIDTHS PT=PAR(12)*SQRT(-ALOG(MAX(1E-10,RLU(0)))) IF(MST(32).EQ.1) PT=PAR(13)*PT IF(IFLA.GE.4.AND.IFLA.LT.10.AND.ABS(PAR(16)-1.).GT.0.1) PT= &SQRT(PAR(16))*PT IF(IFLA.EQ.93.AND.MST(11).EQ.1) PT=PAR(14)*PT IF(IFLA.EQ.93.AND.MST(11).NE.1) PT=0. IF(IFLA.EQ.94) PT=PAR(15)*PT/PAR(12) PHI=PAR(72)*RLU(0) PX=PT*COS(PHI) PY=PT*SIN(PHI) RETURN END C********************************************************************* SUBROUTINE LUZDIS(IFL1,IFL3,PR,Z) COMMON/LUDAT1/MST(40),PAR(80) IFLA=MAX(MOD(IABS(IFL1),100)/10,MOD(IABS(IFL1),10)) IF(IFLA.NE.0.AND.(MST(4).EQ.1.OR.(MST(4).EQ.3.AND.IFLA.LE.3))) &THEN C...SYMMETRIC SCALING FUNCTION: POSITION OF MAXIMUM, DIVIDE INTERVAL FA=PAR(31) FB=PAR(32)*PR IF(IFL3.NE.0) FA=PAR(35) IF(IFL3.NE.0) FB=PAR(36)*PR IF(MST(32).EQ.1) FA=PAR(33) IF(MST(32).EQ.1) FB=PAR(34)*PR IF(FA.LE.0.01) ZMAX=MIN(1.,FB) IF(FA.GT.0.01.AND.ABS(FA-1.)/FB.LE.0.01) ZMAX=FB/(1.+FB)+ & (1.-FA)*FB**2/(1.+FB)**3 IF(FA.GT.0.01.AND.ABS(FA-1.)/FB.GT.0.01) ZMAX=0.5*(1.+FB- & SQRT((1.-FB)**2+4.*FA*FB))/(1.-FA) IF(ZMAX.LT.0.1) ZDIV=2.75*ZMAX IF(ZMAX.GT.0.85) ZDIV=ZMAX-0.6/FB**2+(FA/FB)*ALOG((0.01+FA)/FB) C...CHOICE OF Z, PREWEIGHTED FOR PEAKS AT LOW OR HIGH Z 100 Z=RLU(0) IDIV=1 FPRE=1. IF(ZMAX.LT.0.1) THEN IF(1..LT.RLU(0)*(1.-ALOG(ZDIV))) IDIV=2 IF(IDIV.EQ.1) Z=ZDIV*Z IF(IDIV.EQ.2) Z=ZDIV**Z IF(IDIV.EQ.2) FPRE=ZDIV/Z ELSEIF(ZMAX.GT.0.85) THEN IF(1..LT.RLU(0)*(FB*(1.-ZDIV)+1.)) IDIV=2 IF(IDIV.EQ.1) Z=ZDIV+ALOG(Z)/FB IF(IDIV.EQ.1) FPRE=EXP(FB*(Z-ZDIV)) IF(IDIV.EQ.2) Z=ZDIV+Z*(1.-ZDIV) ENDIF C...WEIGHTING ACCORDING TO CORRECT FORMULA IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100 FVAL=(ZMAX/Z)*EXP(FB*(1./ZMAX-1./Z)) IF(FA.GT.0.01) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL IF(FVAL.LT.RLU(0)*FPRE) GOTO 100 ELSEIF(IFL1.NE.0) THEN C...GENERATE Z ACCORDING TO FIELD-FEYNMAN, SLAC, (1-Z)**C OR Z**C FC=PAR(40+IFLA) IF(MST(32).EQ.1) FC=PAR(49) IF(IFL3.NE.0) FC=PAR(50) 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 ELSE C...POSITION OF J OR I QUARK 120 Z=RLU(0)**(1./(1.+MAX(PAR(49+2*IFL3),PAR(50+2*IFL3)))) IF((1.-Z)**MIN(PAR(49+2*IFL3),PAR(50+2*IFL3)).LT.RLU(0)) & GOTO 120 IF(PAR(50+2*IFL3).GT.PAR(49+2*IFL3)) Z=1.-Z ENDIF RETURN END C********************************************************************* SUBROUTINE LUIFLV(KF,IFLA,IFLB,IFLC,KSP) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) KFA=IABS(KF) KFS=ISIGN(1,KF) IFLA=0 IFLB=0 IFLC=0 C...RECONSTRUCT SPIN FOR HADRON KSP=-1 IF((KFA.GE.17.AND.KFA.LE.26).OR.KFA.EQ.37.OR.KFA.EQ.38.OR. &(KFA.GE.83.AND.KFA.LE.86).OR.KFA.GE.101) KSP=0 IF((KFA.GE.27.AND.KFA.LE.36).OR.(KFA.GE.87.AND.KFA.LE.90).OR. &KFA.GE.123) KSP=1 IF((KFA.GE.41.AND.KFA.LE.56).OR.KFA.GE.145) KSP=2 IF((KFA.GE.57.AND.KFA.LE.60).OR.KFA.GE.241) KSP=3 IF((KFA.GE.61.AND.KFA.LE.80).OR.KFA.GE.293) KSP=4 IF(KFA.GE.393) KSP=-1 C...RECONSTRUCT FLAVOUR CONTENT FOR MESON IF((KFA.GE.23.AND.KFA.LE.26).OR.(KFA.GE.33.AND.KFA.LE.36).OR. &(KFA.GE.83.AND.KFA.LE.90)) THEN IF(KFA.LE.40) IFLA=KFA-22-10*KSP IF(KFA.GE.80) IFLA=KFA-78-4*KSP IFLB=-IFLA ELSEIF(KFA.EQ.37.OR.KFA.EQ.38) THEN IFLA=ISIGN(3,(-1)**INT(RLU(0)+0.5)) IFLB=ISIGN(2,-IFLA) ELSEIF(KSP.EQ.0.OR.KSP.EQ.1) THEN 100 IFLA=IFLA+1 IF(IFLA.LT.8.AND.KFR(8*KSP+IFLA+1).LT.KFA) GOTO 100 IFLB=-(KFA-KFR(8*KSP+IFLA)) IF(IFLA.LE.3) IFLB=-IFLB IF(IFLA.LE.3) IFLA=-IFLA C...RECONSTRUCT FLAVOUR CONTENT FOR BARYON ELSEIF(KSP.GE.2.AND.KSP.LE.4) THEN 110 IFLA=IFLA+1 IF(IFLA.LT.8.AND.KFR(16*KSP+IFLA-15).LT.KFA) GOTO 110 120 IFLB=IFLB+1 IF(IFLB.LT.8.AND.KFR(16*KSP+IFLB-7).LT.KFA-KFR(16*KSP+IFLA-16)) & GOTO 120 IFLC=KFA-KFR(16*KSP+IFLA-16)-KFR(16*KSP+IFLB-8) ENDIF IFLA=KFS*IFLA IFLB=KFS*IFLB IFLC=KFS*IFLC RETURN END C********************************************************************* FUNCTION LUCHGE(KF) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) KFA=IABS(KF) LUCHGE=0 C...CALCULATE 3*CHARGE FOR PARTICLES AND PARTONS IF(KFA.LE.100) THEN KTY=MOD(KTYP(KFA),10) IF(KTY.GE.1) LUCHGE=3*KTY-6 ELSEIF(KFA.LT.500) THEN CALL LUIFLV(KFA,IFLA,IFLB,IFLC,KSP) LUCHGE=3*MOD(KTYP(100+IFLA),10)-16+ & (3*MOD(KTYP(100+IABS(IFLB)),10)-16)*ISIGN(1,IFLB) IF(IFLC.NE.0) LUCHGE=LUCHGE+3*MOD(KTYP(100+IFLC),10)-16 ELSEIF(KFA.LE.600) THEN IF(MOD(KFA,10).NE.0) LUCHGE=3*MOD(KTYP(100+MOD(KFA,10)),10)-16 IF(KFA.GT.510) LUCHGE=LUCHGE+3*MOD(KTYP(50+KFA/10),10)-16 ELSEIF(KFA.LE.700) THEN IF(MOD(KFA,10).NE.0) LUCHGE=3*MOD(KTYP(100+MOD(KFA,10)),10)-16 ENDIF LUCHGE=LUCHGE*ISIGN(1,KF) RETURN END C********************************************************************* SUBROUTINE LUNAME(KF,CHAU) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) COMMON/LUDAT4/CHAG(50),CHAF(100) CHARACTER CHAU*8,CHAG*4,CHAF*4 CHAU=CHAG(1)//CHAG(1) KFA=IABS(KF) KFS=ISIGN(1,KF) IF(KFA.EQ.0) THEN C...PARTICLE NAMES: ORDINARY AND HEAVY HADRONS ELSEIF(KFA.LE.100) THEN CHAU=CHAF(KFA)//CHAG(27+KFS*MOD(KTYP(KFA),10)) ELSEIF(KFA.LT.500) THEN CALL LUIFLV(KFA,IFLA,IFLB,IFLC,KSP) IF(IFLC.EQ.0) CHAU=CHAG(10+IFLA)(1:1)//CHAG(10-IFLB)(1:2)// & CHAG(35-KSP)(1:1)//CHAG(27+KFS*(LUCHGE(KFA)/3+2)) IF(IFLC.NE.0) CHAU=CHAG(10+IFLA)(1:1)//CHAG(10+IFLB)(1:1)// & CHAG(10+IFLC)(1:1)//CHAG(30+KSP)(1:1)//CHAG(27+KFS* & (LUCHGE(KFA)/3+2)) C...JET NAMES: GLUON, QUARKS AND DIQUARKS; ALSO SPECTATOR AND PHASESPACE ELSEIF(KFA.LT.590) THEN IFLA=MAX(KFA/10-50,KFA-10*(KFA/10)) IFLB=MIN(KFA/10-50,KFA-10*(KFA/10)) IF(IFLB.EQ.0) CHAU=CHAG(10+KFS*IFLA)//CHAG(22) KSP=32 IF(KFA/10-50.LT.IFLA) KSP=33 IF(IFLB.NE.0) CHAU=CHAG(10+IFLA)(1:1)//CHAG(10+KFS*IFLB)(1:2)// & CHAG(KSP)(1:1)//CHAG(22) ELSEIF(KFA.LE.600) THEN CHAU=CHAG(KFA-571)//CHAG(22) ELSEIF(KFA.LT.700) THEN C...HADRON JETS: J AND I QUARK IFLA=ISIGN(KFA/10-60,KF) IFLB=ISIGN(MOD(KFA,10),KF) IF(IFLA.NE.0) CHAU(1:4)=CHAG(10+IFLA)(1:2)//CHAG(37)(1:2) IF(IFLB.NE.0) CHAU(5:8)=CHAG(10+IFLB)(1:2)//CHAG(38)(1:2) ENDIF RETURN END C********************************************************************* FUNCTION ULANGL(X,Y) COMMON/LUDAT1/MST(40),PAR(80) ULANGL=0. C...RECONSTRUCT THE ANGLE FROM X AND Y COORDINATES 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=PAR(71)-ULANGL ELSEIF(X.LT.0.) THEN ULANGL=-PAR(71)-ULANGL ENDIF ENDIF RETURN END C********************************************************************* BLOCK DATA LUDATA COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT2/KTYP(120),PMAS(120),PWID(60),KFR(80),CFR(40) COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600) COMMON/LUDAT4/CHAG(50),CHAF(100) CHARACTER CHAG*4,CHAF*4 C...LUDAT1, CONTAINING STATUS CODES AND MOST PARAMETERS DATA MST/ 1 0, 0, 0, 1, 1, 0, 2, 0, 0, 1, 2 0, 1, 10, 0, 0, 0, 0, 0, 1, 6, 3 1, 0, 1, 0, 0, 0, 0, 0, 0, 2000, 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ DATA PAR/ 1 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0.50, 0.60, 0.75, 2 1.0, 0.35, 1.0, 1.0, 0., 1.0, 1.0, 2.0, 0., 0., 3 0.10, 1.0, 0.8, 1.5, 0.8, 2.0, 0.2, 2.5, 0.6, 2.5, 4 0.5, 0.9, 0.5, 0.9, 0.5, 0.9, 1.0, 0., 0., 0., 5 0.77, 0.77, 0.77, 0., 0., 0., 0., 0., 1.0, 0.77, 6 1.0, 1.0, 0., 1.0, 0., 0., 0., 0., 0.09, 0.01, 7 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 8 3.1415927, 6.2831854, 0.,0.001, 0., 5*0./ C...LUDAT2, WITH PARTICLE DATA AND FLAVOUR TREATMENT DATA KTYP/0,10,23,3*0,1,2,1,2,1,2,1,2,2*0,2*3,2*2,2*3,4*0,33,43, &52,2,2*3,60,70,80,5*0,3,2,3,2,1,2,1,4,3,2,3,2*2,4,2*3,2,2*3,2,94, &103,112,121,133,142,151,162,171,1,4,3,2,3,2*2,4,2*3,4,10*0,2,3, &8*0,6,2*5,6,5,6,5,6,12*0/ DATA PMAS/0.,94.,83.,15.,2*0.,.00051,0.,.1057,0.,1.7842,0.,60., &3*0.,.1396,.4937,.4977,1.8646,1.8693,1.9705,.135,.5488,.9576, &2.981,.7714,.8921,.8965,2.0072,2.0101,2.11,.7717,.7826,1.0195, &3.0969,2*.4977,2*0.,.9383,.9396,1.1894,1.1925,1.1973,1.3149, &1.3213,3*2.44,2*2.55,2.74,2*3.63,3.81,1.1156,2.2812,2*2.46,1.23, &1.231,1.232,1.233,1.3828,1.3837,1.3872,1.5318,1.535,1.6724,3*2.5, &2*2.63,2.8,2*3.69,3.85,4.9,2*0.,9.4,77.99001,118.,397.,9.46,78., &118.,397.,5000.,300.,900.,7*0.,2*.325,.5,1.6,5.,40.,60.,200., &2*0.,.2,.1,0.,.11,.16,.048,4*0./ DATA PWID/2.8,20.,2.8,20.,.148,.4,.05,.2,.052,.2,.153,.4,.01,.1, &.004,.015,.115,.14,.115,.14,.115,.14,.115,.14,.036,.035,.036, &.035,.039,.04,.009,.05,.01,.05,26*0./ DATA KFR/0,16,17,19,100,104,109,115,0,26,27,29,122,126,131,137, &0,40,42,47,144,158,178,205,0,1,3,6,10,15,21,28,0,0,56,57,240, &246,256,271,0,0,1,3,6,10,15,21,60,61,64,70,292,307,328,356, &0,1,3,6,10,15,21,28,16*0/ DATA CFR/0.5,0.25,0.5,0.25,1.,0.5,0.5,0.,0.5,0.,1.,1.,0.75,0., &0.5,0.,0.,1.,0.1667,0.3333,0.0833,0.6667,0.1667,0.3333,-3.,1., &-2.,-2.,1.,0.,0.,-3.,1.,1.,1.,5*0./ C...LUDAT3, DEVOTED TO PARTICLE DECAY PARAMETERS AND DATA DATA DPAR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16.,4.5,0.7, &0.,0.003,0.5,0.5,4*0./ DATA IDB/0,1,13,19,6*0,23,0,30,0,36,3*0,37,39,70,88,92,94,100, &106,107,108,110,112,114,117,118,119,122,126,129,5*0,131,133,134, &135,136,137,138,139,140,141,142,145,148,151,154,156,161,164,168, &169,171,173,174,177,180,183,185,187,190,191,192,193,194,195,196, &197,198,199,2*0,202,203,204,205,207,215,227,240,10*0,242,249, &3*250,5*257,5*264,5*271/ DATA (CBR(J),J=1,200)/.03,.088,.118,.176,.206,.264,.375,.518, &.661,.772,.915,1.,.08,.16,.24,.5,.76,1.,.82,.91,.99,1.,.175,.35, &.451,.669,.676,.693,1.,.1,.2,.3,.6,.9,2*1.,.5,1.,.07,.14,.194, &.265,.364,.464,.504,.527,.528,.544,.559,.574,.579,.584,.604,.634, &.649,.655,.666,.676,.686,.688,.69,.692,.694,.696,.699,.702,.707, &.92,1.,.182,.364,.405,.465,.525,.605,.607,.61,.615,.622,.632, &.647,.659,.664,.67,.676,.681,1.,.1,.2,.7,1.,.988,1.,.389,.708, &.945,.994,.999,1.,.427,.652,.952,.979,.998,3*1.,.667,1.,.667,1., &.515,1.,.49,.83,3*1.,.896,.983,1.,.495,.838,.987,1.,.069,.138,1., &.686,1.,.516,10*1.,.15,.3,1.,.15,.3,1.,.15,.3,1.,.15,.3,1.,.642, &1.,.045,.09,.6,.8,1.,.15,.3,1.,.05,.1,.6,2*1.,.67,1.,.33,2*1., &.88,.94,1.,.88,.94,1.,.88,.94,1.,.33,1.,.67,1.,.678,.914,10*1., &.15,.3/ DATA (CBR(J),J=201,400)/4*1.,.5,1.,.03,.06,.09,.135,.15,.165,.21, &1.,.02,.04,.06,.08,.1,.12,.17,.22,.27,.32,.37,1.,.02,.04,.06,.08, &.1,.12,.17,.22,.27,.32,.37,.42,1.,.5,1.,.112,.224,.274,.77,.85, &.99,2*1.,.112,.224,.274,.77,.85,.99,1.,.12,.24,.34,.67,.93,.97, &1.,.11,.22,.33,.64,.94,.97,2*1.,129*0./ DATA (KDP(J),J=1,320)/7,-7,2*0,8,-8,2*0,9,-9,2*0,10,-10,2*0,11, &-11,2*0,12,-12,2*0,501,-501,2*0,502,-502,2*0,503,-503,2*0,504, &-504,2*0,505,-505,2*0,506,-506,2*0,-7,8,2*0,-9,10,2*0,-11,12,2*0, &501,-502,2*0,504,-503,2*0,506,-505,2*0,505,-505,2*0,11,-11,2*0, &504,-504,2*0,503,-503,2*0,-12008,7,12,0,-12010,9,12,0,12,-17,2*0, &12,-27,2*0,12,-18,2*0,12,-28,2*0,-13501,502,12,0,-12008,7,14,0, &-12010,9,14,0,-12012,11,14,0,-12501,502,14,0,-12504,503,14,0, &-12506,505,14,0,6591,592,2*0,37,3*0,38,3*0,-12007,8,503,-501, &-12009,10,503,-501,-18,17,2*0,-28,17,2*0,-18,27,2*0,-28,27,2*0, &-19,23,2*0,-29,23,2*0,-19,33,2*0,-29,33,2*0,-19,24,2*0,-29,24, &2*0,-19,25,2*0,-29,25,2*0,-19,34,2*0,-29,34,2*0,-19,35,2*0,-18, &18,2*0,-28,18,2*0,-18,28,2*0,-28,28,2*0,-19,19,2*0,-29,19,2*0, &-19,29,2*0,-29,29,2*0,17,-17,2*0,27,-17,2*0,17,-27,2*0,27,-27, &2*0,7501,-502,503,-501,7503,-502,2*0,-12007,8,503,-502,-12009,10, &503,-502,-19,17,2*0,-29,17,2*0,-19,27,2*0,-29,27,2*0,24,17,2*0, &24,27,2*0,25,17,2*0,25,27,2*0,35,17,2*0/ DATA (KDP(J),J=321,640)/35,27,2*0,18,-19,2*0,18,-29,2*0,28,-19, &2*0,28,-29,2*0,2*17,-17,0,7501,-502,503,-502,-12007,8,503,-503, &-12009,10,503,-503,6501,-502,503,-503,6501,-502,2*0,2*1,2*0,1,7, &-7,0,2*1,2*0,3*23,0,17,-17,23,0,1,17,-17,0,1,7,-7,0,17,-17,7,-7, &17,-17,24,0,2*23,24,0,1,33,2*0,1,34,2*0,2*1,2*0,3*23,0,8591,592, &2*0,3017,23,2*0,3019,17,2*0,3018,23,2*0,3018,-17,2*0,3019,23,2*0, &3020,23,2*0,20,1,2*0,3020,17,2*0,3021,23,2*0,21,1,2*0,22,1,2*0, &3017,-17,2*0,1017,-17,23,0,1,23,2*0,3017,-17,2*0,3018,-18,2*0, &3037,38,2*0,1017,-17,23,0,1,24,2*0,7,-7,2*0,9,-9,2*0,8591,592, &2*0,17,-17,2*0,2*23,2*0,41,23,2*0,42,17,2*0,57,1,2*0,42,-17,2*0, &57,23,2*0,57,-17,2*0,58,17,2*0,58,23,2*0,58,-17,2*0,59,1,2*0,60, &1,2*0,-12007,8,503,533,-12009,10,503,533,6501,-502,503,533, &-12007,8,503,541,-12009,10,503,541,6501,-502,503,541,-12007,8, &503,542,-12009,10,503,542,6501,-502,503,542,-12007,8,503,543, &-12009,10,503,543,6501,-502,503,543,41,-17,2*0,42,23,2*0,-12007, &8,503,512,-12009,10,503,512,6501,-502,503,512,6531,501,2*0,6513, &501,2*0/ DATA (KDP(J),J=641,960)/-12007,8,503,513,-12009,10,503,513,6501, &-502,503,513,-12007,8,503,523,-12009,10,503,523,6501,-502,503, &523,6533,501,2*0,41,17,2*0,41,23,2*0,42,17,2*0,41,-17,2*0,42,23, &2*0,42,-17,2*0,57,17,2*0,43,23,2*0,44,17,2*0,57,23,2*0,43,-17, &2*0,45,17,2*0,57,-17,2*0,44,-17,2*0,45,23,2*0,46,23,2*0,47,17, &2*0,46,-17,2*0,47,23,2*0,57,-18,2*0,46,-17,2*0,47,23,2*0,58,17, &2*0,58,23,2*0,58,-17,2*0,59,1,2*0,60,1,2*0,53,1,2*0,54,1,2*0,55, &1,2*0,56,1,2*0,-12007,8,503,544,-12009,10,503,544,6501,-502,503, &544,2*500,2*0,2*500,2*0,2*500,2*0,5003,507,-508,0,-5003,-507,508, &0,7,-7,2*0,9,-9,2*0,11,-11,2*0,501,-501,2*0,502,-502,2*0,503, &-503,2*0,504,-504,2*0,2*500,2*0,7,-7,2*0,8,-8,2*0,9,-9,2*0,10, &-10,2*0,11,-11,2*0,12,-12,2*0,501,-501,2*0,502,-502,2*0,503,-503, &2*0,504,-504,2*0,505,-505,2*0,2*500,2*0,7,-7,2*0,8,-8,2*0,9,-9, &2*0,10,-10,2*0,11,-11,2*0,12,-12,2*0,501,-501,2*0,502,-502,2*0, &503,-503,2*0,504,-504,2*0,505,-505,2*0,506,-506,2*0,2*500,2*0, &5003,507,-508,0/ DATA (KDP(J),J=961,1280)/-5003,-507,508,0,-12008,7,504,590, &-12010,9,504,590,-12012,11,504,590,-13501,502,504,590,-13501,504, &502,590,-13504,503,504,590,-13504,504,503,590,6001,505,590,0, &-12008,7,504,590,-12010,9,504,590,-12012,11,504,590,-13501,502, &504,590,-13501,504,502,590,-13504,503,504,590,-13504,504,503,590, &-11007,8,505,590,-11009,10,505,590,-11011,12,505,590,-11502,501, &505,590,-11503,504,505,590,-11502,505,501,590,-11503,505,504,590, &-11008,7,506,590,-11010,9,506,590,-11012,11,506,590,-11501,502, &506,590,-11504,503,506,590,-11501,506,502,590,-11504,506,503,590, &5003,507,590,197*0/ DATA (KDP(J),J=1281,1600)/320*0/ C...LUDAT4, CONTAINING CHARACTER STRINGS DATA CHAG/' ','HA','LA','TA','BA','CA','SA','DA','UA','G','U','D', &'S','C','B','T','L','H','SPEC','QRA','QBRA','JET','B--','B-','B', &'B+',' ','-','0','+','++','1','0','*',' ','DFBV','JQ','IQ', &' ',' ','STAB','UNST',8*' '/ DATA CHAF/'GAMM','Z0','W','HIGG','GA/Z',' ','E','NUE','MU', &'NUMU','TAU','NUTA','CHI','NUCH','PHAS',' ','PI',2*'K',2*'D','F', &'PI0','ETA','ETA''','ETAC','RHO',2*'K*',2*'D*','F*','RHO0', &'OMEG','PHI','JPSI','K0S','K0L',2*' ','P','N',3*'SIG',2*'XI', &3*'SIC','CSU1','CSD1','CSS1','CCU1','CCD1','CCS1','LAM','LAMC', &'CSU0','CSD0',4*'DELT',3*'SIG*',2*'XI*','OME*',3*'SIC*','CSU*', &'CSD*','CSS*','CCU*','CCD*','CCS*','CCC*',2*' ','ETAB','ETAT', &'ETAL','ETAH','UPSI','PHIT','PHIL','PHIH','R','HIGG','Z''0', &7*' '/ END C********************************************************************* C*** JETSET VERSION 6.3, E+E- PART ********************************* SUBROUTINE LUEEVT(IFL,ECM) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...PRINTOUT OR RESETTING OF STATISTICS IF(IFL.GE.10) CALL LUESTA(IFL,0,0,0.,0,0.,0) IF(IFL.GE.10) RETURN C...INITIALIZE TOTAL CROSS SECTION IF(MST(19).GE.1) CALL LULIST(-1) IF(MSTE(9).GT.0.AND.(MSTE(9).GE.2.OR.ABS(ECM-PARE(51)).GE. &PARE(17).OR.10*MSTE(2)+IFL.NE.MSTE(36))) CALL LUXTOT(IFL,ECM, &XTOT) IF(MSTE(9).GE.3) MSTE(9)=1 C...ADD INITIAL E+E- TO EVENT RECORD (DOCUMENTATION ONLY) NTRY=0 100 NTRY=NTRY+1 NC=0 IF(MSTE(30).GE.2) THEN NC=NC+2 CALL LUPART(NC-1,7,0.5*ECM,0.,0.) K(NC-1,1)=40000 CALL LUPART(NC,-7,0.5*ECM,PAR(71),0.) K(NC,1)=40000 ENDIF C...RADIATIVE PHOTON (IN INITIAL STATE) MK=0 ECMC=ECM IF(MSTE(7).GE.1.AND.MSTE(9).GE.1) CALL LURADK(ECM,MK,PAK, &THEK,PHIK,ALPK) IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK)) IF(MSTE(30).GE.1.AND.MK.EQ.1) THEN NC=NC+1 CALL LUPART(NC,1,PAK,THEK,PHIK) K(NC,1)=MIN(MSTE(30)/2,1) ENDIF C...VIRTUAL EXCHANGE BOSON (GAMMA OR Z0) IF(MSTE(30).GE.3) THEN NC=NC+1 KF=1 IF(MSTE(2).EQ.2) KF=5 MST(9)=1 P(NC,5)=ECMC CALL LUPART(NC,KF,ECMC,0.,0.) K(NC,1)=50001 MST(9)=0 ENDIF C...CHOICE OF FLAVOUR AND JET CONFIGURATION CALL LUXIFL(IFL,ECM,ECMC,IFLC) IF(IFLC.EQ.0) GOTO 100 CALL LUXJET(ECMC,NJET,CUT) IFLN=0 IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,IFLC,ECMC,IFLN,X1,X2,X4, &X12,X14) IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,IFLC,ECMC,X1,X3) IF(NJET.EQ.2) MSTE(35)=1 C...FILL JET CONFIGURATION AND ORIGIN IF(NJET.EQ.2) CALL LU2JET(NC+1,IFLC,-IFLC,ECMC) IF(NJET.EQ.3) CALL LU3JET(NC+1,IFLC,-IFLC,ECMC,X1,X3) IF(NJET.EQ.4) CALL LU4JET(NC+1,IFLC,-IFLN,IFLN,-IFLC,ECMC, &X1,X2,X4,X12,X14) DO 110 IP=NC+1,N 110 K(IP,1)=K(IP,1)+MIN(MSTE(30)/2,1)+(MSTE(30)/3)*(NC-1) C...ANGULAR ORIENTATION ACCORDING TO MATRIX ELEMENT IF(MSTE(6).EQ.1) THEN CALL LUXDIF(NC,NJET,IFLC,ECMC,CHI,THE,PHI) MST(1)=NC+1 CALL LUROBO(0.,CHI,0.,0.,0.) CALL LUROBO(THE,PHI,0.,0.,0.) MST(1)=0 ENDIF C...ROTATION AND BOOST FROM RADIATIVE PHOTON IF(MK.EQ.1) THEN BEK=-PAK/(ECM-PAK) MST(1)=NC+1-MSTE(30)/3 CALL LUROBO(0.,-PHIK,0.,0.,0.) CALL LUROBO(ALPK,0.,BEK*SIN(THEK),0.,BEK*COS(THEK)) CALL LUROBO(0.,PHIK,0.,0.,0.) MST(1)=0 ENDIF NC=N IF(MSTE(1).GE.3) THEN C...PREPARE EVENT RECORD FOR PARTON SHOWER EVOLUTION K(N+1,1)=K(N,1) K(N+1,2)=K(N,2) DO 120 J=1,5 120 P(N+1,J)=P(N,J) N=N+2 DO 130 I=N-2,N,2 K(I,1)=70000+I-1 K(I,2)=1000+MOD(K(I-1,1),1000) DO 130 J=1,5 130 P(I,J)=0. P(N-2,1)=N-1 P(N,2)=N-3 C...GENERATE PARTON SHOWER, REARRANGE ALONG STRINGS AND CHECK MSTE(13)=MSTE(13)+1 CALL LUSHOW(N-3,N-1,ECMC) MSTE(13)=MSTE(13)-1 NJET=0 IFLN=-2 DO 140 I=1,N IF(K(I,1).LT.20000.AND.IABS(K(I,2)).GE.500) NJET=NJET+1 140 IF(K(I,1).LT.20000.AND.IABS(K(I,2)).GE.501) IFLN=IFLN+1 MST12S=MST(12) IF(MSTE(5).EQ.-1) MST(12)=0 MST21S=MST(21) IF(MSTE(30).LE.3) MST(21)=1 IF(MSTE(30).GE.4) MST(21)=0 IF(MSTE(5).GE.0) MST(26)=0 CALL LUPREP MST(12)=MST12S MST(21)=MST21S IF(MSTE(5).GE.0.AND.MST(26).NE.0) GOTO 100 NC=N+1 150 NC=NC-1 IF(IABS(K(NC,2)).LT.500.AND.MOD(K(NC,1),10000).GT.0) THEN IF(K(MOD(K(NC,1),10000),1)/20000.EQ.1) GOTO 150 ENDIF ENDIF C...EVENT GENERATION AND STATISTICS IF(MSTE(5).EQ.1) CALL LUEXEC IF(NJET.EQ.4.AND.IFLN.NE.0) NJET=-4 IF(MSTE(31).NE.0) CALL LUESTA(IFLC,NJET,NC,ECM,MK,ECMC,NTRY) RETURN END C********************************************************************* SUBROUTINE LUXTOT(IFL,ECM,XTOT) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...STATUS, ALPHA-STRONG, CALCULATE Z0 WIDTH FOR MSTE(2)=3 PARE(51)=ECM MSTE(36)=10*MSTE(2)+IFL ALSPI=ULALPS(ECM**2)/PAR(71) RQCD=1. IF(IABS(MSTE(1)).EQ.1) RQCD=1.+ALSPI IF(IABS(MSTE(1)).GE.2) RQCD=1.+ALSPI+PARE(65)*ALSPI**2 IF(MSTE(2).GE.3) THEN RVA=3.*(3.+(4.*PARE(5)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARE(5)/ & 3.)**2+(4.*PARE(5)/3.-1.)**2) DO 100 IFLC=5,6 VQ=1. IF(MOD(MSTE(3),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*ULMASS(2,IFLC)/ & ECM)**2)) IF(IFLC.EQ.5) VF=4.*PARE(5)/3.-1. IF(IFLC.EQ.6) VF=1.-8.*PARE(5)/3. 100 RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3) PARE(7)=PARE(4)*PARE(6)*RVA/(48.*PARE(5)*(1.-PARE(5))) ENDIF C...CALCULATE PROPAGATOR AND RELATED CONSTANTS FOR QFD CASE POLL=1.-PARE(11)*PARE(12) IF(MSTE(2).GE.2) THEN SFF=1./(16.*PARE(5)*(1.-PARE(5))) SFW=ECM**4/((ECM**2-PARE(6)**2)**2+(PARE(6)*PARE(7))**2) SFI=SFW*(1.-(PARE(6)/ECM)**2) VE=4.*PARE(5)-1. SF1I=SFF*(VE*POLL+PARE(12)-PARE(11)) SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARE(12)-PARE(11))) HF1I=SFI*SF1I HF1W=SFW*SF1W ENDIF C...LOOP OVER DIFFERENT FLAVOURS: CHARGE, VELOCITY RTOT=0. RQQ=0. RQV=0. RVA=0. DO 110 IFLC=1,MAX(MSTE(4),IFL) IF(IFL.GT.0.AND.IFLC.NE.IFL) GOTO 110 PMQ=ULMASS(2,IFLC) IF(ECM.LT.2.*PMQ+PARE(10)) GOTO 110 QF=2./3. IF(IFLC.EQ.2.OR.IFLC.EQ.3.OR.IFLC.EQ.5.OR.IFLC.EQ.7) QF=-1./3. VQ=1. IF(MOD(MSTE(3),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(MSTE(2).LE.1) THEN RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL ELSE VF=SIGN(1.,QF)-4.*QF*PARE(5) 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(MSTE(2).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA C...CALCULATE CROSS SECTION INCLUDING QCD CORRECTIONS PARE(41)=RQQ PARE(42)=RTOT PARE(43)=RTOT*RQCD PARE(44)=PARE(43) PARE(45)=PARE(41)*86.8/ECM**2 PARE(46)=PARE(42)*86.8/ECM**2 PARE(47)=PARE(43)*86.8/ECM**2 PARE(48)=PARE(47) PARE(57)=RSUM*RQCD PARE(58)=0. PARE(59)=0. XTOT=PARE(47) IF(MSTE(7).LE.0) RETURN C...VIRTUAL CROSS SECTION, SOFT AND HARD RADIATIVE X-SECT IN QED CASE XKL=PARE(15) XKU=MIN(PARE(16),1.-(2.*PARE(10)/ECM)**2) ALE=2.*ALOG(ECM/ULMASS(0,7))-1. SIGV=ALE/3.+2.*ALOG(ECM**2/(ULMASS(0,9)*ULMASS(0,11)))/3.-4./3.+ &1.526*ALOG(ECM**2/0.932) IF(MSTE(2).LE.1) THEN SIGV=1.5*ALE-0.5+PAR(71)**2/3.+2.*SIGV SIGS=ALE*(2.*ALOG(XKL)-ALOG(1.-XKL)-XKL) SIGH=ALE*(2.*ALOG(XKU/XKL)-ALOG((1.-XKU)/(1.-XKL))-(XKU-XKL)) C...DITTO IN QFD CASE, TOTAL X-SECT AND FRACTION HARD PHOTON EVENTS ELSE SZM=1.-(PARE(6)/ECM)**2 SZW=PARE(6)*PARE(7)/ECM**2 PARE(61)=-RQQ/RSUM PARE(62)=-(RQQ+RQV+RVA)/RSUM PARE(63)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM PARE(64)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM- & SZM**2))/(SZW*RSUM) SIGV=1.5*ALE-0.5+PAR(71)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+ & (SZW*SFW*RQV/RSUM)*PAR(71)*20./9. SIGS=ALE*(2.*ALOG(XKL)+PARE(61)*ALOG(1.-XKL)+PARE(62)*XKL+ & PARE(63)*ALOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+ & PARE(64)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW))) SIGH=ALE*(2.*ALOG(XKU/XKL)+PARE(61)*ALOG((1.-XKU)/(1.-XKL))+ & PARE(62)*(XKU-XKL)+PARE(63)*ALOG(((XKU-SZM)**2+SZW**2)/ & ((XKL-SZM)**2+SZW**2))+PARE(64)*(ATAN((XKU-SZM)/SZW)- & ATAN((XKL-SZM)/SZW))) ENDIF PARE(60)=SIGH/(PAR(71)/PARE(4)+SIGV+SIGS+SIGH) PARE(57)=RSUM*(1.+(PARE(4)/PAR(71))*(SIGV+SIGS+SIGH))*RQCD PARE(44)=PARE(57) PARE(48)=PARE(44)*86.8/ECM**2 XTOT=PARE(48) RETURN END C********************************************************************* SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...FUNCTION: CUMULATIVE HARD PHOTON SPECTRUM IN QFD CASE FXK(XK)=2.*ALOG(XK)+PARE(61)*ALOG(1.-XK)+PARE(62)*XK+PARE(63)* &ALOG((XK-1.+(PARE(6)/ECM)**2)**2+(PARE(6)*PARE(7)/ECM**2)**2)+ &PARE(64)*ATAN((ECM**2*(XK-1.)+PARE(6)**2)/(PARE(6)*PARE(7))) C...DETERMINE WHETHER RADIATIVE PHOTON OR NOT MK=0 PAK=0. IF(PARE(60).LT.RLU(0)) RETURN MK=1 C...FIND PHOTON MOMENTUM IN QED CASE XKL=PARE(15) XKU=MIN(PARE(16),1.-(2.*PARE(10)/ECM)**2) IF(MSTE(2).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 FXKL=FXK(XKL) FXKU=FXK(XKU) DFXK=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.DFXK) 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(0,7)/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=PAR(72)*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 END C********************************************************************* SUBROUTINE LUXIFL(IFL,ECM,ECMC,IFLC) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...CALCULATE MAXIMUM WEIGHT IN QED OR QFD CASE IF(MSTE(2).LE.1) THEN RFMAX=4./9. ELSE POLL=1.-PARE(11)*PARE(12) SFF=1./(16.*PARE(5)*(1.-PARE(5))) SFW=ECMC**4/((ECMC**2-PARE(6)**2)**2+(PARE(6)*PARE(7))**2) SFI=SFW*(1.-(PARE(6)/ECMC)**2) VE=4.*PARE(5)-1. HF1I=SFI*SFF*(VE*POLL+PARE(12)-PARE(11)) HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARE(12)-PARE(11))) RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARE(5)/3.)*HF1I+ & ((1.-8.*PARE(5)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.* & (-1.+4.*PARE(5)/3.)*HF1I+((-1.+4.*PARE(5)/3.)**2+1.)*HF1W) ENDIF C...CHOOSE FLAVOUR, GIVES CHARGE AND VELOCITY 100 IFLC=IFL IF(IFL.LE.0) IFLC=1+INT(MSTE(4)*RLU(0)) PMQ=ULMASS(2,IFLC) IF(ECM.LT.2.*PMQ+PARE(10)) GOTO 100 QF=2./3. IF(IFLC.EQ.2.OR.IFLC.EQ.3.OR.IFLC.EQ.5.OR.IFLC.EQ.7) QF=-1./3. VQ=1. IF(MOD(MSTE(3),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2)) C...CALCULATE WEIGHT IN QED OR QFD CASE IF(MSTE(2).LE.1) THEN RF=QF**2 RFV=0.5*VQ*(3.-VQ**2)*QF**2 ELSE VF=SIGN(1.,QF)-4.*QF*PARE(5) 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(IFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100 PARE(58)=PARE(58)+1. IF(ECMC.LT.2.*PMQ+PARE(10).OR.RFV.LT.RLU(0)*RF) IFLC=0 IF(MSTE(7).LE.0.AND.IFLC.EQ.0) GOTO 100 IF(IFLC.NE.0) PARE(59)=PARE(59)+1. PARE(44)=PARE(57)*PARE(59)/PARE(58) PARE(48)=PARE(44)*86.8/ECM**2 RETURN END C********************************************************************* SUBROUTINE LUXJET(ECM,NJET,CUT) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...ALPHA-STRONG, TOTAL CROSS SECTION, INITIAL VALUE FOR CUT ALSPI=ULALPS(ECM**2)/PAR(71) RQCD=1.+ALSPI IF(IABS(MSTE(1)).GE.2) RQCD=1.+ALSPI+PARE(65)*ALSPI**2 CUT=MAX(0.001,(PARE(9)/ECM)**2,PARE(8),EXP(-SQRT(0.75/ALSPI))/2.) IF(IABS(MSTE(1)).GE.2) CUT=MAX(CUT,0.2*ALSPI) C...PARAMETRIZATION OF FIRST AND SECOND ORDER THREE-JET CROSS SECTION 100 IF(MSTE(1).EQ.0.OR.MSTE(1).GE.3.OR.CUT.GE.0.25) THEN PARE(52)=0. ELSE PARE(52)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*ALOG(CUT))*ALOG(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 ENDIF IF(IABS(MSTE(1)).LE.1.OR.MSTE(1).GE.3.OR.CUT.GE.0.25) THEN PARE(53)=0. ELSE CT=ALOG(1./CUT-2.) PARE(53)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2- & 0.2661*CT**3+0.01159*CT**4)/RQCD ENDIF C...PARAMETRIZATION OF SECOND ORDER FOUR-JET CROSS SECTION IF(IABS(MSTE(1)).LE.1.OR.MSTE(1).GE.3.OR.CUT.GE.0.125) THEN PARE(54)=0. ELSE CT=ALOG(1./CUT-5.) IF(CUT.LE.0.018) THEN XQQGG=6.349-4.330*CT+0.8304*CT**2 XQQQQ=-0.1080+0.01486*CT+0.009364*CT**2 ELSE XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3 XQQQQ=0.003661-0.004888*CT-0.001081*CT**2+0.002093*CT**3 ENDIF PARE(54)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD PARE(55)=XQQQQ/(XQQGG+XQQQQ) ENDIF C...IF TOO HIGH CROSS SECTION HARDER CUTS, ELSE CHOOSE JET NUMBER IF(PARE(52)+PARE(53)+PARE(54).GE.1.) THEN CUT=0.51*(2.*CUT)**SQRT(1./(PARE(52)+PARE(53)+PARE(54))) GOTO 100 ENDIF PARE(50)=CUT IF(MSTE(1).LE.0) THEN NJET=MIN(4,2-MSTE(1)) ELSEIF(MSTE(1).GE.3) THEN NJET=2 ELSE RNJ=RLU(0) NJET=2 IF(PARE(52)+PARE(53)+PARE(54).GT.RNJ) NJET=3 IF(PARE(54).GT.RNJ) NJET=4 ENDIF RETURN END C********************************************************************* SUBROUTINE LUX3JT(NJET,CUT,IFL,ECM,X1,X2) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) 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 MSTE(35)=2 PMQ=ULMASS(2,IFL) QME=(2.*PMQ/ECM)**2 CUTL=ALOG(CUT) CUTD=ALOG(1./CUT-2.) WTMX=MIN(20.,37.-6.*CUTD) 100 NJET=3 C...CHOOSE THREE-JET EVENTS IN ALLOWED REGION 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(MSTE(1).EQ.2) THEN Y12L=ALOG(Y12) Y13M=ALOG(1.-Y13) Y23M=ALOG(1.-Y23) Y12M=ALOG(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=(4./3.)*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+ & 2.*(2.*CUTL-Y12L)*CUT/Y12)+3.*((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)+ & 2.*(2.*CUTL/3.-10./9.)+(4./3.)*(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+ & 3.*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+ & (1./3.)*((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- & 3.*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I) IF(1.+PARE(49)*WT2/PAR(72).LE.(1.+PARE(49)*WTMX/PAR(72))* & RLU(0)) GOTO 110 PARE(56)=PARE(49)*WT2/PAR(72)/(1.+PARE(49)*WT2/PAR(72)) 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(MSTE(3),4).GE.2.AND.IABS(MSTE(1)).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(MSTE(1).EQ.-1.AND.NJET.EQ.2) GOTO 100 RETURN END C********************************************************************* SUBROUTINE LUX4JT(NJET,CUT,IFL,ECM,IFLN,X1,X2,X4,X12,X14) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4) C...COMMON CONSTANTS, CHOICE OF PROCESS (QQGG OR QQQQ) PMQ=ULMASS(2,IFL) QME=(2.*PMQ/ECM)**2 CT=ALOG(1./CUT-5.) 100 NJET=4 IT=1 IF(PARE(55).GT.RLU(0)) IT=2 IF(MSTE(1).LE.-3) IT=-MSTE(1)-2 IF(IT.EQ.1) WTMX=0.7/CUT**2 IF(IT.EQ.2) WTMX=0.3/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(PAR(71)*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 ELEMENT 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*(4.*WTA(IC)-0.5*WTB(IC)+9.*WTC(IC))/18. 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+(2.*WTD(IC)-WTE(IC)/6.)/12. 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 IF(IT.EQ.1) THEN C...QQGG EVENTS: STRING CONFIGURATION, EVENT TYPE IF(ID.EQ.1) THEN 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 ENDIF MSTE(35)=3 IF(0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.RLU(0)*WTTOT) & MSTE(35)=4 PARE(56)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+ & WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT) IFLN=0 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 ELSE C...QQQQ EVENTS: STRING CONFIGURATION, CHOOSE NEW FLAVOUR 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 MSTE(35)=5 PARE(56)=(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(6.*WTTOT) 140 IFLN=1+INT(4.*RLU(0)) IF(IFLN.NE.IFL.AND.0.25*PARE(56).LE.RLU(0)) GOTO 140 IF(IFLN.EQ.IFL.AND.1.-0.75*PARE(56).LE.RLU(0)) GOTO 140 IF(IFLN.GT.MSTE(4)) NJET=2 PMQN=ULMASS(2,IFLN) 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.(PARE(10)+PMQ+PMQN)**2) & NJET=2 IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2 ENDIF 150 IF(MSTE(1).LE.-2.AND.NJET.EQ.2) GOTO 100 RETURN END C********************************************************************* SUBROUTINE LUXDIF(NC,NJET,IFL,ECM,CHI,THE,PHI) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...CHARGE, FACTORS DEPENDING ON POLARIZATION FOR QED CASE QF=2./3. IF(IFL.EQ.2.OR.IFL.EQ.3.OR.IFL.EQ.5.OR.IFL.EQ.7) QF=-1./3. POLL=1.-PARE(11)*PARE(12) POLD=PARE(12)-PARE(11) IF(MSTE(2).LE.1) THEN HF1=POLL HF2=0. HF3=PARE(13)**2 HF4=0. C...FACTORS DEPENDING ON FLAVOUR, ENERGY AND POLARIZATION FOR QFD CASE ELSE SFF=1./(16.*PARE(5)*(1.-PARE(5))) SFW=ECM**4/((ECM**2-PARE(6)**2)**2+(PARE(6)*PARE(7))**2) SFI=SFW*(1.-(PARE(6)/ECM)**2) AE=-1. VE=4.*PARE(5)-1. AF=SIGN(1.,QF) VF=AF-4.*QF*PARE(5) 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=PARE(13)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)* & SFW*SFF**2*(VE**2-AE**2)) HF4=-PARE(13)**2*2.*QF*VF*SFW*(PARE(6)*PARE(7)/ECM**2)*SFF*AE ENDIF C...MASS FACTOR, DIFFERENTIAL CROSS SECTIONS FOR TWO-JET EVENTS SQ2=SQRT(2.) QME=0. IF(MSTE(3).GE.4.AND.IABS(MSTE(1)).LE.1.AND.MSTE(2).LE.1) QME= &(2.*ULMASS(2,IFL)/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-JETS (OR REDUCED FOUR-JETS) 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) 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) ENDIF C...UPPER BOUND 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 SECTION 100 CHI=PAR(72)*RLU(0) CTHE=2.*RLU(0)-1. PHI=PAR(72)*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-PARE(14))) S2PHI=SIN(2.*(PHI-PARE(14))) 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 END C********************************************************************* SUBROUTINE LUONIA(IFL,ECM) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...PRINTOUT OR RESETTING OF STATISTICS IF(IFL.GE.10) CALL LUESTA(IFL,0,0,0.,0,0.,0) IF(IFL.GE.10) RETURN IF(MST(19).GE.1) CALL LULIST(-1) C...INITIAL E+E- AND ONIUM STATE (OPTIONAL) NC=0 IF(MSTE(30).GE.2) THEN NC=NC+2 CALL LUPART(NC-1,7,0.5*ECM,0.,0.) K(NC-1,1)=40000 CALL LUPART(NC,-7,0.5*ECM,PAR(71),0.) K(NC,1)=40000 ENDIF IFLC=IABS(IFL) IF(MSTE(30).GE.3.AND.IFLC.GE.5) THEN NC=NC+1 KF=82+IABS(IFL) MST(9)=1 P(NC,5)=ECM CALL LUPART(NC,KF,ECM,0.,0.) K(NC,1)=50001 MST(9)=0 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 CALL LU3JET(NC+1,0,0,ECM,X1,X3) C...PHOTON-GLUON-GLUON EVENTS, SMALL SYSTEM MODIFICATIONS, JET ORIGIN QF=0. IF(IFLC.EQ.1.OR.IFLC.EQ.4.OR.IFLC.EQ.6.OR.IFLC.EQ.8) QF=2./3. IF(IFLC.EQ.2.OR.IFLC.EQ.3.OR.IFLC.EQ.5.OR.IFLC.EQ.7) QF=-1./3. RGAM=7.2*QF**2*PARE(4)/ULALPS(ECM**2) MK=0 ECMC=ECM IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN IF(1.-MAX(X1,X2,X3).LE.MAX((PARE(9)/ECM)**2,PARE(8))) NJET=2 IF(NJET.EQ.2) CALL LU2JET(NC+1,0,0,ECM) ELSE MK=1 ECMC=SQRT(1.-X1)*ECM IF(ECMC.LT.2.*PARE(10)) GOTO 100 K(NC+1,1)=0 K(NC+1,2)=1 NJET=2 IF(ECMC.LT.4.*PARE(10)) NJET=0 MST(9)=1 IF(NJET.EQ.0) P(NC+2,5)=ECMC IF(NJET.EQ.0) CALL LUPART(NC+2,15,0.5*(X2+X3)*ECM,PAR(71),1.) MST(9)=0 ENDIF DO 110 IP=NC+1,N 110 K(IP,1)=K(IP,1)+(MSTE(30)/2)+(IFLC/5)*(MSTE(30)/3)*(NC-1) C...DIFFERENTIAL CROSS SECTIONS, UPPER LIMIT FOR CROSS SECTION IF(MSTE(6).EQ.1) THEN SQ2=SQRT(2.) HF1=1.-PARE(11)*PARE(12) HF3=PARE(13)**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=PAR(72)*RLU(0) CTHE=2.*RLU(0)-1. PHI=PAR(72)*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-PARE(14))) S2PHI=SIN(2.*(PHI-PARE(14))) 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 MST(1)=NC+1 CALL LUROBO(0.,CHI,0.,0.,0.) CALL LUROBO(THE,PHI,0.,0.,0.) MST(1)=0 ENDIF IF(MSTE(1).GE.3.AND.NJET.GE.2) THEN C...PREPARE EVENT RECORD FOR PARTON SHOWER EVOLUTION DO 130 I=NJET,2,-1 K(NC+MK+2*I-1,1)=K(NC+MK+I,1) K(NC+MK+2*I-1,2)=K(NC+MK+I,2) DO 130 J=1,5 130 P(NC+MK+2*I-1,J)=P(NC+MK+I,J) DO 140 I=NC+MK+2,NC+MK+2*NJET,2 K(I,1)=70000+I-1 K(I,2)=1000+MOD(K(I-1,1),1000) P(I,1)=I-3 P(I,2)=I+1 P(I,3)=0. P(I,4)=0. 140 P(I,5)=0. P(NC+MK+2,1)=NC+MK+2*NJET-1 P(NC+MK+2*NJET,2)=NC+MK+1 N=N+NJET C...GENERATE PARTON SHOWER, REARRANGE ALONG STRINGS AND CHECK CALL LUSHOW(NC+MK+1,-NJET,ECMC) NJET=0 DO 150 I=1,N 150 IF(K(I,1).LT.20000.AND.IABS(K(I,2)).GE.500) NJET=NJET+1 MST12S=MST(12) IF(MSTE(5).EQ.-1) MST(12)=0 MST21S=MST(21) IF(MSTE(30).LE.3) MST(21)=1 IF(MSTE(30).GE.4) MST(21)=0 IF(MSTE(5).GE.0) MST(26)=0 CALL LUPREP MST(12)=MST12S MST(21)=MST21S IF(MSTE(5).GE.0.AND.MST(26).NE.0) GOTO 100 NC=N+1 160 NC=NC-1 IF(IABS(K(NC,2)).LT.500.AND.MOD(K(NC,1),10000).GT.0) THEN IF(K(MOD(K(NC,1),10000),1)/20000.EQ.1) GOTO 160 ENDIF ELSE NJET=3-MK ENDIF C...EVENT GENERATION AND STATISTICS NC=N IF(MSTE(5).EQ.1) CALL LUEXEC IF(MSTE(31).NE.0) CALL LUESTA(9,3-MK,NC,ECM,MK,ECMC,NTRY) RETURN END C*********************************************************************** SUBROUTINE LUESTA(IFL,NJET,NC,ECM,MK,ECMC,NTRY) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDAT3/DPAR(20),IDB(120),CBR(400),KDP(1600) COMMON/LUDAT4/CHAG(50),CHAF(100) COMMON/LUDATE/MSTE(40),PARE(80) CHARACTER CHAG*4,CHAF*4,CHAP*8,CHAD*4 DIMENSION LFL(10,10),LKF(400,4),ECMS(2) DATA LFL/100*0/,LKF/1600*0/,ECMS/2*0./,NTRYS/0/ C...FILL STATISTICS ON INITIAL STATE OF EVENT IF(IFL.LT.10) THEN ECMS(1)=ECMS(1)+ECM ECMS(2)=ECMS(2)+ECMC NJT=NJET IF(NJET.LT.0) NJT=5 IF(NJET.GE.5) NJT=MIN(NJET+1,9) LFL(1,1)=LFL(1,1)+1 LFL(1,NJT)=LFL(1,NJT)+1 IF(MK.EQ.1) LFL(1,10)=LFL(1,10)+1 IF(IFL.GE.1) LFL(IFL+1,1)=LFL(IFL+1,1)+1 IF(IFL.GE.1) LFL(IFL+1,NJT)=LFL(IFL+1,NJT)+1 IF(IFL.GE.1.AND.MK.EQ.1) LFL(IFL+1,10)=LFL(IFL+1,10)+1 NTRYS=NTRYS+NTRY C...FILL STATISTICS ON FINAL STATE OF EVENT IF(IABS(MSTE(31)).LE.1) RETURN DO 100 I=1,N KFA=IABS(K(I,2)) IF(KFA.GE.400.OR.K(I,1).GE.40000) GOTO 100 IF(MOD(K(I,1),10000).LE.NC) LKF(400,1)=LKF(400,1)+1 IF(K(I,1).LT.20000) LKF(400,2)=LKF(400,2)+1 IF(K(I,1).LT.20000.AND.LUCHGE(KFA).NE.0) LKF(400,3)=LKF(400,3)+1 KFS=2-ISIGN(1,K(I,2)) IF(MOD(K(I,1),10000).GT.NC) KFS=KFS+1 LKF(KFA,KFS)=LKF(KFA,KFS)+1 100 CONTINUE C...WRITE E+E- PARAMETER TABLE AND INITIAL STATE STATISTICS ELSEIF(IFL.EQ.10) THEN IF(MSTE(31).GE.0) WRITE(MST(20),1000) (L,MSTE(L),MSTE(L+20), & PARE(L),PARE(L+20),PARE(L+40),PARE(L+60),L=1,20) IF(MSTE(31).EQ.0.OR.LFL(1,1).EQ.0) RETURN FAC=1./FLOAT(LFL(1,1)) IF(MSTE(31).EQ.-2) GOTO 120 WRITE(MST(20),1100) (FAC*ECMS(L),L=1,2),(LFL(1,J),J=1,10), & (FAC*LFL(1,J),J=2,10) DO 110 L=2,10 110 IF(LFL(L,1).NE.0) WRITE(MST(20),1200) L-1,CHAG(9+L-9*(L/10)), & (LFL(L,J),J=1,10),FAC*LFL(L,1),(LFL(L,J)/FLOAT(LFL(L,1)),J=2,10) WRITE(MST(20),1300) (NTRYS-LFL(1,1))/FLOAT(NTRYS) C...WRITE FINAL STATE STATISTICS 120 IF(IABS(MSTE(31)).LE.1) RETURN WRITE(MST(20),1400) (FAC*LKF(400,L),L=1,3) DO 130 L=1,399 LKFS=LKF(L,1)+LKF(L,2)+LKF(L,3)+LKF(L,4) IF(LKFS.EQ.0) GOTO 130 CALL LUNAME(L,CHAP) KFA=L IF(KFA.GT.100) CALL LUIFLV(KFA,IFLA,IFLB,IFLC,KSP) IF(KFA.GT.100) KFA=76+5*IFLA+KSP CHAD=CHAG(41) IF(IDB(KFA).GE.1) CHAD=CHAG(42) PM=ULMASS(0,L) WRITE(MST(20),1500) L,CHAP,CHAD,PM,(LKF(L,J),J=1,4),FAC*LKFS 130 CONTINUE C...RESET COUNTERS ELSE DO 140 L=1,10 DO 140 J=1,7 140 LFL(L,J)=0 DO 150 L=1,400 DO 150 J=1,4 150 LKF(L,J)=0 ECMS(1)=0. ECMS(2)=0. NTRYS=0 ENDIF C...FORMAT STATEMENTS FOR OUTPUT ON UNIT MST(20) (DEFAULT IS 6) 1000 FORMAT(///20X,'E+E- PARAMETER VALUE TABLE'//5X,'L MSTE(L) ', &'&(L+20) PARE(L) &(L+20) &(L+40) &(L+60)'/ &20(/1X,I5,2(1X,I7),4(1X,F12.4))) 1100 FORMAT(//20X,'EVENT STATISTICS - INITIAL STATE'//5X,'MEAN TOTAL', &' ENERGY =',F10.3/5X,'MEAN HADRONIC CM ENERGY =',F10.3//5X, &'NUMBER AND FRACTION OF EVENT TYPES'/5X,'FLAVOUR',7X,'ALL',7X, &'QQ QQG QQGG QQQQ 5JET 6JET 7JET',6X, &'>=8 RAD'//6X,'ALL',4X,10(1X,I8)/22X,9(1X,F8.3)) 1200 FORMAT(/1X,I5,3X,A4,10(1X,I8)/13X,10(1X,F8.3)) 1300 FORMAT(/5X,'FRACTION OF ORIGINAL EVENTS FAILING CUTS =',F10.4) 1400 FORMAT(//20X,'EVENT STATISTICS - FINAL STATE'//5X,'MEAN PRIMARY', &' MULTIPLICITY =',F8.3/5X,'MEAN FINAL MULTIPLICITY =',F8.3/ &5X,'MEAN CHARGED MULTIPLICITY =',F8.3//5X,'NUMBER AND FRACTION ', &'OF PARTICLES PRODUCED (DIRECTLY AND VIA DECAYS)'/41X,'PART', &'ICLES ANTIPARTICLES TOTAL/'/5X,'KF PARTICLE/DECAY', &5X,'MASS #PRIM #SECO #PRIM #SECO /EVENT'/) 1500 FORMAT(1X,I6,4X,A8,2X,A4,1X,F8.3,4(1X,I8),1X,F9.4) RETURN END C********************************************************************* SUBROUTINE LUSHOW(IP1,IP2,QMAX) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) DIMENSION PMTH(3,0:8),PS(5),PMA(4),PMSD(4),IEP(4), &IPA(4),IFLA(4),IFLD(4),IFL(4),ITRY(4),ISI(4),ISL(4) C...INITIALIZATION OF CUTOFF MASSES ETC. IF(MSTE(11).LE.0.OR.QMAX.LE.PARE(22)) RETURN DO 100 IF=0,8 PMTH(1,IF)=ULMASS(2,IF) PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PARE(22)**2) 100 PMTH(3,IF)=PMTH(2,0)+PMTH(2,IF) PT2MIN=MAX(0.5*PARE(22),1.1*PARE(21))**2 ALAMS=PARE(21)**2 ALFM=ALOG(PT2MIN/ALAMS) C...CHECK ON PHASE SPACE AVAILABLE FOR EMISSION: PAIR OR SINGLE PARTON M3JC=0 IF(IP1.GT.0.AND.IP2.EQ.0) THEN NPA=1 IPA(1)=IP1 ELSEIF(IP1.GT.0.AND.IP2.GT.0) THEN NPA=2 IPA(1)=IP1 IPA(2)=IP2 ELSEIF(IP1.GT.0.AND.IP2.LT.0) THEN NPA=IABS(IP2) DO 110 I=1,NPA 110 IPA(I)=IP1+2*(I-1) ELSE RETURN ENDIF IREJ=0 DO 120 J=1,5 120 PS(J)=0. PM=0. DO 130 I=1,NPA IFLA(I)=IABS(K(IPA(I),2))-500 PMA(I)=P(IPA(I),5) IF(IFLA(I).GE.0.AND.IFLA(I).LE.8) PMA(I)=PMTH(3,IFLA(I)) PM=PM+PMA(I) IF(IFLA(I).LT.0.OR.IFLA(I).GT.8.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+PARE(22)) RETURN IF(NPA.EQ.2.AND.MSTE(13).GE.2) THEN IF(IFLA(1).GE.1.AND.IFLA(1).LE.8.AND.IFLA(2).GE.1.AND. & IFLA(2).LE.8) M3JC=1 ENDIF C...DEFINE IMAGINED SINGLE INITIATOR OF SHOWER FOR PARTON SYSTEM NS=N IF(NPA.GE.2) THEN K(N+1,1)=0 K(N+1,2)=500 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) P(N+2,5)=PS(5)**2 N=N+2 ENDIF C...LOOP OVER PARTONS THAT MAY BRANCH NEP=NPA IM=NS-1 IF(NPA.EQ.1) IM=NS-3 140 IM=IM+2 IF(N.GT.NS) THEN IF(IM.GT.N) GOTO 330 IFLM=IABS(K(IM,2))-500 IF(IFLM.LT.0.OR.IFLM.GT.8) GOTO 140 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 140 IGM=MOD(K(IM,1),10000) ELSE IGM=-1 ENDIF C...ORIGIN AND FLAVOUR OF DAUGHTERS IF(IGM.GE.0) THEN K(IM+1,1)=N+1 DO 150 I=1,NEP 150 K(N+2*I-1,1)=IM ELSE K(N+1,1)=IPA(1) ENDIF IF(IGM.LE.0) THEN DO 160 I=1,NEP 160 K(N+2*I-1,2)=K(IPA(I),2) ELSEIF(IFLM.NE.0) THEN K(N+1,2)=K(IM,2) K(N+3,2)=500 ELSEIF(K(IM+1,2).EQ.500) THEN K(N+1,2)=500 K(N+3,2)=500 ELSE K(N+1,2)=K(IM+1,2) K(N+3,2)=-K(IM+1,2) ENDIF DO 170 IP=1,NEP IFLD(IP)=IABS(K(N+2*IP-1,2))-500 ITRY(IP)=0 ISL(IP)=0 ISI(IP)=0 170 IF(IFLD(IP).GE.0.AND.IFLD(IP).LE.8) ISI(IP)=1 ISLM=0 C...MAXIMUM VIRTUALITY OF DAUGHTERS IF(IGM.LE.0) THEN DO 180 I=1,NPA IMP=N+2*I-1 IF(NPA.GE.3) P(IMP,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(IMP,5)=MIN(QMAX,PS(5)) IF(NPA.GE.3) P(IMP,5)=MIN(P(IMP,5),P(IMP,4)) 180 IF(ISI(I).EQ.0) P(IMP,5)=P(IPA(I),5) ELSE IF(MSTE(12).LE.2) PEM=P(IM+1,2) IF(MSTE(12).GE.3) PEM=P(IM,4) P(N+1,5)=MIN(P(IM,5),P(IM+1,1)*PEM) P(N+3,5)=MIN(P(IM,5),(1.-P(IM+1,1))*PEM) ENDIF DO 190 I=1,NEP PMSD(I)=P(N+2*I-1,5) IF(ISI(I).EQ.1) THEN IF(P(N+2*I-1,5).LE.PMTH(3,IFLD(I))) P(N+2*I-1,5)=PMTH(1,IFLD(I)) ENDIF 190 P(N+2*I,5)=P(N+2*I-1,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+2*I-1,5).GE.PMTH(2,IFLD(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.PMTH(2,0)) THEN RPM=P(N+2*I-1,5)/PMSD(I) IF(RPM.GT.RMAX.AND.P(N+2*I-1,5).GE.PMTH(2,IFLD(I))) THEN RMAX=RPM INUM=I ENDIF ENDIF 230 CONTINUE ENDIF INUM=MAX(1,INUM) IEP(1)=N+2*INUM-1 DO 240 I=2,NEP IEP(I)=IEP(I-1)+2 240 IF(IEP(I).GE.N+2*NEP) IEP(I)=N+1 DO 250 I=1,NEP 250 IFL(I)=IABS(K(IEP(I),2))-500 ITRY(INUM)=ITRY(INUM)+1 Z=0.5 IF(IFL(1).LT.0.OR.IFL(1).GT.8) GOTO 290 IF(P(IEP(1),5).LT.PMTH(2,IFL(1))) GOTO 290 C...CALCULATE ALLOWED Z RANGE AND INTEGRAL OF ALTARELLI-PARISI Z KERNEL IF(NEP.EQ.1) THEN PMED=PS(4) ELSEIF(IGM.EQ.0.OR.MSTE(12).LE.2) THEN PMED=P(IM,5) ELSE IF(INUM.EQ.1) PMED=P(IM+1,1)*PEM IF(INUM.EQ.2) PMED=(1.-P(IM+1,1))*PEM ENDIF IF(MOD(MSTE(12),2).EQ.1) THEN ZC=PMTH(2,0)/PMED ELSE ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,0)/PMED)**2))) IF(ZC.LT.1E-4) ZC=(PMTH(2,0)/PMED)**2 ENDIF IF(ZC.GT.0.49) THEN P(IEP(1),5)=PMTH(1,IFL(1)) P(IEP(1)+1,5)=P(IEP(1),5)**2 GOTO 290 ENDIF IF(IFL(1).EQ.0) FBR=6.*ALOG((1.-ZC)/ZC)+MSTE(15)*(0.5-ZC) IF(IFL(1).NE.0) FBR=(8./3.)*ALOG((1.-ZC)/ZC) C...INNER VETO ALGORITHM STARTS, CHOOSE M AND Z 260 PMS=P(IEP(1)+1,5) IF(IGM.GE.0) THEN PM2=0. DO 270 I=2,NEP PM=P(IEP(I),5) IF(IFL(I).GE.0.AND.IFL(I).LE.8) PM=PMTH(2,IFL(I)) 270 PM2=PM2+PM PMS=MIN(PMS,(P(IM,5)-PM2)**2) ENDIF B0=27./6. DO 280 IF=4,MSTE(15) 280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6. IF(MSTE(14).LE.0) P(IEP(1)+1,5)=PMS*RLU(0)**(PAR(72)/PARE(3) &/FBR) IF(MSTE(14).EQ.1) P(IEP(1)+1,5)=4.*ALAMS*(0.25*PMS/ALAMS)** &(RLU(0)**(B0/FBR)) IF(MSTE(14).GE.2) P(IEP(1)+1,5)=PMS*RLU(0)**(ALFM*B0/FBR) P(IEP(1),5)=SQRT(P(IEP(1)+1,5)) IF(P(IEP(1),5).LE.PMTH(3,IFL(1))) THEN P(IEP(1),5)=PMTH(1,IFL(1)) P(IEP(1)+1,5)=P(IEP(1),5)**2 GOTO 290 ENDIF IF(IFL(1).NE.0) THEN Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0) IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260 ELSEIF(MSTE(15)*(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)+1,2)=500 ELSE Z=ZC+(1.-2.*ZC)*RLU(0) IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260 IFLB=1+INT(MSTE(15)*RLU(0)) PMQ=4.*PMTH(2,IFLB)**2/P(IEP(1)+1,5) IF(PMQ.GE.1.) GOTO 260 PMQ0=4.*PMTH(2,0)**2/P(IEP(1)+1,5) IF(MOD(MSTE(12),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)+1,2)=500+IFLB ENDIF IF(MSTE(14).GE.2.AND.Z*(1.-Z)*P(IEP(1)+1,5).LT.PT2MIN) GOTO 260 IF(MSTE(14).GE.2.AND.ALFM/ALOG(P(IEP(1)+1,5)*Z*(1.-Z)/ALAMS).LT. &RLU(0)) GOTO 260 C...CHECK IF Z CONSISTENT WITH CHOSEN M IF(IFL(1).EQ.0) THEN IFLGD1=IABS(K(IEP(1)+1,2))-500 IFLGD2=IFLGD1 ELSE IFLGD1=IFL(1) IFLGD2=0 ENDIF IF(NEP.EQ.1) THEN PED=PS(4) ELSEIF(NEP.GE.3) THEN PED=P(IEP(1),4) ELSEIF(IGM.EQ.0.OR.MSTE(12).LE.2) THEN PED=0.5*(P(IM+1,5)+P(IEP(1)+1,5)-PM2**2)/P(IM,5) ELSE IF(IEP(1).EQ.N+1) PED=P(IM+1,1)*PEM IF(IEP(1).EQ.N+3) PED=(1.-P(IM+1,1))*PEM ENDIF IF(MOD(MSTE(12),2).EQ.1) THEN PMQ1=PMTH(2,IFLGD1)**2/P(IEP(1)+1,5) PMQ2=PMTH(2,IFLGD2)**2/P(IEP(1)+1,5) DZ=SQRT(MAX(0.,(1.-P(IEP(1)+1,5)/PED**2)*((1.-PMQ1-PMQ2)**2- & 4.*PMQ1*PMQ2))) ZH=1.+PMQ1-PMQ2 ELSE DZ=SQRT(MAX(0.,1.-P(IEP(1)+1,5)/PED**2)) ZH=1. ENDIF ZL=0.5*(ZH-DZ) ZU=0.5*(ZH+DZ) IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260 IF(IFL(1).EQ.0) P(IEP(1)+1,3)=ALOG(ZU*(1.-ZL)/MAX(1E-20,ZL* &(1.-ZU))) IF(IFL(1).NE.0) P(IEP(1)+1,3)=ALOG((1.-ZL)/MAX(1E-10,1.-ZU)) C...THREE-JET MATRIX ELEMENT CORRECTION OR ANGULAR ORDERING IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN X1=1.-P(IEP(1)+1,5)/P(NS+2,5) X2=Z*(1.+P(IEP(1)+1,5)/P(NS+2,5)) X3=(1.-X1)+(1.-X2) WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+(1.-X2)/X3*(X2/(2.-X1))**2 IF(X1**2+X2**2.LT.RLU(0)*WSHOW) GOTO 260 ELSEIF(IGM.GT.0.AND.MSTE(11).GE.2) THEN ZM=P(IM+1,1) IF(IEP(1).EQ.N+3) ZM=1.-P(IM+1,1) IF(Z*(1.-Z)/P(IEP(1)+1,5).LT.(1.-ZM)/(ZM*P(IM+1,5))) GOTO 260 ENDIF C...END OF INNER VETO ALGORITHM, CHECK IF ONLY ONE LEG EVOLVED SO FAR 290 P(IEP(1)+1,1)=Z ISL(1)=0 ISL(2)=0 IF(NEP.EQ.1) GOTO 320 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200 DO 300 I=1,NEP IF(ITRY(I).EQ.0.AND.IFLD(I).GE.0.AND.IFLD(I).LE.8) THEN IF(P(N+2*I-1,5).GE.PMTH(2,IFLD(I))) GOTO 200 ENDIF 300 CONTINUE C...CHECK IF CHOSEN MULTIPLET M1,M2,Z1,Z2 IS PHYSICAL IF(NEP.EQ.4) THEN ELSEIF(NEP.EQ.3) THEN PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5)) PA2S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5)) PA3S=(P(N+5,4)+P(N+5,5))*(P(N+5,4)-P(N+5,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.MSTE(12).LE.2.OR.MOD(MSTE(12),2).EQ.0) THEN DO 310 I1=N+1,N+3,2 IFLDA=IABS(K(I1,2))-500 IF(IFLDA.LT.0.OR.IFLDA.GT.8) GOTO 310 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 310 IF(IFLDA.EQ.0) THEN IFLGD1=IABS(K(I1+1,2))-500 IFLGD2=IFLGD1 ELSE IFLGD1=IFLDA IFLGD2=0 ENDIF I2=2*N+4-I1 IF(IGM.EQ.0.OR.MSTE(12).LE.2) THEN PED=0.5*(P(IM+1,5)+P(I1+1,5)-P(I2+1,5))/P(IM,5) ELSE IF(I1.EQ.N+1) ZM=P(IM+1,1) IF(I1.EQ.N+3) ZM=1.-P(IM+1,1) PML=SQRT((P(IM+1,5)-P(N+2,5)-P(N+4,5))**2- & 4.*P(N+2,5)*P(N+4,5)) PED=PEM*(0.5*(P(IM+1,5)-PML+P(I1+1,5)-P(I2+1,5))+ & PML*ZM)/P(IM+1,5) ENDIF IF(MOD(MSTE(12),2).EQ.1) THEN PMQ1=PMTH(2,IFLGD1)**2/P(I1+1,5) PMQ2=PMTH(2,IFLGD2)**2/P(I1+1,5) DZ=SQRT((1.-P(I1+1,5)/PED**2)*((1.-PMQ1-PMQ2)**2- & 4.*PMQ1*PMQ2)) ZH=1.+PMQ1-PMQ2 ELSE DZ=SQRT(1.-P(I1+1,5)/PED**2) ZH=1. ENDIF ZL=0.5*(ZH-DZ) ZU=0.5*(ZH+DZ) IF(I1.EQ.N+1.AND.(P(I1+1,1).LT.ZL.OR.P(I1+1,1).GT.ZU)) ISL(1)=1 IF(I1.EQ.N+3.AND.(P(I1+1,1).LT.ZL.OR.P(I1+1,1).GT.ZU)) ISL(2)=1 IF(IFLDA.EQ.0) P(I1+1,4)=ALOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU))) IF(IFLDA.NE.0) P(I1+1,4)=ALOG((1.-ZL)/MAX(1E-10,1.-ZU)) 310 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 DZR1=MAX(0.,P(N+2,3)/P(N+2,4)-1.) DZR2=MAX(0.,P(N+4,3)/P(N+4,4)-1.) IF(DZR2.GT.RLU(0)*(DZR1+DZR2)) 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(MSTE(12),2).EQ.1.AND.(P(N+1,5).GE. &PMTH(2,IFLD(1)).OR.P(N+3,5).GE.PMTH(2,IFLD(2)))) THEN PMQ1=P(N+2,5)/P(IM+1,5) PMQ2=P(N+4,5)/P(IM+1,5) DZ=SQRT((1.-P(IM+1,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-4.*PMQ1*PMQ2)) ZH=1.+PMQ1-PMQ2 ZL=0.5*(ZH-DZ) ZU=0.5*(ZH+DZ) IF(P(IM+1,1).LT.ZL.OR.P(IM+1,1).GT.ZU) GOTO 200 ENDIF C...ACCEPTED BRANCH, CONSTRUCT FOUR MOMENTUM 320 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) P(N+2,2)=P(N+1,4) ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN PED1=0.5*(P(IM+1,5)+P(N+2,5)-P(N+4,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+3,1)=0. P(N+3,2)=0. P(N+3,3)=-P(N+1,3) P(N+3,4)=P(IM,5)-PED1 P(N+2,2)=P(N+1,4) P(N+4,2)=P(N+3,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+3,1)=SQRT(PTS) P(N+3,2)=0. P(N+3,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3) P(N+5,1)=-P(N+3,1) P(N+5,2)=0. P(N+5,3)=-(P(N+3,3)+P(N+1,3)) P(N+2,2)=P(N+1,4) P(N+4,2)=P(N+3,4) P(N+6,2)=P(N+5,4) ELSEIF(NEP.EQ.4) THEN ELSE ZM=P(IM+1,1) PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5)))) PMLS=(P(IM+1,5)-P(N+2,5)-P(N+4,5))**2-4.*P(N+2,5)*P(N+4,5) IF(MOD(MSTE(12),2).EQ.1) THEN IF(PZM.GT.0.) THEN PTS=(PEM**2*(ZM*(1.-ZM)*P(IM+1,5)-(1.-ZM)*P(N+2,5)- & ZM*P(N+4,5))-0.25*PMLS)/PZM**2 ELSE PTS=0. ENDIF P(N+1,4)=PEM*P(IM+1,1) ELSE IF(PZM.GT.0.) THEN PTS=PMLS*(ZM*(1.-ZM)*PEM**2/P(IM+1,5)-0.25)/PZM**2 ELSE PTS=0. ENDIF P(N+1,4)=PEM*(0.5*(P(IM+1,5)-SQRT(PMLS)+P(N+2,5)-P(N+4,5))+ & SQRT(PMLS)*ZM)/P(IM+1,5) ENDIF PT=SQRT(MAX(0.,PTS)) PHI=PAR(72)*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*(P(N+4,5)-P(N+2,5)-P(IM+1,5)+2.*PEM*P(N+1,4))/ & PZM ELSE P(N+1,3)=0. ENDIF P(N+3,1)=-P(N+1,1) P(N+3,2)=-P(N+1,2) P(N+3,3)=PZM-P(N+1,3) P(N+3,4)=PEM-P(N+1,4) IF(MSTE(12).LE.2) THEN P(N+2,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5) P(N+4,2)=(PEM*P(N+3,4)-PZM*P(N+3,3))/P(IM,5) ENDIF ENDIF C...ROTATE AND BOOST LINE N+1 AND N+3 IF(IGM.GT.0) THEN IF(MSTE(12).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. 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) MST(1)=N+1 MST(2)=MST(1) CALL LUROBO(THE,PHI,BEX,BEY,BEZ) MST(1)=N+3 MST(2)=MST(1) CALL LUROBO(THE,PHI,BEX,BEY,BEZ) MST(1)=0 MST(2)=0 ENDIF C...CONTINUE LOOP OVER PARTONS THAT MAY BRANCH UNTIL NONE LEFT IF(IGM.GE.0) K(IM,1)=K(IM,1)+20000 N=N+2*NEP NEP=2 GOTO 140 330 CONTINUE C...RECONSTRUCT STRING DRAWING INFORMATION DO 340 I=NS+1,N-1,2 DO 340 J=1,5 340 P(I+1,J)=0. IF(NPA.GE.2) THEN K(NS+2,1)=70000+NS+1 K(NS+2,2)=0 IIM=2 ELSE IIM=0 ENDIF DO 360 I=NS+1+IIM,N-1,2 IF(K(I,1).LT.20000) GOTO 350 ID1=K(I+1,1) IF(K(I,2).GE.501) ID1=K(I+1,1)+2 ID2=2*K(I+1,1)+2-ID1 P(I+1,3)=ID1 P(I+1,4)=ID2 P(ID1+1,1)=I P(ID1+1,2)=ID2 P(ID2+1,1)=ID1 P(ID2+1,2)=I 350 K(I+1,1)=70000+I K(I+1,2)=K(MOD(K(I,1),20000)+1,2) IF(I.EQ.NS+1+IIM) K(I+1,2)=K(IPA(1)+1,2) IF(I.EQ.NS+5.AND.NPA.GE.2) K(I+1,2)=K(IPA(2)+1,2) IF(I.EQ.NS+7.AND.NPA.GE.3) K(I+1,2)=K(IPA(3)+1,2) 360 IF(I.EQ.NS+9.AND.NPA.EQ.4) K(I+1,2)=K(IPA(4)+1,2) 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) MST(1)=NS+1 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 LUROBO(0.,CHI,0.,0.,0.) ENDIF CALL LUROBO(THE,PHI,BEX,BEY,BEZ) MST(1)=0 C...DELETE TRIVIAL SHOWER, ELSE CONNECT INITIATORS IF(N.EQ.NS+2+2*IIM) THEN N=NS ELSE DO 370 IP=1,NPA K(IPA(IP),1)=K(IPA(IP),1)+20000 P(IPA(IP)+1,3)=NS+IIM+2*IP-1 P(IPA(IP)+1,4)=NS+IIM+2*IP-1 P(NS+2*IP+IIM,1)=IPA(IP) 370 P(NS+2*IP+IIM,2)=IPA(IP) ENDIF RETURN END C********************************************************************* SUBROUTINE LUSPHE(SPH,APL) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) DIMENSION SM(3,3),SV(3,3) NP=0 C...CALCULATE MATRIX TO BE DIAGONALIZED DO 100 L1=1,3 DO 100 L2=L1,3 100 SM(L1,L2)=0. PS=0. DO 120 I=1,N IF(K(I,1).GE.20000) GOTO 120 NP=NP+1 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) PWT=1. IF(ABS(PARE(30)-2.).GT.0.001) PWT=PA**(PARE(30)-2.) DO 110 L1=1,3 DO 110 L2=L1,3 110 SM(L1,L2)=SM(L1,L2)+PWT*P(I,L1)*P(I,L2) PS=PS+PWT*PA**2 120 CONTINUE IF(NP.LE.1) THEN C...VERY LOW MULTIPLICITIES (0 OR 1) NOT CONSIDERED SPH=-1. APL=-1. RETURN ENDIF DO 130 L1=1,3 DO 130 L2=L1,3 130 SM(L1,L2)=SM(L1,L2)/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-7) THEN SPH=-1. APL=-1. RETURN ENDIF C...FIND FIRST AND LAST EIGENVECTOR BY SOLVING EQUATION SYSTEM DO 170 LD=1,3,2 DO 140 L1=1,3 SV(L1,L1)=SM(L1,L1)-P(N+LD,4) DO 140 L2=L1+1,3 SV(L1,L2)=SM(L1,L2) 140 SV(L2,L1)=SM(L1,L2) SMAX=0. DO 150 L1=1,3 DO 150 L2=1,3 IF(ABS(SV(L1,L2)).LE.SMAX) GOTO 150 LI=L1 LJ=L2 SMAX=ABS(SV(L1,L2)) 150 CONTINUE SMAX=0. DO 160 L3=LI+1,LI+2 L1=L3-3*((L3-1)/3) RL=SV(L1,LJ)/SV(LI,LJ) DO 160 L2=1,3 SV(L1,L2)=SV(L1,L2)-RL*SV(LI,L2) IF(ABS(SV(L1,L2)).LE.SMAX) GOTO 160 LK=L1 SMAX=ABS(SV(L1,L2)) 160 CONTINUE LJ1=LJ+1-3*(LJ/3) LJ2=LJ+2-3*((LJ+1)/3) P(N+LD,LJ1)=-SV(LK,LJ2) P(N+LD,LJ2)=SV(LK,LJ1) P(N+LD,LJ)=-(SV(LI,LJ1)*P(N+LD,LJ1)+SV(LI,LJ2)*P(N+LD,LJ2))/ &SV(LI,LJ) PA=SQRT(P(N+LD,1)**2+P(N+LD,2)**2+P(N+LD,3)**2) SGN=(-1.)**INT(RLU(0)+0.5) DO 170 J=1,3 170 P(N+LD,J)=SGN*P(N+LD,J)/PA C...MIDDLE EIGENVECTOR ORTHOGONAL TO OTHER TWO, RESET UNUSED COMPONENTS 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 LD=1,3 K(N+LD,1)=LD K(N+LD,2)=0 180 P(N+LD,5)=0. SPH=1.5*(P(N+2,4)+P(N+3,4)) APL=1.5*P(N+3,4) MST(3)=3 RETURN END C********************************************************************* SUBROUTINE LUTHRU(THR,OBL) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) DIMENSION TDI(3),TPR(3) NP=0 PS=0. DO 280 LD=1,2 IF(LD.EQ.2) THEN C...THRUST AXIS ALONG Z DIRECTION FOR MAJOR AXIS SEARCH MST(2)=N+1 PHI=ULANGL(P(N+1,1),P(N+1,2)) CALL LUROBO(0.,-PHI,0.,0.,0.) THE=ULANGL(P(N+1,3),P(N+1,1)) CALL LUROBO(-THE,0.,0.,0.,0.) ENDIF C...FIND AND ORDER PARTICLES WITH HIGHEST P (PT FOR MAJOR) C...(P(I,5) IS TEMPORARILY USED FOR EXTRA PARTICLE WEIGHT, 1 FOR THRUST) IF(MST(23).GE.1.AND.N+MSTE(21)/10+15.GE.MST(30)-5-MST(31)) THEN THR=-2. OBL=-2. RETURN ENDIF DO 100 LF=N+4,N+MSTE(21)/10+4 100 P(LF,4)=0. DO 140 I=1,N IF(K(I,1).GE.20000) GOTO 140 IF(LD.EQ.1) THEN NP=NP+1 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) P(I,5)=1. IF(ABS(PARE(31)-1.).GT.0.001) P(I,5)=PA**(PARE(31)-1.) PS=PS+P(I,5)*PA ELSE PA=SQRT(P(I,1)**2+P(I,2)**2) ENDIF DO 110 LF=N+MSTE(21)/10+3,N+4,-1 IF(PA.LE.P(LF,4)) GOTO 120 DO 110 J=1,5 110 P(LF+1,J)=P(LF,J) LF=N+3 120 DO 130 J=1,3 130 P(LF+1,J)=P(I,J) P(LF+1,4)=PA P(LF+1,5)=P(I,5) 140 CONTINUE IF(NP.LE.1) THEN C...VERY LOW MULTIPLICITIES (0 OR 1) NOT CONSIDERED THR=-1. OBL=-1. RETURN ENDIF C...FIND AND ORDER INITIAL AXES WITH HIGHEST THRUST DO 150 LG=N+MSTE(21)/10+5,N+MSTE(21)/10+15 150 P(LG,4)=0. NC=2**(MIN(MSTE(21)/10,NP)-1) DO 210 LC=1,NC DO 160 J=1,3 160 TDI(J)=0. DO 170 LF=1,MIN(MSTE(21)/10,NP) SGN=P(N+LF+3,5) IF(2**LF*((LC+2**(LF-1)-1)/2**LF).GE.LC) SGN=-SGN DO 170 J=1,4-LD 170 TDI(J)=TDI(J)+SGN*P(N+LF+3,J) TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2 DO 180 LG=N+MSTE(21)/10+MIN(LC,10)+4,N+MSTE(21)/10+5,-1 IF(TDS.LE.P(LG,4)) GOTO 190 DO 180 J=1,4 180 P(LG+1,J)=P(LG,J) LG=N+MSTE(21)/10+4 190 DO 200 J=1,3 200 P(LG+1,J)=TDI(J) P(LG+1,4)=TDS 210 CONTINUE C...ITERATE DIRECTION OF AXIS UNTIL STABLE MAXIMUM P(N+LD,4)=0. LG=0 220 LG=LG+1 THP=0. 230 THPS=THP DO 240 J=1,3 IF(THP.LE.1E-10) TDI(J)=P(N+MSTE(21)/10+4+LG,J) IF(THP.GT.1E-10) TDI(J)=TPR(J) 240 TPR(J)=0. DO 260 I=1,N IF(K(I,1).GE.20000) GOTO 260 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3)) DO 250 J=1,4-LD 250 TPR(J)=TPR(J)+SGN*P(I,J) 260 CONTINUE THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS IF(THP.GE.THPS+PARE(34)) GOTO 230 C...SAVE GOOD AXIS, TRY NEW INITIAL AXIS UNTIL A NUMBER OF TRIES AGREE IF(THP.LT.P(N+LD,4)-PARE(34).AND.LG.LT.MIN(10,NC)) GOTO 220 IF(THP.GT.P(N+LD,4)+PARE(34)) THEN LAGR=0 SGN=(-1.)**INT(RLU(0)+0.5) DO 270 J=1,3 270 P(N+LD,J)=SGN*TPR(J)/(PS*THP) P(N+LD,4)=THP ENDIF LAGR=LAGR+1 280 IF(LAGR.LT.MOD(MSTE(21),10).AND.LG.LT.MIN(10,NC)) GOTO 220 C...FIND MINOR AXIS AND VALUE BY ORTHOGONALITY SGN=(-1.)**INT(RLU(0)+0.5) P(N+3,1)=-SGN*P(N+2,2) P(N+3,2)=SGN*P(N+2,1) P(N+3,3)=0. THP=0. DO 290 I=1,N IF(K(I,1).GE.20000) GOTO 290 THP=THP+P(I,5)*ABS(P(N+3,1)*P(I,1)+P(N+3,2)*P(I,2)) P(I,5)=SQRT(MAX(P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2,0.)) 290 CONTINUE P(N+3,4)=THP/PS C...RESET UNUSED COMPONENTS, ROTATE BACK TO ORIGINAL COORDINATE SYSTEM DO 300 LD=1,3 K(N+LD,1)=LD K(N+LD,2)=0 300 P(N+LD,5)=0. MST(2)=N+3 CALL LUROBO(THE,PHI,0.,0.,0.) MST(2)=0 THR=P(N+1,4) OBL=P(N+2,4)-P(N+3,4) MST(3)=3 RETURN END C********************************************************************* SUBROUTINE LUCLUS(NJET,TGEN,DMIN) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...MOMENTA AND SUM OF MOMENTA FOR PARTICLES C...(P(I,4) IS TEMPORARILY USED TO REPRESENT ABSOLUTE MOMENTA) NP=0 PS=0. DO 100 I=1,N IF(K(I,1).GE.20000) GOTO 100 NP=NP+1 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) PS=PS+P(I,4) 100 CONTINUE IF(NP.LE.2*IABS(MSTE(22))) THEN C...VERY LOW MULTIPLICITIES NOT CONSIDERED NJET=-1 TGEN=-1. DMIN=-1. RETURN ENDIF NL=0 IF(MSTE(22).GE.0) THEN C...FIND INITIAL JET CONFIGURATION. IF TOO FEW JETS, MAKE HARDER CUTS DINIT=1.25*PARE(32) 110 DINIT=0.8*DINIT C...SUM UP SMALL MOMENTUM REGION, JET IF ENOUGH ABSOLUTE MOMENTUM NJET=0 NA=0 DO 120 J=1,3 120 P(N+1,J)=0. DO 140 I=1,N IF(K(I,1).GE.20000) GOTO 140 K(I,1)=0 IF(P(I,4).GT.2.*DINIT) GOTO 140 NA=NA+1 K(I,1)=1 DO 130 J=1,3 130 P(N+1,J)=P(N+1,J)+P(I,J) 140 CONTINUE P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) IF(P(N+1,4).GT.2.*DINIT) NJET=1 IF(DINIT.GE.0.2*PARE(32).AND.NJET+NP-NA.LT.2*IABS(MSTE(22))) & GOTO 110 C...FIND FASTEST PARTICLE, SUM UP JET AROUND IT. ITERATE UNTIL ALL C...PARTICLES USED UP 150 NJET=NJET+1 IF(MST(23).GE.1.AND.N+2*NJET.GE.MST(30)-5-MST(31)) THEN NJET=-2 TGEN=-2. DMIN=-2. RETURN ENDIF PMAX=0. DO 160 I=1,N IF(K(I,1).NE.0.OR.P(I,4).LE.PMAX) GOTO 160 IM=I PMAX=P(I,4) 160 CONTINUE DO 170 J=1,3 170 P(N+NJET,J)=0. DO 190 I=1,N IF(K(I,1).NE.0) GOTO 190 D2=(P(I,4)*P(IM,4)-P(I,1)*P(IM,1)-P(I,2)*P(IM,2)- & P(I,3)*P(IM,3))*2.*P(I,4)*P(IM,4)/(P(I,4)+P(IM,4))**2 IF(D2.GT.DINIT**2) GOTO 190 NA=NA+1 K(I,1)=NJET DO 180 J=1,3 180 P(N+NJET,J)=P(N+NJET,J)+P(I,J) 190 CONTINUE P(N+NJET,4)=SQRT(P(N+NJET,1)**2+P(N+NJET,2)**2+P(N+NJET,3)**2) IF(DINIT.GE.0.2*PARE(32).AND.NJET+NP-NA.LT.2*IABS(MSTE(22))) & GOTO 110 IF(NA.LT.NP) GOTO 150 ELSE C...USE GIVEN INITIAL JET CONFIGURATION DO 200 IT=N+1,N+NJET 200 P(IT,4)=SQRT(P(IT,1)**2+P(IT,2)**2+P(IT,3)**2) ENDIF C...ASSIGN ALL PARTICLES TO NEAREST JET, SUM UP NEW JET MOMENTA 210 TSAV=0. 220 DO 230 IT=N+NJET+1,N+2*NJET DO 230 J=1,3 230 P(IT,J)=0. DO 270 I=1,N IF(K(I,1).GE.20000) GOTO 270 IF(MSTE(23).EQ.1) THEN C...SYMMETRIC DISTANCE MEASURE BETWEEN PARTICLE AND JET D2MIN=1E10 DO 240 IT=N+1,N+NJET IF(P(IT,4).LT.DINIT) GOTO 240 D2=(P(I,4)*P(IT,4)-P(I,1)*P(IT,1)-P(I,2)*P(IT,2)- & P(I,3)*P(IT,3))*2.*P(I,4)*P(IT,4)/(P(I,4)+P(IT,4))**2 IF(D2.GE.D2MIN) GOTO 240 IM=IT D2MIN=D2 240 CONTINUE ELSE C..."MULTICITY" DISTANCE MEASURE BETWEEN PARTICLE AND JET PMAX=-1E10 DO 250 IT=N+1,N+NJET IF(P(IT,4).LT.DINIT) GOTO 250 PROD=(P(I,1)*P(IT,1)+P(I,2)*P(IT,2)+P(I,3)*P(IT,3))/P(IT,4) IF(PROD.LE.PMAX) GOTO 250 IM=IT PMAX=PROD 250 CONTINUE ENDIF K(I,1)=IM-N DO 260 J=1,3 260 P(IM+NJET,J)=P(IM+NJET,J)+P(I,J) 270 CONTINUE C...ABSOLUTE VALUE AND SUM OF JET MOMENTA, FIND TWO CLOSEST JETS PSJT=0. DO 280 IT=N+NJET+1,N+2*NJET P(IT,4)=SQRT(P(IT,1)**2+P(IT,2)**2+P(IT,3)**2) 280 PSJT=PSJT+P(IT,4) D2MIN=1E10 DO 290 IT1=N+NJET+1,N+2*NJET-1 DO 290 IT2=IT1+1,N+2*NJET D2=(P(IT1,4)*P(IT2,4)-P(IT1,1)*P(IT2,1)-P(IT1,2)*P(IT2,2)- &P(IT1,3)*P(IT2,3))*2.*P(IT1,4)*P(IT2,4)/ &MAX(0.01,P(IT1,4)+P(IT2,4))**2 IF(D2.GE.D2MIN) GOTO 290 IM1=IT1 IM2=IT2 D2MIN=D2 290 CONTINUE C...IF ALLOWED, JOIN TWO CLOSEST JETS AND START OVER IF(NJET.GT.IABS(MSTE(22)).AND.D2MIN.LT.PARE(33)**2) THEN NR=1 DO 300 J=1,3 300 P(N+NR,J)=P(IM1,J)+P(IM2,J) P(N+NR,4)=SQRT(P(N+NR,1)**2+P(N+NR,2)**2+P(N+NR,3)**2) DO 320 IT=N+NJET+1,N+2*NJET IF(IT.EQ.IM1.OR.IT.EQ.IM2) GOTO 320 NR=NR+1 DO 310 J=1,5 310 P(N+NR,J)=P(IT,J) 320 CONTINUE NJET=NJET-1 GOTO 210 C...DIVIDE UP BROAD JET IF EMPTY CLUSTER IN LIST OF FINAL ONES ELSEIF(NJET.EQ.IABS(MSTE(22)).AND.NL.LE.2) THEN DO 330 IT=N+1,N+NJET 330 K(IT,2)=0 DO 340 I=1,N 340 IF(K(I,1).LT.20000) K(N+K(I,1),2)=K(N+K(I,1),2)+1 IM=0 DO 350 IT=N+1,N+NJET 350 IF(K(IT,2).EQ.0) IM=IT IF(IM.NE.0) THEN NL=NL+1 IR=0 D2MAX=0. DO 360 I=1,N IF(K(I,1).GE.20000) GOTO 360 IF(K(N+K(I,1),2).LE.1.OR.P(I,4).LT.DINIT) GOTO 360 IT=N+NJET+K(I,1) D2=(P(I,4)*P(IT,4)-P(I,1)*P(IT,1)-P(I,2)*P(IT,2)- & P(I,3)*P(IT,3))*2.*P(I,4)*P(IT,4)/(P(I,4)+P(IT,4))**2 IF(D2.LE.D2MAX) GOTO 360 IR=I D2MAX=D2 360 CONTINUE IF(IR.EQ.0) GOTO 390 IT=N+NJET+K(IR,1) DO 370 J=1,3 P(IM+NJET,J)=P(IR,J) 370 P(IT,J)=P(IT,J)-P(IR,J) P(IM+NJET,4)=P(IR,4) P(IT,4)=SQRT(P(IT,1)**2+P(IT,2)**2+P(IT,3)**2) DO 380 IT=N+1,N+NJET DO 380 J=1,5 380 P(IT,J)=P(IT+NJET,J) IF(NL.LE.2) GOTO 210 ENDIF ENDIF C...IF GENERALIZED THRUST HAS NOT YET CONVERGED, CONTINUE ITERATION 390 TGEN=PSJT/PS IF(TGEN.GT.TSAV+PARE(34).AND.NL.LE.2) THEN TSAV=TGEN DO 400 IT=N+1,N+NJET DO 400 J=1,5 400 P(IT,J)=P(IT+NJET,J) GOTO 220 ENDIF C...REORDER JETS AFTER MOMENTUM, SUM UP JET ENERGIES AND MULTIPLICITIES DO 420 IT=N+1,N+NJET PMAX=0. DO 410 IR=N+NJET+1,N+2*NJET IF(P(IR,4).LE.PMAX) GOTO 410 IM=IR PMAX=P(IR,4) 410 CONTINUE K(IM,1)=IT-N P(IM,4)=-1. K(IT,1)=IT-N K(IT,2)=0 P(IT,4)=0. DO 420 J=1,3 420 P(IT,J)=P(IM,J) DO 430 I=1,N IF(K(I,1).GE.20000) GOTO 430 K(I,1)=K(N+NJET+K(I,1),1) P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) K(N+K(I,1),2)=K(N+K(I,1),2)+1 P(N+K(I,1),4)=P(N+K(I,1),4)+P(I,4) 430 CONTINUE IM=0 DO 440 IT=N+1,N+NJET IF(K(IT,2).EQ.0) IM=IT 440 P(IT,5)=SQRT(MAX(P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-P(IT,3)**2,0.)) C...VALUES AT RETURN (NEGATIVE FOR FAILURE FIXED NUMBER OF CLUSTERS) DMIN=SQRT(D2MIN) IF(NJET.EQ.1) DMIN=0. MST(3)=NJET IF(IM.NE.0) THEN NJET=-1 TGEN=-1. DMIN=-1. ENDIF RETURN END C********************************************************************* SUBROUTINE LUORIE(MORI) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) DIMENSION NS(2),PTS(2),PLS(2) C...PLACE LARGEST AXIS ALONG Z AXIS AND SECOND LARGEST IN XY PLANE MST(2)=N+MST(3) CALL LUROBO(0.,-ULANGL(P(N+1,1),P(N+1,2)),0.,0.,0.) CALL LUROBO(-ULANGL(P(N+1,3),P(N+1,1)),0.,0.,0.,0.) CALL LUROBO(0.,-ULANGL(P(N+2,1),P(N+2,2)),0.,0.,0.) IF(MORI.EQ.1) MST(2)=0 IF(MORI.EQ.1) RETURN DO 100 IS=1,2 NS(IS)=0 PTS(IS)=0. 100 PLS(IS)=0. C...ROTATE SLIM JET ALONG +Z DIRECTION DO 110 I=1,N IF(K(I,1).GE.20000) GOTO 110 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) 110 CONTINUE IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2) &CALL LUROBO(PAR(71),0.,0.,0.,0.) C...ROTATE SECOND LARGEST JET INTO -Z,+X QUADRANT DO 120 I=1,N IF(K(I,1).GE.20000.OR.P(I,3).GE.0.) GOTO 120 IS=2.-SIGN(0.5,P(I,1)) PLS(IS)=PLS(IS)-P(I,3) 120 CONTINUE IF(PLS(2).GT.PLS(1)) CALL LUROBO(0.,PAR(71),0.,0.,0.) MST(2)=0 RETURN END C********************************************************************* SUBROUTINE LUCELL(NJET) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...LOOP OVER ALL PARTICLES: FIND CELL THAT WAS HIT NCE2=2*MSTE(24)*MSTE(25) PTLRAT=1./SINH(PARE(35))**2 NC=N DO 110 I=1,N IF(K(I,1).GE.20000) GOTO 110 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110 PT=SQRT(P(I,1)**2+P(I,2)**2) ETA=SIGN(ALOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3)) IETA=MAX(1,MIN(MSTE(24),1+INT(MSTE(24)*0.5*(ETA/PARE(35)+1.)))) PHI=ULANGL(P(I,1),P(I,2)) IPHI=MAX(1,MIN(MSTE(25),1+INT(MSTE(25)*0.5*(PHI/PAR(71)+1.)))) IETPH=MSTE(25)*IETA+IPHI C...ADD TO CELL ALREADY HIT, OR BOOK NEW CELL DO 100 IC=N+1,NC IF(IETPH.EQ.K(IC,1)) THEN K(IC,2)=K(IC,2)+1 P(IC,5)=P(IC,5)+PT GOTO 110 ENDIF 100 CONTINUE IF(MST(23).GE.1.AND.NC.GE.MST(30)-5-MST(31)) THEN NJET=-2 RETURN ENDIF NC=NC+1 K(NC,1)=IETPH K(NC,2)=1 P(NC,1)=(PARE(35)/MSTE(24))*(2*IETA-1-MSTE(24)) P(NC,2)=(PAR(71)/MSTE(25))*(2*IPHI-1-MSTE(25)) P(NC,5)=PT 110 CONTINUE C...SMEAR TRUE BIN CONTENT BY CALORIMETER RESOLUTION IF(MSTE(27).GE.1) THEN DO 130 IC=N+1,NC PEI=P(IC,5) IF(MSTE(27).EQ.2) PEI=P(IC,5)/COSH(P(IC,1)) 120 PEF=PEI+PARE(39)*SQRT(-2.*ALOG(MAX(1E-10,RLU(0)))*PEI)* & COS(PAR(72)*RLU(0)) IF(PEF.LT.0..OR.PEF.GT.PARE(40)*PEI) GOTO 120 P(IC,5)=PEF 130 IF(MSTE(27).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,1).EQ.0.OR.K(IC,1).GT.NCE2) 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.PARE(36)) GOTO 210 IF(MST(23).GE.1.AND.NJ.GE.MST(30)-5-MST(31)) THEN NJET=-2 RETURN ENDIF K(ICMAX,1)=K(ICMAX,1)+NCE2 NJ=NJ+1 K(NJ,1)=1 K(NJ,2)=0 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,1).EQ.0) GOTO 160 IF(ABS(P(IC,1)-ETA).GT.PARE(38)) GOTO 160 DPHIA=ABS(P(IC,2)-PHI) IF(DPHIA.GT.PARE(38).AND.DPHIA.LT.PAR(72)-PARE(38)) GOTO 160 PHIC=P(IC,2) IF(DPHIA.GT.PAR(71)) PHIC=PHIC+SIGN(PAR(72),PHI) IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARE(38)**2) GOTO 160 K(IC,1)=-K(IC,1) K(NJ,2)=K(NJ,2)+K(IC,2) 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.PARE(37)) THEN NJ=NJ-1 DO 170 IC=N+1,NC 170 IF(K(IC,1).LT.0) K(IC,1)=-K(IC,1) ELSEIF(MSTE(26).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.PAR(71)) P(NJ,4)=P(NJ,4)-SIGN(PAR(72), & 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,1).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,1)=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,1).EQ.0) GOTO 220 IF(P(IJ,5).LT.ETMAX) GOTO 220 IJMAX=IJ ETMAX=P(IJ,5) 220 CONTINUE K(IJMAX,1)=0 K(N+I,1)=I K(N+I,2)=K(IJMAX,2) DO 230 J=1,5 230 P(N+I,J)=P(IJMAX,J) NJET=NJ-NC MST(3)=NJET C...CONVERT TO MASSLESS OR MASSIVE FOUR-VECTORS IF(MSTE(26).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(MSTE(26).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 RETURN END C********************************************************************* SUBROUTINE LUFOWO(H10,H20,H30,H40) COMMON/LUJETS/N,K(2000,2),P(2000,5) C...MOMENTA FOR PARTICLES (P(I,5) TEMPORARILY USED) AND H0 NP=0 H0=0 HD=0. DO 100 I=1,N IF(K(I,1).GE.20000) GOTO 100 NP=NP+1 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) H0=H0+P(I,5) HD=HD+P(I,5)**2 100 CONTINUE H0=H0**2 IF(NP.LE.1) THEN C...VERY LOW MULTIPLICITIES (0 OR 1) NOT CONSIDERED 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=1,N-1 IF(K(I1,1).GE.20000) GOTO 120 DO 110 I2=I1+1,N IF(K(I2,1).GE.20000) GOTO 110 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)) H10=H10+P(I1,5)*P(I2,5)*CTHE H20=H20+P(I1,5)*P(I2,5)*(1.5*CTHE**2-0.5) H30=H30+P(I1,5)*P(I2,5)*(2.5*CTHE**3-1.5*CTHE) H40=H40+P(I1,5)*P(I2,5)*(4.375*CTHE**4-3.75*CTHE**2+0.375) 110 CONTINUE 120 CONTINUE C...CALCULATE H10 - H40, RESET P(I,5) TO MASS H10=(HD+2.*H10)/H0 H20=(HD+2.*H20)/H0 H30=(HD+2.*H30)/H0 H40=(HD+2.*H40)/H0 DO 130 I=1,N 130 IF(K(I,1).LT.20000) P(I,5)=SQRT(MAX(P(I,4)**2-P(I,1)**2- &P(I,2)**2-P(I,3)**2,0.)) RETURN END C********************************************************************* FUNCTION ULALPS(Q2) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATE/MSTE(40),PARE(80) C...THE NUMBER OF ACTIVE FLAVOURS NF=3 DO 100 IFL=4,MSTE(4) 100 IF(Q2.GT.4.*ULMASS(2,IFL)**2) NF=NF+1 C...THE STRONG COUPLING CONSTANT IN FIRST AND SECOND ORDER IF(MSTE(8).EQ.0) THEN ULALPS=PARE(3) ELSEIF(IABS(MSTE(1)).LE.1.OR.MSTE(8).EQ.1) THEN ULALPS=12.*PAR(71)/((33.-2.*NF)*ALOG(Q2/PARE(1)**2)) ELSE ALGQ=ALOG(Q2/PARE(2)**2) ULALPS=12.*PAR(71)/((33-2.*NF)*ALGQ+(6.*(153.-19.*NF)/ & (33.-2.*NF))*ALOG(ALGQ)) ENDIF PARE(49)=ULALPS PARE(65)=1.986-0.115*NF RETURN END C********************************************************************* BLOCK DATA LUEDAT COMMON/LUDATE/MSTE(40),PARE(80) DATA MSTE/ 1 3, 2, 7, 5, 1, 1, 0, 2, 1, 0, 2 2, 4, 2, 2, 5, 0, 0, 0, 0, 0, 3 42, 1, 1, 25, 24, 1, 0, 0, 0, 1, 4 1, 1, 0, 0, 0, 0, 0, 0, 0, 0/ DATA PARE/ 1 1.5, 0.5, 0.20,0.0072974,0.229,94.,2.8, 0.02, 2.0, 1.0, 2 0., 0., 0., 0., 0.01, 0.99, 0.2, 0., 0., 0., 3 0.40, 1.0, 0., 0., 0., 0., 0., 0., 0., 2.0, 4 1.0, 0.25, 2.5,0.0001, 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 5 40*0./ END C********************************************************************* C*** JETSET VERSION 6.3, LOW-PT PHYSICS PART *********************** SUBROUTINE LULOPT(KF1,KF2,PE1,PE2) COMMON/LUJETS/N,K(2000,2),P(2000,5) COMMON/LUDAT1/MST(40),PAR(80) COMMON/LUDATH/CHR(20),KHR(60) DIMENSION KRE(2,3) C...FILL INITIAL HADRONS, FIND FLAVOUR CONFIGURATION OF TWO HADRON JETS DO 110 IP=1,2 KF=(2-IP)*KF1+(IP-1)*KF2 PE=(2-IP)*PE1+(IP-1)*PE2 CALL LUPART(IP,KF,PE,(IP-1)*PAR(71),0.) K(IP,1)=40000 KFA=IABS(KF) IF(KFA.GE.17.AND.KFA.LE.19) IHR=2*KFA-34 IF(KFA.EQ.41.OR.KFA.EQ.42) IHR=5*KFA-199 RHR=RLU(0) 100 IHR=IHR+1 IF(RHR.GT.CHR(IHR)) GOTO 100 DO 110 J=1,3 110 KRE(IP,J)=KHR(3*(IHR-1)+J)*ISIGN(1,KF) C...CALCULATE CM ENERGY, FILL JETS IN CM FRAME PM1=ULMASS(1,KF1) PER1=MAX(PM1,PE1) PZ1=SQRT(PER1**2-PM1**2) PM2=ULMASS(1,KF2) PER2=MAX(PM2,PE2) PZ2=-SQRT(PER2**2-PM2**2) ECM=SQRT((PER1+PER2)**2-(PZ1+PZ2)**2) PEC1=0.5*(ECM+(ULMASS(2,KRE(1,1))**2-ULMASS(2,KRE(2,1))**2)/ECM) CALL LU1JET(3,KRE(1,1),KRE(1,2),KRE(1,3),PEC1,0.,0.) K(3,1)=10001 CALL LU1JET(5,KRE(2,1),KRE(2,2),KRE(2,3),ECM-PEC1,PAR(71),0.) K(5,1)=2 C...JET FRAGMENTATION, BOOST TO LAB FRAME CALL LUEXEC MST(1)=3 CALL LUROBO(0.,0.,0.,0.,(PZ1+PZ2)/(PER1+PER2)) MST(1)=0 RETURN END C********************************************************************* BLOCK DATA LUHDAT COMMON/LUDATH/CHR(20),KHR(60) C...FLAVOUR ARRANGEMENT DATA FOR HADRONS DATA CHR/0.5,1.,0.5,1.,0.5,1.,0.3333,0.7708,0.8333,0.9792,1., &0.3333,0.7708,0.8333,0.9792,1.,4*0./ DATA KHR/1,0,-2,-2,0,1,1,0,-3,-3,0,1,2,0,-3,-3,0,2,11,0,2,12,2, &1,12,1,1,21,2,1,21,1,1,22,0,1,12,1,2,12,2,2,21,1,2,21,2,2,12*0/ END C*** END OF JETSET VERSION 6.3 ************************************* C********************************************************************* FUNCTION RLU(IDUM) C...THIS FUNCTION IS AN INTERFACE TO A SUITABLE RANDOM NUMBER C...GENERATOR. SOME POSSIBILITIES ARE SUGGESTED BELOW, BUT IN C...THE END IT IS UP TO THE USER TO FIND ONE THAT WORKS. C...FOR ND (LUND) AND UNIVAC C RLU=RANF(0) C...FOR VAX (OTHER SEED MAY BE CHOSEN IF DESIRED) C DATA ISEED/65539/ C RLU=RAN(ISEED) C...FOR IBM (DESY) C RLU=RN(FLOAT(IDUM)) C...FOR IBM (SLAC) C RLU=RAN7(FLOAT(IDUM)) C...FOR CDC C RLU=RANF() C...USING CERN LIBRARY RLU=RNDM(IDUM) RETURN END