From d05723f449c1eecee4f00af392014df4c898ebe9 Mon Sep 17 00:00:00 2001 From: Oleg Kalashev Date: Sun, 15 Sep 2024 21:01:03 +0300 Subject: [PATCH] external dependencies added --- .gitmodules | 3 + src/external/README.md | 13 - src/external/SOPHIA/README.TXT | 140 + src/external/SOPHIA/eventgen.f | 3312 ++++++++ src/external/SOPHIA/inpoutput.f | 656 ++ src/external/SOPHIA/jetset74dp.f | 11670 +++++++++++++++++++++++++++++ src/external/SOPHIA/rndm.f | 73 + src/external/SOPHIA/sampling.f | 592 ++ src/external/nr | 1 + 9 files changed, 16447 insertions(+), 13 deletions(-) create mode 100644 .gitmodules delete mode 100644 src/external/README.md create mode 100644 src/external/SOPHIA/README.TXT create mode 100644 src/external/SOPHIA/eventgen.f create mode 100644 src/external/SOPHIA/inpoutput.f create mode 100644 src/external/SOPHIA/jetset74dp.f create mode 100644 src/external/SOPHIA/rndm.f create mode 100644 src/external/SOPHIA/sampling.f create mode 160000 src/external/nr diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..6219ba7 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "src/external/nr"] + path = src/external/nr + url = https://github.com/okolo/nr.git diff --git a/src/external/README.md b/src/external/README.md deleted file mode 100644 index 5ef19dc..0000000 --- a/src/external/README.md +++ /dev/null @@ -1,13 +0,0 @@ -# Installing external libraries - -- download SOPHIA event generator sources from https://elsevier.digitalcommonsdata.com/datasets/pkx5j87mgn/1 and extract in **SOPHIA** folder -- download Numerical Recipes 3rd ed. C++ source code to **nr** folder - -

-mkdir SOPHIA
-cd SOPHIA
-cp ~/Downloads/adlb_v1_0.tar.gz ./
-tar xfoz adlb_v1_0.tar.gz
-cd ..
-git clone https://github.com/blackstonep/Numerical-Recipes.git nr
-
diff --git a/src/external/SOPHIA/README.TXT b/src/external/SOPHIA/README.TXT new file mode 100644 index 0000000..d1a7bdd --- /dev/null +++ b/src/external/SOPHIA/README.TXT @@ -0,0 +1,140 @@ + + + SOPHIA 2.0 + ========== + + + +A.M"ucke, Ralph Engel, J.P.Rachen, R.J.Protheroe, and Todor Stanev + +(astro-ph/9903478, to appear in Comp.Phys.Commun.) + + +Files: +----- + +eventgen.f (hadronic event generator) + +sampling.f (sampling of photon energies) + +inpoutput.f (histogramming, input/output) + +jetset74dp.f (Lund fragmentation program, changed to double prec.) + +rndm.f (random number generator) + +README.TXT (this file) + + + + + +Particle record: +--------------- + + +After event generation the final state particles are found in + + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + +NP is the number of particles produced in the last event. +The particle momenta of particle I in x, y, z directions are +P(I,1), P(I,2), P(I,3) and P(I,4) is the energy (in GeV). +The particle mass is stored in P(I,5). + +The particle identity is given by LLIST with the following numbering +scheme: + + ----------------------- + code particle mass + ----------------------- + 1 gam 0.0000 + 2 e+ 0.0005 + 3 e- 0.0005 + 4 mu+ 0.1057 + 5 mu- 0.1057 + 6 pi0 0.1350 + 7 pi+ 0.1396 + 8 pi- 0.1396 + 9 k+ 0.4937 + 10 k- 0.4937 + 11 k0l 0.4977 + 12 k0s 0.4977 + 13 p 0.9383 + 14 n 0.9396 + 15 nue 0.0000 + 16 nueb 0.0000 + 17 num 0.0000 + 18 numb 0.0000 + 21 k0 0.4977 + 22 k0b 0.4977 + 23 eta 0.5488 + 24 etap 0.9576 + 25 rho+ 0.7714 + 26 rho- 0.7714 + 27 rho0 0.7717 + 28 k*+ 0.8921 + 29 k*- 0.8921 + 30 k*0 0.8965 + 31 k*0b 0.8965 + 32 omeg 0.7826 + 33 phi 1.1020 + 34 SIG+ 1.1894 + 35 SIG0 1.1925 + 36 SIG- 1.1973 + 37 XI0 1.3149 + 38 XI- 1.3213 + 39 LAM 1.1156 + 40 DELT++ 1.2300 + 41 DELT+ 1.2310 + 42 DELT0 1.2320 + 43 DELT- 1.2330 + 44 SIG*+ 1.3828 + 45 SIG*0 1.3837 + 46 SIG*- 1.3872 + 47 XI*0 1.5318 + 48 XI*- 1.5350 + 49 OME*- 1.6724 + +Antibaryons have negative ID numbers correspondingly. +Decayed particles are marked by adding 10000 to their ID code. + +The decay of a particle with code ID can be turned off via + + IDB(ID) = -ABS(IDB(ID)) + +and turned on via + + IDB(ID) = ABS(IDB(ID)) + +This has to be done only once at the beginning of event generation or +might be changed on an event-by-event basis. + + + +The particles produced in the last EVENTGEN call can be listed +conveniently by + CALL print_event(1) + + + + +Related publications: +-------------------- + +- M"ucke A., et al. 1999, astro-ph/9903478, to appear in Comp.Phys.Commun. + +- M"ucke A., et al. 1999, astro-ph/9808279, to appear in PASA. + +- M"ucke A., et al. 1999, to appear in: Proc. of the + 19th Texas Symposium on Relativistic Astrophysics, Paris, + France, Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg + (CEA Saclay) + +- M"ucke A., et al. 1999, astro-ph/9905153, to appear in: Proc. of + 19th Texas Symposium on Relativistic Astrophysics, Paris, France, + Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg + (CEA Saclay) + +- M"ucke A., et al 1999, to appear in: Proc. of 26th Int.Cosmic + Ray Conf. (Salt Lake City, Utah) diff --git a/src/external/SOPHIA/eventgen.f b/src/external/SOPHIA/eventgen.f new file mode 100644 index 0000000..dc61a05 --- /dev/null +++ b/src/external/SOPHIA/eventgen.f @@ -0,0 +1,3312 @@ +c***************************************************************************** +c**!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*** +c**!! IF YOU USE THIS PROGRAM, PLEASE CITE: !!*** +c**!! A.M"ucke, Ralph Engel, J.P.Rachen, R.J.Protheroe and Todor Stanev, !!*** +c**!! 1999, astro-ph/9903478, to appear in Comp.Phys.Commun. !!*** +c**!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*** +c***************************************************************************** +c** Further SOPHIA related papers: *** +c** (1) M"ucke A., et al 1999, astro-ph/9808279, to appear in PASA. *** +c** (2) M"ucke A., et al 1999, to appear in: Proc. of the *** +c** 19th Texas Symposium on Relativistic Astrophysics, Paris, France, *** +c** Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg (CEA Saclay) *** +c** (3) M"ucke A., et al 1999, astro-ph/9905153, to appear in: Proc. of *** +c** 19th Texas Symposium on Relativistic Astrophysics, Paris, France, *** +c** Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg (CEA Saclay) *** +c** (4) M"ucke A., et al 1999, to appear in: Proc. of 26th Int.Cosmic Ray *** +c** Conf. (Salt Lake City, Utah) *** +c***************************************************************************** + + + subroutine eventgen(L0,E0,eps,theta,Imode) + +c******************************************************* +c** subroutine for photopion production of ** +c** relativistic nucleons in a soft photon field ** +c** subroutine for SOPHIA Version 1.2 ** +c****** INPUT ****************************************** +c E0 = energy of incident proton (in lab frame) [in GeV] +c eps = energy of incident photon [in GeV] (in lab frame) +c theta = angle between incident proton and photon [in degrees] +c L0 = code number of the incident nucleon +c****** OUTPUT ************************************************* +c P(2000,5) = 5-momentum of produced particles +c LLIST(2000) = code numbers of produced particles +c NP = number of produced particles +c*************************************************************** +c** Date: 20/01/98 ** +c** correct.:19/02/98 ** +c** change: 23/05/98 ** +c** last change:06/09/98 ** +c** authors: A.Muecke ** +c** R.Engel ** +c************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + + COMMON /S_RUN/ SQS, S, Q2MIN, XMIN, ZMIN, kb, kt, a1, a2, Nproc + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + COMMON /S_MASS1/ AM(49), AM2(49) + COMMON /S_CHP/ S_LIFE(49), ICHP(49), ISTR(49), IBAR(49) + COMMON /S_CSYDEC/ CBR(102), IDB(49), KDEC(612), LBARP(49) + + CHARACTER NAMPRES*6 + COMMON /RES_PROP/ AMRES(9), SIG0(9),WIDTH(9), + + NAMPRES(0:9) + + CHARACTER NAMPRESp*6 + COMMON /RES_PROPp/ AMRESp(9), BGAMMAp(9),WIDTHp(9), + + RATIOJp(9),NAMPRESp(0:9) + + CHARACTER NAMPRESn*6 + COMMON /RES_PROPn/ AMRESn(9), BGAMMAn(9),WIDTHn(9), + + RATIOJn(9),NAMPRESn(0:9) + + DOUBLE PRECISION P_nuc(4),P_gam(4),P_sum(4),PC(4),GamBet(4) + + DATA pi /3.141593D0/ + DATA IRESMAX /9/ + DATA Icount / 0 / + +c****** INPUT ************************************************** +c E0 = energy of incident proton (in lab frame) [in GeV] +c eps = energy of incident photon [in GeV] (in lab frame) +c theta = angle between incident proton and photon [in degrees] +c L0 = code number of the incident nucleon +c*************************************************************** +c** calculate eps_prime = photon energy in nuclear rest frame, +c** sqrt(s) = CMF energy of the N\gamma-system + +c... declare stable particles: + +C muons stable +c IDB(4) = -ABS(IDB(4)) +c IDB(5) = -ABS(IDB(5)) +C +C pi+,pi0,pi- stable +c IDB(6) = -ABS(IDB(6)) +c IDB(7) = -ABS(IDB(7)) +c IDB(8) = -ABS(IDB(8)) +C +C Deltas stable +C IDB(40) = -ABS(IDB(40)) +C IDB(41) = -ABS(IDB(41)) +C IDB(42) = -ABS(IDB(42)) +C IDB(43) = -ABS(IDB(43)) +C rho, omega, phi stable +C IDB(25) = -ABS(IDB(25)) +C IDB(26) = -ABS(IDB(26)) +C IDB(27) = -ABS(IDB(27)) +C IDB(32) = -ABS(IDB(32)) +C IDB(33) = -ABS(IDB(33)) +C print *,' WARNING: Deltas, eta, VMs are stable in this version' + +C rho0,omega stable +c IDB(27) = -ABS(IDB(27)) +c IDB(32) = -ABS(IDB(32)) + +C STRANGE PARTICLES: +C kaons stable +c IDB(9) = -ABS(IDB(9)) +c IDB(10) = -ABS(IDB(10)) + +C IDB(11) = -ABS(IDB(11)) +C IDB(12) = -ABS(IDB(12)) +C IDB(21) = -ABS(IDB(21)) +C IDB(22) = -ABS(IDB(22)) +C kaons* stable +c IDB(28) = -ABS(IDB(28)) +c IDB(29) = -ABS(IDB(29)) +c IDB(30) = -ABS(IDB(30)) +c IDB(31) = -ABS(IDB(31)) + +C eta stable +C IDB(23) = -ABS(IDB(23)) + + +C incoming nucleon + pm = AM(L0) + P_nuc(1) = 0.D0 + P_nuc(2) = 0.D0 + P_nuc(3) = SQRT(MAX((E0-pm)*(E0+pm),0.D0)) + P_nuc(4) = E0 +C incoming photon + P_gam(1) = EPS*SIN(theta*pi/180.D0) + P_gam(2) = 0.D0 + P_gam(3) = -EPS*COS(theta*pi/180.D0) + P_gam(4) = EPS + + Esum = P_nuc(4)+P_gam(4) + PXsum = P_nuc(1)+P_gam(1) + PYsum = P_nuc(2)+P_gam(2) + PZsum = P_nuc(3)+P_gam(3) + IQchr = ICHP(1)+ICHP(L0) + IQbar = IBAR(1)+IBAR(L0) + + gammap = E0/pm + xx = 1.D0/gammap + if(gammap.gt.1000.D0) then + betap = 1.D0 - 0.5D0*xx**2 - 0.125D0*xx**4 + else + betap = sqrt(1.D0-xx)*sqrt(1.D0+xx) + endif +c Etot = E0+eps + s = pm*pm + 2.D0*eps*E0*(1.D0-betap*cos(theta*pi/180.D0)) + + sqsm = sqrt(s) + eps_prime = (s-pm*pm)/2.D0/pm + +C calculate Lorentz boots and rotation + P_sum(1) = P_nuc(1)+P_gam(1) + P_sum(2) = P_nuc(2)+P_gam(2) + P_sum(3) = P_nuc(3)+P_gam(3) + P_sum(4) = P_nuc(4)+P_gam(4) +C Lorentz transformation into c.m. system + DO I=1,4 + GamBet(I) = P_sum(I)/sqsm + ENDDO +C calculate rotation angles + IF(GamBet(4).lt.1.d5) then +C transform nucleon vector + GamBet(1) = -GamBet(1) + GamBet(2) = -GamBet(2) + GamBet(3) = -GamBet(3) + CALL PO_ALTRA(GamBet(4),GamBet(1),GamBet(2),GamBet(3), + & P_nuc(1),P_nuc(2),P_nuc(3),P_nuc(4),Ptot, + & PC(1),PC(2),PC(3),PC(4)) + GamBet(1) = -GamBet(1) + GamBet(2) = -GamBet(2) + GamBet(3) = -GamBet(3) +C rotation angle: nucleon moves along +z + COD = PC(3)/Ptot + SID = SQRT(PC(1)**2+PC(2)**2)/Ptot + COF = 1.D0 + SIF = 0.D0 + IF(Ptot*SID.GT.1.D-5) THEN + COF=PC(1)/(SID*Ptot) + SIF=PC(2)/(SID*Ptot) + Anorf=SQRT(COF*COF+SIF*SIF) + COF=COF/Anorf + SIF=SIF/Anorf + ENDIF + else + COD = 1.D0 + SID = 0.D0 + COF = 1.D0 + SIF = 0.D0 + endif + +c... check for threshold: + sth = 1.1646D0 + if (s.lt.sth) then + print*,'input energy below threshold for photopion production !' + print*,'sqrt(s) = ',sqrt(s) + NP = 0 + RETURN + endif + + 200 continue + Icount = Icount+1 + Imode = 0 + +c******************************************************************* +c decide which process occurs: *** +c (1) decay of resonance *** +c (2) direct pion production (interaction of photon with *** +c virtual pions in nucleon cloud) and diffractive scattering *** +c (3) multipion production *** +c******************************************************************* + + call dec_inter3(eps_prime,Imode,L0) + +c********************************************* +c******* PARTICLE PRODUCTION ***************** +c********************************************* +c 42 continue + if (Imode.le.5) then +c... direct/multipion/diffractive scattering production channel: + call GAMMA_H(sqsm,L0,Imode,Ifbad) + if(Ifbad.ne.0) then + print *,' eventgen: simulation of particle production failed' + goto 200 + endif + else if (Imode.eq.6) then +c... Resonances: +c... decide which resonance decays with ID=IRES in list: +c... IRESMAX = number of considered resonances = 9 so far + IRES = 0 + 46 call dec_res2(eps_prime,IRES,IRESMAX,L0) + Nproc = 10+IRES + call dec_proc2(eps_prime,IPROC,IRANGE,IRES,L0) +c 2-particle decay of resonance in CM system: + NP = 2 + call res_decay3(IRES,IPROC,IRANGE,s,L0,nbad) + if (nbad.eq.1) then + print *,' eventgen: event rejected by res_decay3' + goto 46 + endif + call DECSIB + else + print*,'invalid Imode !!' + STOP + endif + +c... consider only stable particles: + 18 istable=0 + do 16 i=1,NP + if (abs(LLIST(i)).lt.10000) then + istable = istable+1 + LLIST(istable) = LLIST(i) + P(istable,1) = P(i,1) + P(istable,2) = P(i,2) + P(istable,3) = P(i,3) + P(istable,4) = P(i,4) + P(istable,5) = P(i,5) + endif + 16 continue + if (NP.gt.istable) then + do i=istable+1,NP + LLIST(i) = 0 + P(i,1) = 0. + P(i,2) = 0. + P(i,3) = 0. + P(i,4) = 0. + P(i,5) = 0. + enddo + endif + NP = istable + +c*********************************************** +c transformation from CM-system to lab-system: * +c*********************************************** + + DO I=1,NP + CALL PO_TRANS(P(I,1),P(I,2),P(I,3),COD,SID,COF,SIF, + & PC(1),PC(2),PC(3)) + PC(4) = P(I,4) + CALL PO_ALTRA(GamBet(4),GamBet(1),GamBet(2),GamBet(3), + & PC(1),PC(2),PC(3),PC(4),Ptot, + & P(I,1),P(I,2),P(I,3),P(I,4)) + ENDDO + +c call check_event(Icount,Esum,PXsum,PYsum,PZsum,IQchr,IQbar,Irej) +c if(Irej.ne.0) then +c print *,' eventgen: event rejected by check_event' +c goto 200 +c endif + + return + + END + + +c***************************** +c*** List of SUBROUTINES ***** +C***************************** + + DOUBLE PRECISION function crossection(x,NDIR,NL0) + + IMPLICIT DOUBLE PRECISION (A-M,O-Z) + IMPLICIT INTEGER (N) + + SAVE + + CHARACTER NAMPRES*6 + COMMON /RES_PROP/ AMRES(9), SIG0(9),WIDTH(9), + + NAMPRES(0:9) + COMMON /S_MASS1/ AM(49), AM2(49) + + DIMENSION sig_res(9) + + external breitwigner, Ef, singleback, twoback + + DATA sth /1.1646D0/ + +c***************************************************** +C calculates crossection of N-gamma-interaction +C (see thesis of J.Rachen, p.45ff and corrections +C report from 27/04/98, 5/05/98, 22/05/98 of J.Rachen) +C***************************************************** +c** Date: 20/01/98 ** +c** correct.:27/04/98** +c** update: 23/05/98 ** +c** author: A.Muecke ** +c********************** +c +c x = eps_prime in GeV + pm = AM(NL0) + s = pm*pm+2.D0*pm*x + + if (s.lt.sth) then + crossection = 0. + RETURN + endif + if (x.gt.10.D0) then +c only multipion production: + cross_res = 0.D0 + cross_dir = 0.D0 + cross_dir1 = 0.D0 + cross_dir2 = 0.D0 + goto 10 + endif + +c**************************** +c RESONANCES: +c**************************** + + cross_res = 0.D0 + + cross_res = breitwigner(SIG0(1),WIDTH(1),AMRES(1),x) + & *Ef(x,0.152D0,0.17D0) + sig_res(1) = cross_res + DO N=2,9 + + sig_res(N) = breitwigner(SIG0(N),WIDTH(N),AMRES(N),x) + & *Ef(x,0.15D0,0.38D0) + cross_res = cross_res + sig_res(N) + + ENDDO + +c**************************** +c DIRECT CHANNEL: +c**************************** + + if((x.gt.0.1D0).and.(x.lt.0.6D0)) then + cross_dir1 = singleback(x) + & + 40.D0*exp(-(x-0.29D0)**2/0.002D0) + & - 15.D0*exp(-(x-0.37D0)**2/0.002D0) + else + cross_dir1 = singleback(x) + endif + cross_dir2 = twoback(x) + + cross_dir = cross_dir1 + cross_dir2 + +c**************************** +c FRAGMENTATION 2: +c**************************** + 10 continue + if (NL0.eq.13) then + cross_frag2 = 80.3D0*Ef(x,0.5D0,0.1D0)*(s**(-0.34D0)) + else if (NL0.eq.14) then + cross_frag2 = 60.2D0*Ef(x,0.5D0,0.1D0)*(s**(-0.34D0)) + endif + +c**************************************************** +c MULTIPION PRODUCTION/FRAGMENTATION 1 CROSS SECTION +c**************************************************** + if (x.gt.0.85D0) then + ss1 = (x-.85D0)/.69D0 + if (NL0.eq.13) then + ss2 = 29.3D0*(s**(-.34D0))+59.3D0*(s**.095D0) + else if (NL0.eq.14) then + ss2 = 26.4D0*(s**(-.34D0))+59.3D0*(s**.095D0) + endif + cs_multidiff = (1.-exp(-ss1))*ss2 + cs_multi = 0.89D0*cs_multidiff + +c**************************** +c DIFFRACTIVE SCATTERING: +c**************************** + + cross_diffr1 = .099D0*cs_multidiff + cross_diffr2 = .011D0*cs_multidiff + cross_diffr = 0.11D0*cs_multidiff + +C*********************************************************************** + + ss1 = ((x-.85D0)**.75D0)/.64D0 + ss2 = 74.1D0*(x**(-.44D0))+62.D0*(s**.08D0) + cs_tmp = 0.96D0*(1.D0-exp(-ss1))*ss2 + cross_diffr1 = 0.14D0*cs_tmp + cross_diffr2 = 0.013D0*cs_tmp + cs_delta = cross_frag2 - (cross_diffr1+cross_diffr2-cross_diffr) + if(cs_delta.lt.0.D0) then + cross_frag2 = 0.D0 + cs_multi = cs_multi+cs_delta + else + cross_frag2 = cs_delta + endif + cross_diffr = cross_diffr1 + cross_diffr2 + cs_multidiff = cs_multi + cross_diffr + +C*********************************************************************** + + + else + cross_diffr = 0.D0 + cross_diffr1 = 0.D0 + cross_diffr2 = 0.D0 + cs_multidiff = 0.D0 + cs_multi = 0.D0 + endif + + if (NDIR.eq.3) then + + crossection = cross_res+cross_dir+cs_multidiff+cross_frag2 + RETURN + + else if (NDIR.eq.0) then + + crossection = cross_res+cross_dir+cross_diffr+cross_frag2 + RETURN + + else if (NDIR.eq.2) then + + crossection = cross_res+cross_dir + RETURN + + else if (NDIR.eq.1) then + + crossection = cross_res + RETURN + + else if (NDIR.eq.4) then + + crossection = cross_dir + RETURN + + else if (NDIR.eq.5) then + + crossection = cs_multi + RETURN + + else if (NDIR.eq.6) then + + crossection = cross_res+cross_dir2 + RETURN + + else if (NDIR.eq.7) then + + crossection = cross_res+cross_dir1 + RETURN + + else if (NDIR.eq.8) then + + crossection = cross_res+cross_dir+cross_diffr1 + RETURN + + else if (NDIR.eq.9) then + + crossection = cross_res+cross_dir+cross_diffr + RETURN + + else if (NDIR.eq.10) then + + crossection = cross_diffr + RETURN + + else if ((NDIR.ge.11).and.(NDIR.le.19)) then + + crossection = sig_res(NDIR-10) + RETURN + + else + + print*,'wrong input NDIR in crossection.f !' + STOP + + endif + + END + + + DOUBLE PRECISION function breitwigner(sigma_0,Gamma, + & DMM,eps_prime) + + IMPLICIT DOUBLE PRECISION (A-M,O-Z) + IMPLICIT INTEGER (N) + + SAVE + +c*************************************************************************** +c calculates Breit-Wigner cross section of a resonance with width Gamma [GeV], +c mass DMM [GeV], max. cross section sigma_0 [mubarn] and total mass of the +c interaction s [GeV] +c*************************************************************************** + pm = 0.93827D0 + s = pm*pm+2.D0*pm*eps_prime + gam2s = Gamma*Gamma*s + breitwigner = sigma_0 + & *(s/eps_prime**2)*gam2s/((s-DMM*DMM)**2+gam2s) + + RETURN + + END + + + DOUBLE PRECISION function Pl(x,xth,xmax,alpha) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + if (xth.gt.x) then + Pl = 0. + RETURN + endif + + a = alpha*xmax/xth + prod1 = ((x-xth)/(xmax-xth))**(a-alpha) + prod2 = (x/xmax)**(-a) + Pl = prod1*prod2 + + END + + + DOUBLE PRECISION function Ef(x,th,w) + + IMPLICIT DOUBLE PRECISION (A-M,O-Z) + IMPLICIT INTEGER (N) + + SAVE + + wth = w+th + if (x.le.th) then + Ef = 0. + RETURN + else if (x.gt.th.and.x.lt.wth) then + Ef = (x-th)/w + RETURN + else if (x.ge.wth) then + Ef = 1. + RETURN + else + print*,'error in function EF' + STOP + endif + + END + + + + subroutine dec_inter3(eps_prime,Imode,L0) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + DOUBLE PRECISION RNDM + external RNDM + +c*** decides which process takes place at eps_prime ******** +c (6) excitation/decay of resonance *** +c (2) direct pion production: N\gamma --> N \pi *** +c (3) direct pion production: N\gamma --> \Delta \pi *** +c (1) diffractive scattering: N\gamma --> N \rho *** +c (4) diffractive scattering: N\gamma --> N \omega *** +c (0) multipion production (fragmentation) *** +c (5) fragmentation in resonance region *** +c*********************************************************** +c** Date: 15/04/98 ** +c** author: A.Muecke ** +c********************** + tot = crossection(eps_prime,3,L0) + if (tot.eq.0.) tot = 1.D0 + prob1 = crossection(eps_prime,1,L0)/tot + prob2 = crossection(eps_prime,7,L0)/tot + prob3 = crossection(eps_prime,2,L0)/tot + prob4 = crossection(eps_prime,8,L0)/tot + prob5 = crossection(eps_prime,9,L0)/tot + prob6 = crossection(eps_prime,0,L0)/tot + prob7 = 1.D0 + rn = RNDM(0) + if (rn.lt.prob1) then + Imode = 6 +c ... --> resonance decay + RETURN + else if (prob1.le.rn.and.rn.lt.prob2) then + Imode = 2 +c ... --> direct channel: N\gamma --> N\pi + RETURN + else if (prob2.le.rn.and.rn.lt.prob3) then + Imode = 3 +c ... --> direct channel: N\gamma --> \Delta \pi + RETURN + else if (prob3.le.rn.and.rn.lt.prob4) then + Imode = 1 +c ... --> diffractive scattering: N\gamma --> N \rho + RETURN + else if (prob4.le.rn.and.rn.lt.prob5) then + Imode = 4 +c ... --> diffractive scattering: N\gamma --> N \omega + RETURN + else if (prob5.le.rn.and.rn.lt.prob6) then + Imode = 5 +c ... --> fragmentation (2) in resonance region + return + else if (prob6.le.rn.and.rn.lt.1.D0) then + Imode = 0 +c ... --> fragmentation mode/multipion production + RETURN + else if (rn.eq.1.D0) then + Imode = 0 + RETURN + else + print*,'error in dec_inter.f !' + STOP + endif + + END + + + SUBROUTINE PROC_TWOPART(LA,LB,AMD,Lres,Pres,costheta,nbad) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON /S_MASS1/ AM(49), AM2(49) + COMMON /RES_FLAG/ FRES(49),XLIMRES(49) + SAVE + DIMENSION Pres(2000,5),Lres(2000) + +c*********************************************************** +c 2-particle decay of CMF mass AMD INTO M1 + M2 +C NUCLEON ENERGY E0 [in GeV]; +C E1,E2 [in GeV] are energies of decay products +c LA,LB are code numbers of decay products +c P1(1:5),P2(1:5) are 5-momenta of particles LA,LB; +c resulting momenta are calculated in CM frame; +c costheta is cos of scattering angle in CM frame +c this program also checks if the resulting particles are +c resonances; if yes, it is also allowed to decay a +c mass AMD < M1 + M2 by using the width of the resonance(s) +c*********************************************************** +c** Date: 20/01/98 ** +c** correct.:19/02/98** +c** author: A.Muecke ** +c********************** + + nbad = 0 + SM1 = AM(LA) + if (LB.eq.0) then + SM2 = 2.D0*AM(7) + else + SM2 = AM(LB) + endif + E1 = (AMD*AMD + SM1*SM1 - SM2*SM2)/AMD/2.D0 + E2 = (AMD*AMD + SM2*SM2 - SM1*SM1)/AMD/2.D0 +c... check if SM1+SM2 < AMD: + if ((SM1+SM2).gt.AMD) then +c... if one of the decay products is a resonance, this 'problem' can +c be solved by using a reduced mass for the resonance and assume that +c this resonance is produced at its threshold; + if (FRES(LA).eq.1.D0) then +c ... particle LA is a resonance: + SM1 = AMD-SM2 + E1 = SM1 + E2 = AMD-E1 + if (E1.lt.XLIMRES(LA).or.E2.lt.XLIMRES(LB)) nbad = 1 + endif + if (FRES(LB).eq.1.D0) then +c ... particle LB is a resonance: + SM2 = AMD-SM1 + E2 = SM2 + E1 = AMD-E2 + if (E1.lt.XLIMRES(LA).or.E2.lt.XLIMRES(LB)) nbad = 1 + endif +c ... both particles are NOT resonances: -> error ! + if (FRES(LA).eq.0.D0.and.FRES(LB).eq.0.D0) then + print*,'SM1 + SM2 > AMD in PROC_TWOPART',SM1,SM2,AMD,LA,LB + STOP + endif + endif + + if (nbad.eq.0) then + PC = SQRT((E1*E1 - SM1*SM1)) + Pres(1,4) = E1 + Pres(2,4) = E2 + Pres(1,5) = SM1 + Pres(2,5) = SM2 + + +C ********************************************************* +c theta is scattering angle in CM frame: + r = RNDM(0) + P1Z= PC*costheta + P2Z=-PC*costheta + + P1X = sqrt(r*(PC*PC-P1Z*P1Z)) + P2X = sqrt(r*(PC*PC-P2Z*P2Z)) + P1Y = sqrt((1.D0-r)*(PC*PC-P1Z*P1Z)) + P2Y = sqrt((1.D0-r)*(PC*PC-P2Z*P2Z)) + if(RNDM(0).lt.0.5D0) then + P1X = -P1X + else + P2X = -P2X + endif + if(RNDM(0).lt.0.5D0) then + P1Y = -P1Y + else + P2Y = -P2Y + endif + + Pres(1,1) = P1X + Pres(1,2) = P1Y + Pres(1,3) = P1Z + Pres(2,1) = P2X + Pres(2,2) = P2Y + Pres(2,3) = P2Z + Lres(1) = LA + Lres(2) = LB + endif + + RETURN + + END + + + subroutine dec_res2(eps_prime,IRES,IRESMAX,L0) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + +c***************************************************************************** +c*** decides which resonance with ID=IRES in list takes place at eps_prime *** +c***************************************************************************** +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + + DIMENSION prob_sum(9) + + +c*** sum of all resonances: + sumres = 0.D0 + do 12 j=1,IRESMAX + j10 = j+10 + sumres = sumres+crossection(eps_prime,j10,L0) + prob_sum(j) = sumres + 12 continue + + + r = RNDM(0) + + IRES = 0 + i = 0 + prob = 0.D0 + 10 continue + i = i+1 + probold = prob + prob = prob_sum(i)/sumres + if (r.ge.probold.and.r.lt.prob) then + IRES = i + RETURN + endif + if (i.lt.IRESMAX) goto 10 + if (r.eq.1.D0) IRES = i + if (IRES.eq.0) then + print*,'no resonance possible !' + STOP + endif + + RETURN + + END + + + subroutine dec_proc2(x,IPROC,IRANGE,IRES,L0) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + +c********************************************************************** +c*** decide which decay with ID=IPROC of resonance IRES takes place *** +c********************************************************************** +c** Date: 20/01/98 ** +c** correct.: 27/04/98* +c** author: A.Muecke ** +c********************** + + COMMON /S_RESp/ CBRRES1p(18),CBRRES2p(36),CBRRES3p(26), + + RESLIMp(36),ELIMITSp(9),KDECRES1p(90),KDECRES2p(180), + + KDECRES3p(130),IDBRES1p(9),IDBRES2p(9),IDBRES3p(9) + COMMON /S_RESn/ CBRRES1n(18),CBRRES2n(36),CBRRES3n(22), + + RESLIMn(36),ELIMITSn(9),KDECRES1n(90),KDECRES2n(180), + + KDECRES3n(110),IDBRES1n(9),IDBRES2n(9),IDBRES3n(9) + DIMENSION prob_sum(0:9) + +c x = eps_prime +c ... choose arrays /S_RESp/ for charged resonances, +c ... arrays /S_RESn/ for neutral resonances + if (L0.eq.13) then +c ... charged resonances: + + r = RNDM(0) +c... determine the energy range of the resonance: + nlim = ELIMITSp(IRES) + istart = (IRES-1)*4+1 + if (nlim.gt.0) then + do ie=istart,nlim-2+istart + reslimp1 = RESLIMp(ie) + reslimp2 = RESLIMp(ie+1) + if (x.le.reslimp2.and.x.gt.reslimp1) then + IRANGE = ie+1-istart + endif + enddo + else + irange = 1 + 13 endif + + + + IPROC = -1 + i = 0 + prob_sum(0) = 0.D0 + + if (IRANGE.eq.1) then + j = IDBRES1p(IRES)-1 + if (j.eq.-1) then + print*,'invalid resonance in energy range 1' + endif + 10 continue + j = j+1 + i = i+1 + prob_sum(i) = CBRRES1p(j) + if (r.ge.prob_sum(i-1).and.r.lt.prob_sum(i)) then + IPROC = j + endif + if (prob_sum(i).lt.1.D0) goto 10 + if (r.eq.1.D0) IPROC = j + if (IPROC.eq.-1) then + print*,'no resonance decay possible !' + endif + + else if (IRANGE.eq.2) then + j = IDBRES2p(IRES)-1 + if (j.eq.-1) then + print*,'invalid resonance in energy range 2' + endif + 11 continue + j = j+1 + i = i+1 + prob_sum(i) = CBRRES2p(j) + if (r.ge.prob_sum(i-1).and.r.lt.prob_sum(i)) then + IPROC = j + endif + if (prob_sum(i).lt.1.D0) goto 11 + if (r.eq.1.D0) IPROC = j + if (IPROC.eq.-1) then + print*,'no resonance decay possible !' + endif + + else if (IRANGE.eq.3) then + j = IDBRES3p(IRES)-1 + if (j.eq.-1) then + print*,'invalid resonance in energy range 3' + endif + 12 continue + j = j+1 + i = i+1 + prob_sum(i) = CBRRES3p(j) + if (r.ge.prob_sum(i-1).and.r.lt.prob_sum(i)) then + IPROC = j + endif + if (prob_sum(i).lt.1.D0) goto 12 + if (r.eq.1.D0) IPROC = j + if (IPROC.eq.-1) then + print*,'no resonance decay possible !' + endif + + else + print*,'invalid IRANGE in DEC_PROC2' + endif + + RETURN + + + else if (L0.eq.14) then +c ... neutral resonances: + + r = RNDM(0) +c... determine the energy range of the resonance: + nlim = ELIMITSn(IRES) + istart = (IRES-1)*4+1 + if (nlim.gt.0) then + do ie=istart,nlim-2+istart + if (x.le.RESLIMn(ie+1).and.x.gt.RESLIMn(ie)) then + IRANGE = ie+1-istart + endif + enddo + else + irange = 1 + endif + + + IPROC = -1 + i = 0 + prob_sum(0) = 0.D0 + + if (IRANGE.eq.1) then + j = IDBRES1n(IRES)-1 + if (j.eq.-1) then + print*,'invalid resonance in this energy range' + endif + 20 continue + j = j+1 + i = i+1 + prob_sum(i) = CBRRES1n(j) + if (r.ge.prob_sum(i-1).and.r.lt.prob_sum(i)) then + IPROC = j + endif + if (prob_sum(i).lt.1.D0) goto 20 + if (r.eq.1.D0) IPROC = j + if (IPROC.eq.-1) then + print*,'no resonance decay possible !' + endif + + else if (IRANGE.eq.2) then + j = IDBRES2n(IRES)-1 + if (j.eq.-1) then + print*,'invalid resonance in this energy range' + endif + 21 continue + j = j+1 + i = i+1 + prob_sum(i) = CBRRES2n(j) + if (r.ge.prob_sum(i-1).and.r.lt.prob_sum(i)) then + IPROC = j + endif + if (prob_sum(i).lt.1.D0) goto 21 + if (r.eq.1.) IPROC = j + if (IPROC.eq.-1) then + print*,'no resonance decay possible !' + endif + + else if (IRANGE.eq.3) then + j = IDBRES3n(IRES)-1 + if (j.eq.-1) then + print*,'invalid resonance in this energy range' + endif + 22 continue + j = j+1 + i = i+1 + prob_sum(i) = CBRRES3n(j) + if (r.ge.prob_sum(i-1).and.r.lt.prob_sum(i)) then + IPROC = j + endif + if (prob_sum(i).lt.1.D0) goto 22 + if (r.eq.1.D0) IPROC = j + if (IPROC.eq.-1) then + print*,'no resonance decay possible !' + endif + + else + print*,'invalid IRANGE in DEC_PROC2' + endif + + RETURN + + else + print*,'no valid L0 in DEC_PROC !' + STOP + endif + + END + + + SUBROUTINE RES_DECAY3(IRES,IPROC,IRANGE,s,L0,nbad) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + COMMON /S_RESp/ CBRRES1p(18),CBRRES2p(36),CBRRES3p(26), + + RESLIMp(36),ELIMITSp(9),KDECRES1p(90),KDECRES2p(180), + + KDECRES3p(130),IDBRES1p(9),IDBRES2p(9),IDBRES3p(9) + COMMON /S_RESn/ CBRRES1n(18),CBRRES2n(36),CBRRES3n(22), + + RESLIMn(36),ELIMITSn(9),KDECRES1n(90),KDECRES2n(180), + + KDECRES3n(110),IDBRES1n(9),IDBRES2n(9),IDBRES3n(9) + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb +c COMMON /S_CNAM/ NAMP (0:49) +c CHARACTER NAMP*6, NAMPRESp*6, NAMPRESn*6 + +* external scatangle, proc_twopart + +c******************************************************** +c RESONANCE AMD with code number IRES INTO M1 + M2 +C PROTON ENERGY E0 [in GeV] IN DMM [in GeV] +C E1,E2 [in GeV] are energies of decay products +c LA,LB are code numbers of decay products +c P(1,1:5),P(2,1:5) are 5-momenta of particles LA,LB; +c resulting momenta are calculated in CM frame; +c ANGLESCAT is cos of scattering angle in CM frame +c******************************************************** +c** Date: 20/01/98 ** +c** correct.:28/04/98** +c** author: A.Muecke ** +c********************** + +c... determine decay products LA, LB: + NP = 2 + if (L0.eq.13) then +c ... proton is incident nucleon: + if (IRANGE.eq.1) then + LA = KDECRES1p(5*(IPROC-1)+3) + LB = KDECRES1p(5*(IPROC-1)+4) + else if (IRANGE.eq.2) then + LA = KDECRES2p(5*(IPROC-1)+3) + LB = KDECRES2p(5*(IPROC-1)+4) + else if (IRANGE.eq.3) then + LA = KDECRES3p(5*(IPROC-1)+3) + LB = KDECRES3p(5*(IPROC-1)+4) + else + print*,'error in res_decay3' + endif + else if (L0.eq.14) then +c ... neutron is incident nucleon: + if (IRANGE.eq.1) then + LA = KDECRES1n(5*(IPROC-1)+3) + LB = KDECRES1n(5*(IPROC-1)+4) + else if (IRANGE.eq.2) then + LA = KDECRES2n(5*(IPROC-1)+3) + LB = KDECRES2n(5*(IPROC-1)+4) + else if (IRANGE.eq.3) then + LA = KDECRES3n(5*(IPROC-1)+3) + LB = KDECRES3n(5*(IPROC-1)+4) + else + print*,'error in res_decay3' + endif + + else + print*,'no valid L0 in RES_DECAY' + STOP + endif + + LLIST(1) = LA + LLIST(2) = LB + +c... sample scattering angle: + call scatangle(anglescat,IRES,L0) + +c ... 2-particle decay: + call proc_twopart(LA,LB,sqrt(s),LLIST,P,anglescat,nbad) + + RETURN + + END + +c*********************************************************** +C calculates functions for crossection of direct channel +c NOT isospin-corrected, simply a samelsurium of functions +c x is eps_prime in GeV (see main program) +C (see thesis of J.Rachen, p.45ff) +c note: neglect strange- and eta-channel +C*********************************************************** +c** Date: 27/04/98 ** +c** last chg:23/05/98** +c** author: A.Muecke ** +c********************** +c + + DOUBLE PRECISION FUNCTION singleback(x) +c**************************** +c SINGLE PION CHANNEL +c**************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + singleback = 92.7D0*Pl(x,.152D0,.25D0,2.D0) + + END + + + DOUBLE PRECISION FUNCTION twoback(x) +c***************************** +c TWO PION PRODUCTION +c***************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + twoback = 37.7D0*Pl(x,.4D0,.6D0,2.D0) + + END + + + subroutine scatangle(anglescat,IRES,L0) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + +c******************************************************************* +c This routine samples the cos of the scattering angle for a given * +c resonance IRES and incident nucleon L0; it is exact for ** +c one-pion decay channel and if there is no ** +c other contribution to the cross section from another resonance ** +c and an approximation for an overlay of resonances; ** +c for decay channels other than the one-pion decay a isotropic ** +c distribution is used ** +c******************************************************************* +c** Date: 16/02/98 ** +c** author: A.Muecke ** +c********************** + + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + +c ... use rejection method for sampling: + LA = LLIST(1) + LB = LLIST(2) + 10 continue + r = RNDM(0) +c*** sample anglescat random between -1 ... 1 ** + anglescat = 2.D0*(r-0.5D0) +c ... distribution is isotropic for other than one-pion decays: + if ((LA.eq.13.or.LA.eq.14).and.LB.ge.6.and.LB.le.8) then + prob = probangle(IRES,L0,anglescat) + else + prob = 0.5D0 + endif + r = RNDM(0) + if (r.le.prob) then + RETURN + else + goto 10 + endif + 12 continue + + END + + DOUBLE PRECISION function probangle(IRES,L0,z) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + +c******************************************************************** +c probability distribution for scattering angle of given resonance ** +c IRES and incident nucleon L0 ; ** +c z is cosine of scattering angle in CMF frame ** +c******************************************************************** + + if (IRES.eq.4.or.IRES.eq.5.or.IRES.eq.2) then +c ... N1535 andf N1650 decay isotropically. + probangle = 0.5D0 + return + endif + + if (IRES.eq.1) then +c ... for D1232: + probangle = 0.636263D0 - 0.408790D0*z*z + return + endif + + if (IRES.eq.3.and.L0.eq.14) then +c ... for N1520 and incident n: + probangle = 0.673669D0 - 0.521007D0*z*z + return + endif + + if (IRES.eq.3.and.L0.eq.13) then +c ... for N1520 and incident p: + probangle = 0.739763D0 - 0.719288D0*z*z + return + endif + + if (IRES.eq.6.and.L0.eq.14) then +c ... for N1680 (more precisely: N1675) and incident n: + q=z*z + probangle = 0.254005D0 + 1.427918D0*q - 1.149888D0*q*q + return + endif + + + if (IRES.eq.6.and.L0.eq.13) then +c ... for N1680 and incident p: + q=z*z + probangle = 0.189855D0 + 2.582610D0*q - 2.753625D0*q*q + return + endif + + if (IRES.eq.7) then +c ... for D1700: + probangle = 0.450238D0 + 0.149285D0*z*z + return + endif + + + if (IRES.eq.8) then +c ... for D1905: + q=z*z + probangle = 0.230034D0 + 1.859396D0*q - 1.749161D0*q*q + return + endif + + + if (IRES.eq.9) then +c ... for D1950: + q=z*z + probangle = 0.397430D0 - 1.498240D0*q + 5.880814D0*q*q + & - 4.019252D0*q*q*q + return + endif + + print*,'error in function probangle !' + STOP + END + +C-> + DOUBLE PRECISION FUNCTION GAUSS (FUN, A,B) +c********************************************************* +C Returns the 8 points Gauss-Legendre integral +C of function FUN from A to B +c this routine was provided by T.Stanev +c********************************************************* +c** Date: 20/01/98 ** +c** A.Muecke ** +c********************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + EXTERNAL FUN + +C........................................................... + DIMENSION X(8), W(8) + DATA X /.0950125098D0,.2816035507D0,.4580167776D0,.6178762444D0 + + ,.7554044083D0,.8656312023D0,.9445750230D0,.9894009349D0/ + DATA W /.1894506104D0,.1826034150D0,.1691565193D0,.1495959888D0 + + ,.1246289712D0,.0951585116D0,.0622535239D0, .0271524594D0/ + + XM = 0.5D0*(B+A) + XR = 0.5D0*(B-A) + SS = 0.D0 + DO NJ=1,8 + DX = XR*X(NJ) + SS = SS + W(NJ) * (FUN(XM+DX) + FUN(XM-DX)) + ENDDO + GAUSS = XR*SS + RETURN + END + + + + + +C-> +c*************************** +c** last change: 12/10/98 ** +c** author: A.Muecke ** +c*************************** + BLOCK DATA DATDEC + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + COMMON /S_CSYDEC/ CBR(102), IDB(49), KDEC(612), LBARP(49) + COMMON /S_MASS1/ AM(49), AM2(49) + COMMON /S_CHP/ S_LIFE(49), ICHP(49), ISTR(49), IBAR(49) + COMMON /S_CNAM/ NAMP (0:49) + + CHARACTER NAMPRESp*6 + COMMON /RES_PROPp/ AMRESp(9), BGAMMAp(9),WIDTHp(9), + + RATIOJp(9),NAMPRESp(0:9) + + CHARACTER NAMPRESn*6 + COMMON /RES_PROPn/ AMRESn(9), BGAMMAn(9),WIDTHn(9), + + RATIOJn(9),NAMPRESn(0:9) + + COMMON /S_RESp/ CBRRES1p(18),CBRRES2p(36),CBRRES3p(26), + + RESLIMp(36),ELIMITSp(9),KDECRES1p(90),KDECRES2p(180), + + KDECRES3p(130),IDBRES1p(9),IDBRES2p(9),IDBRES3p(9) + COMMON /S_RESn/ CBRRES1n(18),CBRRES2n(36),CBRRES3n(22), + + RESLIMn(36),ELIMITSn(9),KDECRES1n(90),KDECRES2n(180), + + KDECRES3n(110),IDBRES1n(9),IDBRES2n(9),IDBRES3n(9) + COMMON /RES_FLAG/ FRES(49),XLIMRES(49) + CHARACTER NAMP*6 + + DATA Ideb / 0 / + + DATA FRES /0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + + 1,1,1,0,0,0,0,1,1,0,0,0,0,0,0,1,1,1,1,0,0,0,0,0,1/ + DATA XLIMRES /0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0. + + ,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., + + .275,.275,.28,0.,0.,0.,0.,.41,.9954,0.,0.,0.,0.,0.,0., + + 1.078,1.08,1.078,1.08,0,0,0,0,0,1/ + DATA AMRESp / 1.231,1.440,1.515,1.525,1.675,1.680,1.690, + + 1.895,1.950/ + DATA AMRESn / 1.231,1.440,1.515,1.525,1.675,1.675,1.690, + + 1.895,1.950/ + DATA IDBRES1p / + + 1,3,5,7,9,11,13,15,17/ + DATA IDBRES2p / + + 0,1,6,11,14,19,24,27,32/ + DATA IDBRES3p / + + 0,0,1,0,3,9,16,21,26/ + DATA IDBRES1n / + + 1,3,5,7,9,11,13,15,17/ + DATA IDBRES2n / + + 0,1,6,11,14,19,24,27,32/ + DATA IDBRES3n / + + 0,0,1,0,3,0,9,14,19/ + + DATA CBRRES1p / + + .667,1.,.667,1.,.667,1.,.667,1.,.667,1.,.667,1.,.667,1., + + .667,1.,.667,1./ + DATA CBRRES1n / + + .667,1.,.667,1.,.667,1.,.667,1.,.667,1.,.667,1.,.667,1., + + .667,1.,.667,1./ +C************************** settings of versions 1.4 - 2.0 ********* + DATA CBRRES2p / + + .333,.5,.750,.917,1.,.333,.5,.75,.917,1.,.167,.25,1., + + .567,.85,.925,.975,1.,.433,.65,.825,.942,1.,.4,.467,1., + + .267,.4,.64,.68,1.,.4,.6,.76,.787,1./ + DATA CBRRES2n / + + .333,.5,.750,.917,1.,.333,.5,.75,.917,1.,.167,.25,1., + + .567,.85,.925,.975,1.,.267,.4,.7,.9,1.,.4,.467,1., + + .267,.4,.64,.68,1.,.4,.6,.76,.787,1./ + DATA CBRRES3p / + + .333,1.,.467,.7,.775,.825,.85,1.,.367,.55,.7, + + 1.,.08,.093,.2,.733,1.,.667,1., + + .2,.3,.46,.487,.7,.9,1./ + DATA CBRRES3n / + + .333,1.,.467,.7,.775,.825,.85,1., + + .08,.093,.2,.733,1.,.667,1., + + .2,.3,.46,.487,.7,.9,1./ + DATA KDECRES1p / + + 2,0,13,6,0,2,0,14,7,0,2,0,14,7,0,2,0,13,6,0,2,0,14,7,0, + + 2,0,13,6,0,2,0,14,7,0,2,0,13,6,0,2,0,14,7,0,2,0,13,6,0, + + 2,0,14,7,0,2,0,13,6,0,2,0,13,6,0,2,0,14,7,0,2,0,13,6,0, + + 2,0,14,7,0,2,0,13,6,0,2,0,14,7,0/ + DATA KDECRES2p / + + 2,0,14,7,0,2,0,13,6,0,2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,14,7,0,2,0,13,6,0,2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,14,7,0,2,0,13,6,0,2,0,13,23,0,2,0,14,7,0,2,0,13,6,0, + + 2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,14,7,0,2,0,13,6,0,2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,13,6,0,2,0,14,7,0,2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,13,6,0,2,0,14,7,0,2,0,40,8,0,2,0,41,6,0,2,0,42,7,0/ + DATA KDECRES3p / + + 2,0,13,27,0,2,0,14,25,0, + + 2,0,14,7,0,2,0,13,6,0,2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,39,9,0, + + 2,0,14,7,0,2,0,13,6,0, + + 2,0,13,27,0,2,0,14,25,0,2,0,40,8,0,2,0,41,6,0,2,0,42,7,0, + + 2,0,13,27,0,2,0,14,25,0, + + 2,0,13,27,0,2,0,14,25,0, + + 2,0,13,6,0,2,0,14,7,0, + + 2,0,40,8,0,2,0,41,6,0,2,0,42,7,0,2,0,13,27,0,2,0,14,25,0/ + DATA KDECRES1n / + + 2,0,14,6,0,2,0,13,8,0,2,0,13,8,0,2,0,14,6,0,2,0,13,8,0, + + 2,0,14,6,0,2,0,13,8,0,2,0,14,6,0,2,0,13,8,0,2,0,14,6,0, + + 2,0,13,8,0,2,0,14,6,0,2,0,14,6,0,2,0,13,8,0,2,0,14,6,0, + + 2,0,13,8,0,2,0,14,6,0,2,0,13,8,0/ + DATA KDECRES2n / + + 2,0,13,8,0,2,0,14,6,0,2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,13,8,0,2,0,14,6,0,2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,13,8,0,2,0,14,6,0,2,0,14,23,0,2,0,13,8,0,2,0,14,6,0, + + 2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,13,8,0,2,0,14,6,0,2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,14,6,0,2,0,13,8,0,2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,14,6,0,2,0,13,8,0,2,0,43,7,0,2,0,42,6,0,2,0,41,8,0/ + DATA KDECRES3n / + + 2,0,14,27,0,2,0,13,26,0, + + 2,0,13,8,0,2,0,14,6,0,2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,39,21,0, + + 2,0,43,7,0,2,0,42,6,0,2,0,41,8,0, + + 2,0,14,27,0,2,0,13,26,0, + + 2,0,14,27,0,2,0,13,26,0, + + 2,0,14,6,0,2,0,13,8,0, + + 2,0,43,7,0,2,0,42,6,0,2,0,41,8,0,2,0,14,27,0,2,0,13,26,0/ + DATA RESLIMp / + + 0.,0.,0.,0.,0.,.54,10.,0.,0.,.54,1.09,10., + + 0.,.71,10.,0.,0.,.54,.918,10., + + 0.,.54,1.09,10.,0.,.54,1.09,10., + + 0.,.54,1.09,10.,0.,.54,1.09,10./ + DATA RESLIMn / + + 0.,.0,.0,.0,0.,.54,10.,0.,0.,.54,1.09,10., + + 0.,.71,10.,0.,0.,.54,.918,10., + + 0.,.54,10.,0.,0.,.54,1.09,10.,0.,.54,1.09,10., + + 0.,.54,1.09,10./ + DATA ELIMITSp /0,3,4,3,4,4,4,4,4/ + DATA ELIMITSn /0,3,4,3,4,3,4,4,4/ + DATA NAMPRESp / + + ' ','D+1232','N+1440','N+1520','N+1535','N+1650', + + 'N+1680','D+1700','D+1905','D+1950'/ + DATA NAMPRESn / + + ' ','D01232','N01440','N01520','N01535','N01650', + + 'N01675','D01700','D01905','D01950'/ + DATA BGAMMAp / + + 5.6,0.5,4.6,2.5,1.0,2.1,2.0,0.2,1.0/ + DATA RATIOJp / + + 1.,0.5,1.,0.5,0.5,1.5,1.,1.5,2./ + DATA WIDTHp / + + .11,.35,.11,.10,.16,.125,.29,.35,.3/ + DATA BGAMMAn / + + 6.1,0.3,4.0,2.5,0.,0.2,2.0,0.2,1.0/ + DATA RATIOJn / + + 1.,0.5,1.,0.5,0.5,1.5,1.,1.5,2./ + DATA WIDTHn / + + .11,.35,.11,.10,.16,.15,.29,.35,.3/ + + + DATA CBR /3*1.,0.,1.,1.,0.6351,0.8468,0.9027,0.9200,0.9518,1., + + 0.6351,0.8468,0.9027,0.9200,0.9518,1.,0.2160,0.3398,0.4748, + + 0.6098,0.8049,1.,0.6861,1.,3*0.,0.5,1.,0.5,1., + + 0.3890,0.7080,0.9440,0.9930,1.,0.,0.4420,0.6470,0.9470,0.9770, + + 0.9990,4*1.,0.6670,1.,9*0.,0.6670,1.,0.6670,1.,0.6670,1., + + 0.8880,0.9730,1.,0.4950,0.8390,0.9870,1.,0.5160,5*1.,0.6410,1., + + 1.,0.67,1.,0.33,1.,1.,0.88,0.94,1.,0.88,0.94,1.,0.88,0.94,1., + + 0.33,1.,0.67,1.,0.678,0.914,1./ + DATA AM / 0.,2*0.511E-3, 2*0.10566, 0.13497, 2*0.13957, + + 2*0.49365, 2*0.49767, 0.93827, 0.93957, 4*0.,0.93827, + + 0.93957, 2*0.49767, 0.54880,0.95750,2*0.76830,0.76860, + + 2*0.89183,2*0.89610,0.78195,1.01941,1.18937,1.19255, + + 1.19743,1.31490,1.32132,1.11563,1.23100,1.23500, + + 1.23400,1.23300,1.38280,1.38370,1.38720, + + 1.53180,1.53500,1.67243 / + DATA AM2 /0.,2*2.61121E-07,2*0.011164,0.018217,0.019480, + + 0.019480,0.243690,0.243690,0.247675,0.247675,0.880351,0.882792, + + 0.000000,0.000000,0.000000,0.000000,0.880351,0.882792,0.247675, + + 0.247675,0.301181,0.916806,0.590285,0.590285,0.590746,0.795361, + + 0.795361,0.802995,0.802995,0.611446,1.039197,1.414601,1.422176, + + 1.433839,1.728962,1.745887,1.244630,1.515361,1.525225,1.522765, + + 1.520289,1.912136,1.914626,1.924324,2.346411,2.356225,2.797022/ + DATA IDB / + + 0,0,0,1,2,3,5,6,7,13,19,25,8*0,30,32,34,40,46,47,48,49,60,62, + + 64,66,69,73,75,76,77,78,79,81,82,84,86,87,90,93,96,98,100/ + DATA KDEC / + + 3,1,15,2,18,0,3,1,16,3,17,0,2,0,1,1,8*0,2,0,4,17,0,0,2,0,5,18,0, + + 0,2,0,4,17,0,0,2,0,7,6,0,0,3,0,7,7,8,0,3,0,7,6,6,0,3,1,17,4,6,0, + + 3,1,15,2,6,0,2,0,5,18,0,0,2,0,8,6,0,0,3,0,8,8,7,0,3,0,8,6,6,0,3, + + 1,18,5,6,0,3,1,16,3,6,0,3,0,6,6,6,0,3,0,7,8,6,0,3,1,18,5,7,0,3, + + 1,17,4,8,0,3,1,16,3,7,0,3,1,15,2,8,0,2,0,7,8,0,0,2,0,6,6,20*0,1, + + 0,11,3*0,1,0,12,0,0,0,1,0,11,0,0,0,1,0,12,0,0,0,2,0,1,1,0,0,3,0, + + 6,6,6,0,3,0,7,8,6,0,3,0,1,7,8,0,3,0,1,3,2,7*0,3,0,7,8,23,0,3,0,6 + + ,6,23,0,2,0,1,27,0,0,2,0,1,32,0,0,2,0,1,1,0,0,3,0,6,6,6,0,2,0,7, + + 6,0,0,2,0,8,6,0,0,2,0,7,8,0,0,2,0,21,7,0,0,2,0,9,6,0,0,54*0,2,0, + + 22,8,0,0,2,0,10,6,0,0,2,0,9,8,0,0,2,0,21,6,0,0,2,0,10,7,0,0, + + 2,0,22,6,0,0,3,0,7,8,6,0,2,0,1,6,0,0,2,0,7,8,0,0,2,0,9,10,0, + + 0,2,0,11,12,0,0,3,0,7, + + 8,6,0,2,0,1,23,0,0,2,0,13,6,0,0,2,0,14,7,0,0,2,0,39,1,0,0,2, + + 0,14,8,0,0,2,0,39,6,0,0,2,0,39,8,0,0,2,0,13,8,0,0,2,0, + + 14,6,0,0,2,0,13,7,0,0,2,0,13,6, + + 0,0,2,0,14,7,0,0,2,0,13,8,0,0,2,0,14,6,0,0,2,0,14,8,0,0,2,0, + + 39,7,0,0,2,0,34,6,0,0,2,0,35,7,0,0,2,0,39,6,0,0,2,0,34,8,0,0, + + 2,0,36,7,0,0,2,0,39,8,0,0,2, + + 0,35,8,0,0,2,0,36,6,0,0,2,0,37,6,0,0,2,0,38,7,0,0,2,0, + + 37,8,0,0,2,0,38,6,0,0,2,0,39,10,0,0,2,0,37,8,0,0,2,0,38,6,0,0/ + DATA LBARP/1,3,2,5,4,6,8,7,10,9,11,12,-13,-14,16,15,18,17,13,14, + + 22,21,23,24,26,25,27,29,28,31,30,32,33,-34,-35,-36,-37,-38,-39, + + -40,-41,-42,-43,-44,-45,-46,-47,-48,-49/ + DATA ICHP /0,1,-1,1,-1,0,1,-1,1,-1,0,0,1,0,4*0,-1,0,4*0, + + 1,-1,0,1,-1,4*0,1,0,-1,0,-1,0,2,1,0,-1,1,0,-1,0,-1,-1/ + DATA ISTR /8*0,-1,+1,10,10,8*0,-1,+1,5*0,-1,+1,-1,+1,2*0, + + 3*1,2*2,1,4*0,3*1,2*2,3 / + DATA IBAR /12*0,2*1,4*0,2*-1,13*0,16*1/ + DATA NAMP / + + ' ','gam ','e+','e-','mu+','mu-','pi0', + + 'pi+','pi-','k+', 'k-', 'k0l','k0s', + + 'p', 'n', 'nue', 'nueb', 'num', 'numb', 'pbar', 'nbar', + + 'k0', 'k0b', 'eta', 'etap', 'rho+', 'rho-','rho0', + + 'k*+','k*-','k*0','k*0b','omeg', 'phi', 'SIG+', 'SIG0', + + 'SIG-','XI0','XI-','LAM','DELT++','DELT+','DELT0','DELT-', + + 'SIG*+ ','SIG*0','SIG*-', 'XI*0', 'XI*-', 'OME*-'/ + DATA S_LIFE /0.,0.,0.,2.197D-6,2.197D-6,8.4D-17,2.6033D-8, + + 2.6033D-8,1.2371D-8,1.2371D-8, + + 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., + + 0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., + + 0.,0.,0./ + END +C-> + BLOCK DATA PARAM_INI +C....This block data contains default values +C. of the parameters used in fragmentation +C................................................ + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + COMMON /S_CZDIS/ FA, FB0 + COMMON /S_CZDISs/ FAs1, fAs2 + COMMON /S_CZLEAD/ CLEAD, FLEAD + COMMON /S_CPSPL/ CCHIK(3,6:14) + COMMON /S_CQDIS/ PPT0 (33),ptflag + COMMON /S_CDIF0/ FFD, FBD, FDD + COMMON /S_CFLAFR/ PAR(8) +C...Longitudinal Fragmentation function + DATA FA /0.5/, FB0 /0.8/ +C...Longitudinal Fragmentation function for leading baryons + DATA CLEAD /0.0/, FLEAD /0.6/ +c strange fragmentation + data FAs1 /3./, fAs2 /3./ +c data FAs1 /0./, fAs2 /0./ +C...pT of sea partons + DATA PTFLAG /1./ + DATA PPT0 /0.30,0.30,0.450,30*0.60/ +C...Splitting parameters + DATA CCHIK /21*2.,6*3./ +C...Parameters of flavor formation + DATA PAR /0.04,0.25,0.25,0.14,0.3,0.3,0.15,0./ + END + + + SUBROUTINE gamma_h(Ecm,ip1,Imode,ifbad) +C********************************************************************** +C +C simple simulation of low-energy interactions (R.E. 03/98) +C +C changed to simulate superposition of reggeon and pomeron exchange +C interface to Lund / JETSET 7.4 fragmentation +C (R.E. 08/98) +C +C +C +C input: ip1 incoming particle +C 13 - p +C 14 - n +C Ecm CM energy in GeV +C Imode interaction mode +C 0 - multi-pion fragmentation +C 5 - fragmentation in resonance region +C 1 - quasi-elastic / diffractive interaction +C (p/n-gamma --> n/p rho) +C 4 - quasi-elastic / diffractive interaction +C (p/n-gamma --> n/p omega) +C 2 - direct interaction (p/n-gamma --> n/p pi) +C 3 - direct interaction (p/n-gamma --> delta pi) +C IFBAD control flag +C (0 all OK, +C 1 generation of interaction not possible) +C +C********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON /S_RUN/ SQS, S, Q2MIN, XMIN, ZMIN, kb, kt, a1, a2, Nproc + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + COMMON /S_CHP/ S_LIFE(49), ICHP(49), ISTR(49), IBAR(49) + COMMON /S_MASS1/ AM(49), AM2(49) + COMMON /S_CFLAFR/ PAR(8) + SAVE + + DIMENSION P_dec(10,5), P_in(5) + DIMENSION xs1(2), xs2(2), xmi(2), xma(2) + DIMENSION LL(10), Ijoin(4) + + DOUBLE PRECISION PA1(4), PA2(4), P1(4), P2(4) + + DATA Ic / 0 / + +C second particle is always photon + IP2 = 1 +C parameters of pi0 suppression + a1 = 0.5D0 + a2 = 0.5D0 +C parameter of strangeness suppression + PAR(2) = 0.18D0 +C slope of pomeron trajectory + alphap = 0.25D0 + + ifbad = 0 + SQS = Ecm + S = SQS*SQS + Ic = Ic+1 + + + IF((Imode.eq.1).or.(Imode.eq.4)) THEN + +C*********************************************************************** + +C simulation of diffraction + + ipa = ip1 + ipb = ip2 + + if(Imode.eq.1) then + Nproc = 1 + if(ip1.eq.1) then + ipa = 27 + else if(ip2.eq.1) then + ipb = 27 + endif + else if(Imode.eq.4) then + Nproc = 4 + if(ip1.eq.1) then + ipa = 32 + else if(ip2.eq.1) then + ipb = 32 + endif + endif + + am_a = AM(ipa) + am_b = AM(ipb) + if(am_a+am_b.ge.Ecm-1.D-2) am_a = Ecm - am_b-1.D-2 + +C find t range + e1 = 0.5D0*(Ecm + AM(ip1)**2/Ecm - AM(ip2)**2/Ecm) + if(e1.gt.100.D0*AM(ip1)) then + pcm1 = e1 - 0.5D0*AM(ip1)**2/e1 + else + pcm1 = sqrt((e1-AM(ip1))*(e1+AM(ip1))) + endif + e3 = 0.5D0*(Ecm + am_a**2/Ecm - am_b**2/Ecm) + if(e3.gt.100.D0*am_a) then + pcm3 = e3 - 0.5D0*am_a**2/e3 + else + pcm3 = sqrt((e3-am_a)*(e3+am_a)) + endif + t0 = ((AM(ip1)**2-am_a**2-AM(ip2)**2+am_b**2)/(2.D0*Ecm))**2 + & -(pcm1-pcm3)**2-0.0001D0 + t1 = ((AM(ip1)**2-am_a**2-AM(ip2)**2+am_b**2)/(2.D0*Ecm))**2 + & -(pcm1+pcm3)**2+0.0001D0 + +C sample t + b = 6.5D0+2.D0*alphap*log(S) + t = 1.D0/b*log((exp(b*t0)-exp(b*t1))*RNDM(0)+exp(b*t1)) + +C kinematics + pl = (2.D0*e1*e3+t-AM(ip1)**2-am_a**2)/(2.D0*pcm1) + pt = (pcm3-pl)*(pcm3+pl) + if(pt.lt.0.D0) then + pl = sign(pcm3,pl) + pt = 1.D-6 + else + pt = sqrt(pt) + endif + phi = 6.28318530717959D0*RNDM(0) + + LLIST(1) = ipa + P(1,4) = e3 + P(1,1) = SIN(phi)*pt + P(1,2) = COS(phi)*pt + P(1,3) = pl + P(1,5) = am_a + LLIST(2) = ipb + P(2,1) = -P(1,1) + P(2,2) = -P(1,2) + P(2,3) = -P(1,3) + P(2,4) = Ecm - P(1,4) + P(2,5) = am_b + np = 2 + + call DECSIB + + ELSE IF((Imode.eq.2).or.(Imode.eq.3)) THEN + +C*********************************************************************** + +C simulation of direct p-gamma process + + if(ip1.eq.13) then +C projectile is a proton + if(Imode.eq.2) then + Nproc = 2 + ipa = 14 + ipb = 7 + else + Nproc = 3 + if(rndm(0).gt.0.25) then + ipa = 40 + ipb = 8 + else + ipa = 42 + ipb = 7 + endif + endif + else if(ip1.eq.14) then +C projectile is a neutron + if(Imode.eq.2) then + Nproc = 2 + ipa = 13 + ipb = 8 + else + Nproc = 3 + if(rndm(0).gt.0.25) then + ipa = 43 + ipb = 7 + else + ipa = 41 + ipb = 8 + endif + endif + endif + + am_a = AM(ipa) + am_b = AM(ipb) + if(am_a+am_b.ge.Ecm-1.e-3) am_a = Ecm - am_b-1.D-3 + +C find t range + e1 = 0.5D0*(Ecm + AM(ip1)**2/Ecm - AM(ip2)**2/Ecm) + if(e1.gt.100.D0*AM(ip1)) then + pcm1 = e1 - 0.5D0*AM(ip1)**2/e1 + else + pcm1 = sqrt((e1-AM(ip1))*(e1+AM(ip1))) + endif + e3 = 0.5D0*(Ecm + am_a**2/Ecm - am_b**2/Ecm) + if(e3.gt.100.D0*am_a) then + pcm3 = e3 - 0.5D0*am_a**2/e3 + else + pcm3 = sqrt((e3-am_a)*(e3+am_a)) + endif + t0 = ((AM(ip1)**2-am_a**2-AM(ip2)**2+am_b**2)/(2.D0*Ecm))**2 + & -(pcm1-pcm3)**2-0.0001D0 + t1 = ((AM(ip1)**2-am_a**2-AM(ip2)**2+am_b**2)/(2.D0*Ecm))**2 + & -(pcm1+pcm3)**2+0.0001D0 + +C sample t + b = 12.D0 + t = 1./b*log((exp(b*t0)-exp(b*t1))*RNDM(0)+exp(b*t1)) + +C kinematics + pl = (2.D0*e1*e3+t-AM(ip1)**2-am_a**2)/(2.D0*pcm1) + pt = (pcm3-pl)*(pcm3+pl) + if(pt.lt.0.D0) then + pl = sign(pcm3,pl) + pt = 1.D-6 + else + pt = sqrt(pt) + endif + phi = 6.28318530717959D0*RNDM(0) + + LLIST(1) = ipa + P(1,4) = e3 + P(1,1) = SIN(phi)*pt + P(1,2) = COS(phi)*pt + P(1,3) = pl + P(1,5) = am_a + LLIST(2) = ipb + P(2,1) = -P(1,1) + P(2,2) = -P(1,2) + P(2,3) = -P(1,3) + P(2,4) = Ecm - P(1,4) + P(2,5) = am_b + np = 2 + + call DECSIB + + ELSE + +C*********************************************************************** + +C simulation of multiparticle production via fragmentation + + Nproc = 0 + + SIG_reg = 129.D0*(S-AM(13)**2)**(-0.4525D0) + SIG_pom = 67.7D0*(S-AM(13)**2)**0.0808D0 + + if(S.gt.2.6D0) then + prob_reg = SIG_reg/(SIG_pom+SIG_reg) + else + prob_reg = 1.D0 + endif + + ptu =.36D0+.08D0*log10(sqs/30.D0) + + s1 = 1.2D0 + s2 = 0.6D0 + as1 = s1**2/S + as2 = s2**2/S + if(s1+s2.ge.sqs-0.2) then + prob_reg = 1.D0 + endif + + itry = 0 + 100 continue + Istring = 0 + +C avoid infinite looping + itry = itry+1 + if(itry.gt.50) then + print *,' gamma_h: more than 50 internal rejections,' + print *,' called with ip1,ip2,Ecm,Imode:',ip1,ip2,Ecm,Imode + PAUSE + ifbad = 1 + return + endif + +C simulate reggeon (one-string topology) + + if(RNDM(0).lt.prob_reg) then + + do i=1,1000 + call valences(IP1,Ifl1a,Ifl1b) + call valences(IP2,Ifl2a,Ifl2b) + if(Ifl1b.eq.-Ifl2b) goto 200 + enddo + print *,'gamma_h: simulation of reggeon impossible:',ip1,ip2 + goto 100 + + 200 continue + + np = 0 + Istring = 1 + + ee = Ecm/2.D0 + 250 continue + pt = ptu*sqrt(-log(max(1.D-10,RNDM(0)))) + if(pt.ge.ee) goto 250 + phi = 6.2831853D0*RNDM(0) + px = pt*COS(phi) + py = pt*SIN(phi) + + pz = SQRT(ee**2-px**2-py**2) + call lund_put(1,Ifl1a,px,py,pz,ee) + px = -px + py = -py + pz = -pz + call lund_put(2,Ifl2a,px,py,pz,ee) + Ijoin(1) = 1 + Ijoin(2) = 2 + call lujoin(2,Ijoin) + + call lund_frag(Ecm,NP) + if(NP.lt.0) then + if(Ideb.ge.5) + & print *,' gamma_h: rejection (1) by lund_frag, sqs:',Ecm + NP = 0 + goto 100 + endif + + do i=1,NP + call lund_get(i,LLIST(i), + & P(i,1),P(i,2),P(i,3),P(i,4),P(i,5)) + enddo + + +C simulate pomeron (two-string topology) + + else + + call valences(IP1,Ifl1a,Ifl1b) + call valences(IP2,Ifl2a,Ifl2b) + if(Ifl1a*Ifl2a.lt.0) then + j = Ifl2a + Ifl2a = Ifl2b + Ifl2b = j + endif + + pl1 = (1.D0+as1-as2) + ps1 = 0.25D0*pl1**2-as1 + if(ps1.le.0.D0) then + if(Ideb.ge.5) print *,' rejection by x-limits (1) ',Ecm + prob_reg = 1.D0 + goto 100 + endif + ps1 = sqrt(ps1) + xmi(1) = 0.5D0*pl1-ps1 + xma(1) = 0.5D0*pl1+ps1 + + pl2 = (1.D0+as2-as1) + ps2 = 0.25D0*pl2**2-as2 + if(ps2.le.0.D0) then + if(Ideb.ge.5) print *,' rejection by x-limits (2) ',Ecm + prob_reg = 1.D0 + goto 100 + endif + ps2 = sqrt(ps2) + xmi(2) = 0.5D0*pl2-ps2 + xma(2) = 0.5D0*pl2+ps2 + + if((xmi(1).ge.xma(1)+0.05D0).or. + & (xmi(2).ge.xma(2)+0.05D0)) then + if(Ideb.ge.5) print *,' rejection by x-limits (3) ',Ecm + prob_reg = 1.D0 + goto 100 + endif + call PO_SELSX2(xs1,xs2,xmi,xma,as1,as2,Irej) + if(Irej.ne.0) then + if(Ideb.ge.5) print *, + & 'gamma_h: rejection by PO_SELSX2, sqs,m1,m2:',Ecm,s1,s2 + prob_reg = 1.D0 + goto 100 + endif + + NP = 0 + Istring = 1 + + ee = SQRT(XS1(1)*XS2(1))*Ecm/2.D0 + 260 continue + pt = ptu*sqrt(-log(max(1.D-10,RNDM(0)))) + if(pt.ge.ee) goto 260 + phi = 6.2831853D0*RNDM(0) + px = pt*COS(phi) + py = pt*SIN(phi) + + PA1(1) = px + PA1(2) = py + PA1(3) = XS1(1)*Ecm/2.D0 + PA1(4) = PA1(3) + + PA2(1) = -px + PA2(2) = -py + PA2(3) = -XS2(1)*Ecm/2.D0 + PA2(4) = -PA2(3) + + XM1 = 0.D0 + XM2 = 0.D0 + call PO_MSHELL(PA1,PA2,XM1,XM2,P1,P2) + px = P1(1) + py = P1(2) + pz = P1(3) + ee = P1(4) + call lund_put(1,Ifl1a,px,py,pz,ee) + px = P2(1) + py = P2(2) + pz = P2(3) + ee = P2(4) + call lund_put(2,Ifl2a,px,py,pz,ee) + + Ijoin(1) = 1 + Ijoin(2) = 2 + call lujoin(2,Ijoin) + + ee = SQRT(XS1(2)*XS2(2))*Ecm/2.D0 + 270 continue + pt = ptu*sqrt(-log(max(1.D-10,RNDM(0)))) + if(pt.ge.ee) goto 270 + phi = 6.2831853D0*RNDM(0) + px = pt*COS(phi) + py = pt*SIN(phi) + + PA1(1) = px + PA1(2) = py + PA1(3) = XS1(2)*Ecm/2.D0 + PA1(4) = PA1(3) + + PA2(1) = -px + PA2(2) = -py + PA2(3) = -XS2(2)*Ecm/2.D0 + PA2(4) = -PA2(3) + + XM1 = 0.D0 + XM2 = 0.D0 + call PO_MSHELL(PA1,PA2,XM1,XM2,P1,P2) + + px = P1(1) + py = P1(2) + pz = P1(3) + ee = P1(4) + call lund_put(3,Ifl1b,px,py,pz,ee) + px = P2(1) + py = P2(2) + pz = P2(3) + ee = P2(4) + call lund_put(4,Ifl2b,px,py,pz,ee) + + Ijoin(1) = 3 + Ijoin(2) = 4 + call lujoin(2,Ijoin) + + call lund_frag(Ecm,NP) + if(NP.lt.0) then + if(Ideb.ge.5) + & print *,' gamma_h: rejection (2) by lund_frag, sqs:',Ecm + NP = 0 + prob_reg = prob_reg+0.1D0 + goto 100 + endif + + do i=1,NP + call lund_get(i,LLIST(i), + & P(i,1),P(i,2),P(i,3),P(i,4),P(i,5)) + enddo + + endif + + if(Ideb.ge.10) then + print *,' multi-pion event',Istring,NP + call print_event(1) + endif + +C... for fragmentation in resonance region: + if (Imode.eq.5) goto 400 + +C leading baryon/meson effect + + do j=1,np + if(((LLIST(J).eq.13).or.(LLIST(J).eq.14)) + & .and.(p(j,3).lt.0.D0)) then + if(rndm(0).lt.(2.D0*p(j,4)/Ecm)**2) goto 100 + endif + if((LLIST(J).ge.6).and.(LLIST(J).le.8) + & .and.(p(j,3).lt.-0.4D0)) then + if(rndm(0).lt.(2.D0*p(j,4)/Ecm)**2) goto 100 + endif + enddo + +C remove elastic/diffractive channels + + ima_0 = 0 + imb_0 = 0 + ima_1 = 0 + imb_1 = 0 + ima_2 = 0 + imb_2 = 0 + imul = 0 + + if(ip1.eq.1) then + iba_0 = 6 + iba_1 = 27 + iba_2 = 32 + else + iba_0 = ip1 + iba_1 = ip1 + iba_2 = ip1 + endif + if(ip2.eq.1) then + ibb_0 = 6 + ibb_1 = 27 + ibb_2 = 32 + else + ibb_0 = ip2 + ibb_1 = ip2 + ibb_2 = ip2 + endif + + do j=1,np + l1 = abs(LLIST(J)) + if(l1.lt.10000) then + if(LLIST(J).eq.iba_0) ima_0 = 1 + if(LLIST(J).eq.iba_1) ima_1 = 1 + if(LLIST(J).eq.iba_2) ima_2 = 1 + if(LLIST(J).eq.ibb_0) imb_0 = 1 + if(LLIST(J).eq.ibb_1) imb_1 = 1 + if(LLIST(J).eq.ibb_2) imb_2 = 1 + imul = imul+1 + endif + enddo + + if(imul.eq.2) then + if(ima_0*imb_0.eq.1) goto 100 + if(ima_1*imb_1.eq.1) goto 100 + if(ima_2*imb_2.eq.1) goto 100 + endif + +C remove direct channels + + if((imul.eq.2).and. + & (ip2.eq.1).and.((ip1.eq.13).or.(ip1.eq.14))) then + + ima_0 = 0 + imb_0 = 0 + ima_1 = 0 + imb_1 = 0 + ima_2 = 0 + imb_2 = 0 + ima_3 = 0 + imb_3 = 0 + + if(ip1.eq.13) then + iba_0 = 14 + ibb_0 = 7 + iba_1 = 40 + ibb_1 = 8 + iba_2 = 42 + ibb_2 = 7 + iba_3 = 13 + ibb_3 = 23 + else + iba_0 = 13 + ibb_0 = 8 + iba_1 = 43 + ibb_1 = 7 + iba_2 = 41 + ibb_2 = 8 + iba_3 = 14 + ibb_3 = 23 + endif + + do j=1,np + l1 = abs(LLIST(J)) + if(l1.lt.10000) then + if(LLIST(J).eq.iba_0) ima_0 = 1 + if(LLIST(J).eq.iba_1) ima_1 = 1 + if(LLIST(J).eq.iba_2) ima_2 = 1 + if(LLIST(J).eq.iba_3) ima_3 = 1 + if(LLIST(J).eq.ibb_0) imb_0 = 1 + if(LLIST(J).eq.ibb_1) imb_1 = 1 + if(LLIST(J).eq.ibb_2) imb_2 = 1 + if(LLIST(J).eq.ibb_3) imb_3 = 1 + endif + enddo + + if(ima_0*imb_0.eq.1) goto 100 + if(ima_1*imb_1.eq.1) goto 100 + if(ima_2*imb_2.eq.1) goto 100 + if(ima_3*imb_3.eq.1) goto 100 + + endif + +C suppress events with many pi0's + + ima_0 = 0 + imb_0 = 0 + do j=1,np +C neutral mesons + if(LLIST(J).eq.6) ima_0 = ima_0+1 + if(LLIST(J).eq.11) ima_0 = ima_0+1 + if(LLIST(J).eq.12) ima_0 = ima_0+1 + if(LLIST(J).eq.21) ima_0 = ima_0+1 + if(LLIST(J).eq.22) ima_0 = ima_0+1 + if(LLIST(J).eq.23) ima_0 = ima_0+1 + if(LLIST(J).eq.24) ima_0 = ima_0+1 + if(LLIST(J).eq.27) ima_0 = ima_0+1 + if(LLIST(J).eq.32) ima_0 = ima_0+1 + if(LLIST(J).eq.33) ima_0 = ima_0+1 +C charged mesons + if(LLIST(J).eq.7) imb_0 = imb_0+1 + if(LLIST(J).eq.8) imb_0 = imb_0+1 + if(LLIST(J).eq.9) imb_0 = imb_0+1 + if(LLIST(J).eq.10) imb_0 = imb_0+1 + if(LLIST(J).eq.25) imb_0 = imb_0+1 + if(LLIST(J).eq.26) imb_0 = imb_0+1 + enddo + + prob_1 = a1*DBLE(imb_0)/max(DBLE(ima_0+imb_0),1.D0)+a2 + + if(RNDM(0).GT.prob_1) goto 100 + + +C correct multiplicity at very low energies + + ND = 0 + + E_ref_1 = 1.6D0 + E_ref_2 = 1.95D0 + + if((imul.eq.3) + & .and.(Ecm.gt.E_ref_1).and.(Ecm.lt.E_ref_2)) then + + ima_0 = 0 + ima_1 = 0 + ima_2 = 0 + imb_0 = 0 + imb_1 = 0 + iba_0 = 0 + iba_1 = 0 + iba_2 = 0 + ibb_0 = 0 + ibb_1 = 0 +C incoming proton + if(ip1.eq.13) then + iba_0 = 13 + iba_1 = 7 + iba_2 = 8 + ibb_0 = 14 + ibb_1 = 6 +C incoming neutron + else if(ip1.eq.14) then + iba_0 = 14 + iba_1 = 7 + iba_2 = 8 + ibb_0 = 13 + ibb_1 = 6 + endif + do j=1,np + if(LLIST(J).eq.iba_0) ima_0 = ima_0+1 + if(LLIST(J).eq.iba_1) ima_1 = ima_1+1 + if(LLIST(J).eq.iba_2) ima_2 = ima_2+1 + if(LLIST(J).eq.ibb_0) imb_0 = imb_0+1 + if(LLIST(J).eq.ibb_1) imb_1 = imb_1+1 + enddo + +C N gamma --> N pi+ pi- + if(ima_0*ima_1*ima_2.eq.1) then + Elog = LOG(Ecm) + Elog_1 = LOG(E_ref_1) + Elog_2 = LOG(E_ref_2) + prob = 0.1D0*4.D0/(Elog_2-Elog_1)**2 + & *(Elog-Elog_1)*(Elog_2-Elog) + + if(RNDM(0).lt.prob) then + LL(1) = ip1 + LL(2) = 7 + LL(3) = 8 + LL(4) = 6 + ND = 4 + endif + + endif + + endif + + + E_ref_1 = 1.95D0 + E_ref_2 = 2.55D0 + + if((imul.eq.4) + & .and.(Ecm.gt.E_ref_1).and.(Ecm.lt.E_ref_2)) then + + ima_0 = 0 + ima_1 = 0 + ima_2 = 0 + imb_0 = 0 + imb_1 = 0 + iba_0 = 0 + iba_1 = 0 + iba_2 = 0 + ibb_0 = 0 + ibb_1 = 0 +C incoming proton + if(ip1.eq.13) then + iba_0 = 13 + iba_1 = 7 + iba_2 = 8 + ibb_0 = 14 + ibb_1 = 6 +C incoming neutron + else if(ip1.eq.14) then + iba_0 = 14 + iba_1 = 7 + iba_2 = 8 + ibb_0 = 13 + ibb_1 = 6 + endif + do j=1,np + if(LLIST(J).eq.iba_0) ima_0 = ima_0+1 + if(LLIST(J).eq.iba_1) ima_1 = ima_1+1 + if(LLIST(J).eq.iba_2) ima_2 = ima_2+1 + if(LLIST(J).eq.ibb_0) imb_0 = imb_0+1 + if(LLIST(J).eq.ibb_1) imb_1 = imb_1+1 + enddo + +C N gamma --> N pi+ pi- pi0 + if(ima_0*ima_1*ima_2*imb_1.eq.1) then + Elog = LOG(Ecm) + Elog_2 = LOG(E_ref_2) + Elog_1 = LOG(E_ref_1) + prob = 0.1D0*4.D0/(Elog_2-Elog_1)**2 + & *(Elog-Elog_1)*(Elog_2-Elog) + + if(RNDM(0).lt.prob) then + if(ip1.eq.13) then + LL(1) = 14 + LL(2) = 7 + LL(3) = 7 + LL(4) = 8 + else + LL(1) = 13 + LL(2) = 7 + LL(3) = 8 + LL(4) = 8 + endif + ND = 4 + endif + + endif + + endif + + + if(ND.gt.0) then + P_in(1) = 0.D0 + P_in(2) = 0.D0 + P_in(3) = 0.D0 + P_in(4) = Ecm + P_in(5) = Ecm + call DECPAR(0,P_in,ND,LL,P_dec) + Iflip = 0 + do j=1,ND + LLIST(j) = LL(j) + do k=1,5 + P(j,k) = P_dec(j,k) + enddo + if(((LLIST(j).eq.13).or.(LLIST(j).eq.14)) + & .and.(P(j,3).lt.0.D0)) Iflip = 1 + enddo + if(Iflip.ne.0) then + do j=1,ND + P(j,3) = -P(j,3) + enddo + endif + NP = ND + endif + +C... for fragmentation in resonance region: + 400 continue + + call DECSIB + + ENDIF + + if(Ideb.ge.10) then + if(Ideb.ge.20) then + call print_event(2) + else + call print_event(1) + endif + endif + + IQchr = ICHP(ip1)+ICHP(ip2) + IQbar = IBAR(ip1)+IBAR(ip2) + call check_event(-Ic,Ecm,0.D0,0.D0,0.D0,IQchr,IQbar,Irej) + + end + + + SUBROUTINE print_event(Iout) +C********************************************************************* +C +C print final state particles +C +C (R.E. 03/98) +C +C********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON /S_RUN/ SQS, S, Q2MIN, XMIN, ZMIN, kb, kt, a1, a2, Nproc + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + COMMON /S_CSYDEC/ CBR(102), IDB(49), KDEC(612), LBARP(49) + COMMON /S_CHP/ S_LIFE(49), ICHP(49), ISTR(49), IBAR(49) + COMMON /S_MASS1/ AM(49), AM2(49) + COMMON /S_CNAM/ NAMP (0:49) + CHARACTER*6 NAMP + CHARACTER CODE*18 + SAVE + + if(iout.gt.0) then + + print *,' --------------------------------------------------' + + if(Nproc.eq.1) then + print *,' diffractive rho-0 production',Nproc + else if(Nproc.eq.2) then + print *,' direct interaction 1',Nproc + else if(Nproc.eq.3) then + print *,' direct interaction 2',Nproc + else if(Nproc.eq.4) then + print *,' diffractive omega production',Nproc + else if(Nproc.eq.0) then + print *,' multi-pion/fragmentation contribution',Nproc + else if((Nproc.gt.10).and.(Nproc.lt.20)) then + print *,' resonance production and decay',Nproc-10 + else + print *,' unknown process',Nproc + endif + + i0 = 0 + px = 0.D0 + py = 0.D0 + pz = 0.D0 + ee = 0.D0 + ichar = 0 + ibary = 0 + do j=1,np + l1 = abs(LLIST(J)) + l = mod(llist(j),10000) + if(l1.lt.10000) then + px = px + P(j,1) + py = py + P(j,2) + pz = pz + P(j,3) + ee = ee + P(j,4) + ichar = ichar+sign(1,l)*ICHP(iabs(l)) + ibary = ibary+sign(1,l)*IBAR(iabs(l)) + endif + if((l1.lt.10000).or.(Iout.GE.2)) then + i0 = i0+1 + code = ' ' + code(1:6) = namp(iabs(l)) + if (l .lt. 0) code(7:9) = 'bar' + write (6,120) i0,CODE,l1*sign(1,l),sign(1,l)*ICHP(iabs(l)), + & (P(j,k),k=1,4) + endif + enddo + write (6,122) ' sum: ',px,py,pz,ee + print *,' charge QN: ',ichar,' baryon QN: ',ibary + print *,' --------------------------------------------------' +120 FORMAT(1X,I4,1X,A18,1X,I6,1X,I2,1X,2(F9.3,2X),2(E9.3,2X)) +122 FORMAT(7X,A8,20X,2(F9.3,2X),2(E9.3,2X)) + + endif + + END + + + SUBROUTINE check_event(Ic,Esum,PXsum,PYsum,PZsum,IQchr,IQbar,Irej) +C*********************************************************************** +C +C check energy-momentum and quantum number conservation +C +C (R.E. 08/98) +C +C*********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON /S_RUN/ SQS, S, Q2MIN, XMIN, ZMIN, kb, kt, a1, a2, Nproc + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + COMMON /S_CSYDEC/ CBR(102), IDB(49), KDEC(612), LBARP(49) + COMMON /S_CHP/ S_LIFE(49), ICHP(49), ISTR(49), IBAR(49) + COMMON /S_MASS1/ AM(49), AM2(49) + COMMON /S_CNAM/ NAMP (0:49) + CHARACTER*6 NAMP + SAVE + + px = 0.D0 + py = 0.D0 + pz = 0.D0 + ee = 0.D0 + ichar = 0 + ibary = 0 + Iprint = 0 + + PLscale = Esum + PTscale = 1.D0 + + do j=1,np + l1 = abs(LLIST(J)) + l = mod(llist(j),10000) + if(l1.lt.10000) then + px = px + P(j,1) + py = py + P(j,2) + pz = pz + P(j,3) + ee = ee + P(j,4) + ichar = ichar+sign(1,l)*ICHP(iabs(l)) + ibary = ibary+sign(1,l)*IBAR(iabs(l)) + endif + enddo + + if(ichar.ne.IQchr) then + print *,' charge conservation violated',Ic + Iprint = 1 + endif + if(ibary.ne.IQbar) then + print *,' baryon number conservation violated',Ic + Iprint = 1 + endif + if(abs((px-PXsum)/MAX(PXsum,PTscale)).gt.1.D-3) then + print *,' x momentum conservation violated',Ic + Iprint = 1 + endif + if(abs((py-PYsum)/MAX(PYsum,PTscale)).gt.1.D-3) then + print *,' y momentum conservation violated',Ic + Iprint = 1 + endif + if(abs((pz-Pzsum)/MAX(ABS(PZsum),PLscale)).gt.1.D-3) then + print *,' z momentum conservation violated',Ic + Iprint = 1 + endif + if(abs((ee-Esum)/MAX(Esum,1.D0)).gt.1.D-3) then + print *,' energy conservation violated',Ic + Iprint = 1 + endif + + if(Iprint.ne.0) call print_event(1) + + Irej = Iprint + + END + + + SUBROUTINE valences(ip,ival1,ival2) +C********************************************************************** +C +C valence quark composition of various particles (R.E. 03/98) +C (with special treatment of photons) +C +C********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + if(ip.eq.1) then + if(rndm(0).gt.0.2D0) then + ival1 = 1 + ival2 = -1 + else + ival1 = 2 + ival2 = -2 + endif + else if(ip.eq.6) then + if(rndm(0).gt.0.5D0) then + ival1 = 1 + ival2 = -1 + else + ival1 = 2 + ival2 = -2 + endif + else if(ip.eq.7) then + ival1 = 1 + ival2 = -2 + else if(ip.eq.8) then + ival1 = 2 + ival2 = -1 + else if(ip.eq.13) then + Xi = rndm(0) + if(Xi.lt.0.3333D0) then + ival1 = 12 + ival2 = 1 + else if(Xi.lt.0.6666D0) then + ival1 = 21 + ival2 = 1 + else + ival1 = 11 + ival2 = 2 + endif + else if(ip.eq.14) then + Xi = rndm(0) + if(Xi.lt.0.3333D0) then + ival1 = 12 + ival2 = 2 + else if(Xi.lt.0.6666D0) then + ival1 = 21 + ival2 = 2 + else + ival1 = 22 + ival2 = 1 + endif + endif + + if((ip.lt.13).and.(rndm(0).lt.0.5D0)) then + k = ival1 + ival1 = ival2 + ival2 = k + endif + + END + + + SUBROUTINE DECSIB +C*********************************************************************** +C +C Decay all unstable particle in SIBYLL +C decayed particle have the code increased by 10000 +C +C (taken from SIBYLL 1.7, R.E. 04/98) +C +C*********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON /S_CSYDEC/ CBR(102), IDB(49), KDEC(612), LBARP(49) + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + COMMON /S_PLIST1/ LLIST1(2000) + SAVE + + DIMENSION P0(5), LL(10), PD(10,5) + + NN = 1 + DO J=1,NP + LLIST1(J) = 0 + ENDDO + DO WHILE (NN .LE. NP) + L= LLIST(NN) + IF (IDB(IABS(L)) .GT. 0) THEN + DO K=1,5 + P0(K) = P(NN,K) + ENDDO + ND = 0 + CALL DECPAR (L,P0,ND,LL,PD) + LLIST(NN) = LLIST(NN)+ISIGN(10000,LLIST(NN)) + DO J=1,ND + DO K=1,5 + P(NP+J,K) = PD(J,K) + ENDDO + LLIST(NP+J)=LL(J) + LLIST1(NP+J)=NN + ENDDO + NP=NP+ND + ENDIF + NN = NN+1 + ENDDO + + END + + + SUBROUTINE DECPAR(LA,P0,ND,LL,P) +C*********************************************************************** +C +C This subroutine generates the decay of a particle +C with ID = LA, and 5-momentum P0(1:5) +C into ND particles of 5-momenta P(j,1:5) (j=1:ND) +C +C If the initial particle code is LA=0 +C then ND and LL(1:ND) are considered as input and +C the routine generates a phase space decay into ND +C particles of codes LL(1:nd) +C +C (taken from SIBYLL 1.7, muon decay corrected, R.E. 04/98) +C +C*********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON /S_CSYDEC/ CBR(102), IDB(49), KDEC(612), LBARP(49) + COMMON /S_MASS1/ AM(49), AM2(49) + SAVE + + DIMENSION P0(5), LL(10), P(10,5) + DIMENSION PV(10,5), RORD(10), UE(3),BE(3), FACN(3:10) + + DATA FACN /2.D0,5.D0,15.D0,60.D0,250.D0, + + 1500.D0,12000.D0,120000.D0/ + DATA PI /3.1415926D0/ + +C...c.m.s. Momentum in two particle decays + PAWT(A,B,C) = SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.D0*A) + +C...Phase space decay into the particles in the list + IF (LA .EQ. 0) THEN + MAT = 0 + MBST = 0 + PS = 0. + DO J=1,ND + P (J,5) = AM(IABS(LL(J))) + PV(J,5) = AM(IABS(LL(J))) + PS = PS+P(J,5) + ENDDO + DO J=1,4 + PV(1,J) = P0(J) + ENDDO + PV(1,5) = P0(5) + GOTO 140 + ENDIF + +C...Choose decay channel + L = IABS(LA) + ND=0 + IDC = IDB(L)-1 + IF (IDC+1 .LE.0) RETURN + RBR = RNDM(0) +110 IDC=IDC+1 + IF(RBR.GT.CBR(IDC)) GOTO 110 + + KD =6*(IDC-1)+1 + ND = KDEC(KD) + MAT= KDEC(KD+1) + + MBST=0 + IF (MAT .GT.0 .AND. P0(4) .GT. 20.D0*P0(5)) MBST=1 + IF (MAT .GT.0 .AND. MBST .EQ. 0) + + BETA = SQRT(P0(1)**2+P0(2)**2+P0(3)**2)/P0(4) + + PS = 0.D0 + DO J=1,ND + LL(J) = KDEC(KD+1+J) + P(J,5) = AM(LL(J)) + PV(J,5) = AM(LL(J)) + PS = PS + P(J,5) + ENDDO + DO J=1,4 + PV(1,J) = 0.D0 + IF (MBST .EQ. 0) PV(1,J) = P0(J) + ENDDO + IF (MBST .EQ. 1) PV(1,4) = P0(5) + PV(1,5) = P0(5) + +140 IF (ND .EQ. 2) GOTO 280 + + IF (ND .EQ. 1) THEN + DO J=1,4 + P(1,J) = P0(J) + ENDDO + RETURN + ENDIF + +C...Calculate maximum weight for ND-particle decay + WWTMAX = 1.D0/FACN(ND) + PMAX=PV(1,5)-PS+P(ND,5) + PMIN=0.D0 + DO IL=ND-1,1,-1 + PMAX = PMAX+P(IL,5) + PMIN = PMIN+P(IL+1,5) + WWTMAX = WWTMAX*PAWT(PMAX,PMIN,P(IL,5)) + ENDDO + +C...generation of the masses, compute weight, if rejected try again +240 RORD(1) = 1.D0 + DO 260 IL1=2,ND-1 + RSAV = RNDM(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.D0 + WT = 1.D0 + DO 270 IL=ND-1,1,-1 + PV(IL,5)=PV(IL+1,5)+P(IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS) +270 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(IL,5)) + IF (WT.LT.RNDM(0)*WWTMAX) 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(IL,5)) + UE(3)=2.D0*RNDM(0)-1.D0 + PHI=2.D0*PI*RNDM(0) + UT = SQRT(1.D0-UE(3)**2) + UE(1) = UT*COS(PHI) + UE(2) = UT*SIN(PHI) + DO 290 J=1,3 + P(IL,J)=PA*UE(J) +290 PV(IL+1,J)=-PA*UE(J) + P(IL,4)=SQRT(PA**2+P(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(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=IL,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) + +C...Weak decays + IF (MAT .EQ. 1) THEN + F1=P(2,4)*P(3,4)-P(2,1)*P(3,1)-P(2,2)*P(3,2)-P(2,3)*P(3,3) + IF (MBST.EQ.1) WT = P0(5)*P(1,4)*F1 + IF (MBST.EQ.0) + + WT=F1*(P(1,4)*P0(4)-P(1,1)*P0(1)-P(1,2)*P0(2)-P(1,3)*P0(3)) + WTMAX = P0(5)**4/16.D0 + IF(WT.LT.RNDM(0)*WTMAX) GOTO 240 + ENDIF + + +C...Boost back for rapidly moving particle + IF (MBST .EQ. 1) THEN + DO 440 J=1,3 +440 BE(J)=P0(J)/P0(4) + GA= P0(4)/P0(5) + DO 460 I=1,ND + 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 + +C...labels for antiparticle decay + IF (LA .LT. 0 .AND. L .GT. 18) THEN + DO J=1,ND + LL(J) = LBARP(LL(J)) + ENDDO + ENDIF + + END + + + SUBROUTINE PO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E) +C********************************************************************* +C +C arbitrary Lorentz transformation +C +C (taken from PHOJET v1.12, R.E. 08/98) +C +C********************************************************************* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + + EP=PCX*BGX+PCY*BGY+PCZ*BGZ + PE=EP/(GA+1.D0)+EC + PX=PCX+BGX*PE + PY=PCY+BGY*PE + PZ=PCZ+BGZ*PE + P=SQRT(PX*PX+PY*PY+PZ*PZ) + E=GA*EC+EP + + END + + + SUBROUTINE PO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z) +C********************************************************************** +C +C rotation of coordinate frame (1) de rotation around y axis +C (2) fe rotation around z axis +C +C (taken from PHOJET v1.12, R.E. 08/98) +C +C********************************************************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + + X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO + Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO + Z=-SDE *XO +CDE *ZO + + END + + + SUBROUTINE PO_SELSX2(XS1,XS2,XMIN,XMAX,AS1,AS2,IREJ) +C*********************************************************************** +C +C select x values of soft string ends using PO_RNDBET +C +C (taken from PHOJET v1.12, R.E. 08/98) +C +C*********************************************************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + DIMENSION XS1(2),XS2(2) + DIMENSION XMIN(2),XMAX(2) + + IREJ = 0 + + GAM1 = +1.5D0 + 1.D0 + GAM2 = -0.5D0 + 1.D0 + BET1 = -0.5D0 + 1.D0 + BET2 = -0.5D0 + 1.D0 + + ITRY0 = 0 + DO 100 I=1,100 + + ITRY1 = 0 + 10 CONTINUE + X1 = PO_RNDBET(GAM1,BET1) + ITRY1 = ITRY1+1 + IF(ITRY1.GE.50) THEN + IREJ = 1 + RETURN + ENDIF + IF((X1.LE.XMIN(1)).OR.(X1.GE.XMAX(1))) GOTO 10 + + ITRY2 = 0 + 11 CONTINUE + X2 = PO_RNDBET(GAM2,BET2) + ITRY2 = ITRY2+1 + IF(ITRY2.GE.50) THEN + IREJ = 2 + RETURN + ENDIF + IF((X2.LE.XMIN(2)).OR.(X2.GE.XMAX(2))) GOTO 11 + + X3 = 1.D0 - X1 + X4 = 1.D0 - X2 + IF(X1*X2.GT.AS1) THEN + IF(X3*X4.GT.AS2) GOTO 300 + ENDIF + ITRY0 = ITRY0+1 + + 100 CONTINUE + + IREJ = 3 + RETURN + + 300 CONTINUE + + XS1(1) = X1 + XS1(2) = X3 + + XS2(1) = X2 + XS2(2) = X4 + + END + + + DOUBLE PRECISION FUNCTION PO_RNDBET(GAM,ETA) +C******************************************************************** +C +C random number generation from beta +C distribution in region 0 < X < 1. +C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM +C *GAMM(ETA)) +C +C (taken from PHOJET v1.12, R.E. 08/98) +C +C******************************************************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + Y = PO_RNDGAM(1.D0,GAM) + Z = PO_RNDGAM(1.D0,ETA) + PO_RNDBET = Y/(Y+Z) + + END + + + DOUBLE PRECISION FUNCTION PO_RNDGAM(ALAM,ETA) +C******************************************************************** +C +C random number selection from gamma distribution +C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) +C +C (taken from PHOJET v1.12, R.E. 08/98) +C +C******************************************************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + NCOU=0 + N = ETA + F = ETA - N + IF(F.EQ.0.D0) GOTO 20 + 10 R = RNDM(0) + NCOU=NCOU+1 + IF (NCOU.GE.11) GOTO 20 + IF(R.LT.F/(F+2.71828D0)) GOTO 30 + YYY=LOG(RNDM(0)+1.e-7)/F + IF(ABS(YYY).GT.50.D0) GOTO 20 + Y = EXP(YYY) + IF(LOG(RNDM(0)+1.D-7).GT.-Y) GOTO 10 + GOTO 40 + 20 Y = 0.D0 + GOTO 50 + 30 Y = 1.D0-LOG(RNDM(0)+1.D-7) + IF(RNDM(0).GT.Y**(F-1.D0)) GOTO 10 + 40 IF(N.EQ.0) GOTO 70 + 50 Z = 1.D0 + DO 60 I = 1,N + 60 Z = Z*RNDM(0) + Y = Y-LOG(Z+1.D-7) + 70 PO_RNDGAM = Y/ALAM + + END + + + SUBROUTINE lund_frag(SQS,NP) +C*********************************************************************** +C +C interface to Lund/Jetset fragmentation +C +C (R.E. 08/98) +C +C*********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE + + DATA init / 0 / + + + if(init.eq.0) then + +C no title page + + MSTU(12) = 0 + +C define some particles as stable + + MSTJ(22) = 2 + +C in addition pi0 stable + + KC=LUCOMP(111) + MDCY(KC,1)=0 + +C switch popcorn effect off + + MSTJ(12) = 1 + +C suppress all warning and error messages + + MSTU(22) = 0 + MSTU(25) = 0 + + init = 1 + + endif + + +C set energy dependent parameters + + IF(SQS.LT.2.D0) THEN + PARJ(36) = 0.1D0 + ELSE IF(SQS.LT.4.D0) THEN + PARJ(36) = 0.7D0*(SQS-2.D0)/2.D0+0.1D0 + ELSE + PARJ(36) = 0.8D0 + ENDIF + +C fragment string configuration + + II = MSTU(21) + MSTU(21) = 1 + CALL LUEXEC + MSTU(21) = II + +C event accepted? + + if(MSTU(24).ne.0) then + NP = -1 + return + endif + + CALL LUEDIT(1) + + NP = KLU(0,1) + + END + + + SUBROUTINE lund_put(I,IFL,PX,PY,PZ,EE) +C*********************************************************************** +C +C store initial configuration into Lund common block +C +C (R.E. 08/98) +C +C*********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE + + if(IFL.eq.1) then + Il = 2 + else if(IFL.eq.-1) then + Il = -2 + else if(IFL.eq.2) then + Il = 1 + else if(IFL.eq.-2) then + Il = -1 + else if(IFL.eq.11) then + Il = 2203 + else if(IFL.eq.12) then + Il = 2101 + else if(IFL.eq.21) then + Il = 2103 + else if(IFL.eq.22) then + Il = 1103 + else + print *,' lund_put: unkown flavor code',IFL + endif + + P(I,1) = PX + P(I,2) = PY + P(I,3) = PZ + P(I,4) = EE + P(I,5) = (EE-PZ)*(EE+PZ)-PX**2-PY**2 + + K(I,1) = 1 + K(I,2) = Il + K(I,3) = 0 + K(I,4) = 0 + K(I,5) = 0 + + N = I + + END + + + SUBROUTINE lund_get(I,IFL,PX,PY,PZ,EE,XM) +C*********************************************************************** +C +C read final states from Lund common block +C +C (R.E. 08/98) +C +C*********************************************************************** + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE + + PX = PLU(I,1) + PY = PLU(I,2) + PZ = PLU(I,3) + EE = PLU(I,4) + XM = PLU(I,5) + + Il = KLU(I,8) + +C convert particle ID + + IFL = ICON_PDG_SIB(Il) + + END + + + + INTEGER FUNCTION ICON_PDG_SIB(ID) +C************************************************************************ +C +C convert PDG particle codes to SIBYLL particle codes +C +C (R.E. 09/97) +C +C************************************************************************ + SAVE + + DIMENSION ITABLE(49) + DATA ITABLE / + & 22, -11, 11, -13, 13, 111, 211, -211, 321, -321, 130, 310, 2212, + & 2112, 12, -12, 14, -14, -99999999, -99999999, 311, -311, 221, + & 331, 213, -213, 113, 323, -323, 313, -313, 223, 333, 3222, 3212, + & 3112, 3322, 3312, 3122, 2224, 2214, 2114, 1114, 3224, 3214, + & 3114, 3324, 3314, 3334 / + + IDPDG = ID + + 100 CONTINUE + IDA = ABS(ID) + + IF(IDA.GT.1000) THEN + IS = IDA + IC = SIGN(1,IDPDG) + ELSE + IS = IDPDG + IC = 1 + ENDIF + + DO I=1,49 + IF(IS.EQ.ITABLE(I)) THEN + ICON_PDG_SIB = I*IC + RETURN + ENDIF + ENDDO + + IF(IDPDG.EQ.80000) THEN + ICON_PDG_SIB = 13 + ELSE + print *,'ICON_PDG_DTU: no particle found for ',IDPDG + ICON_PDG_SIB = 0 + RETURN + ENDIF + + END + + + + SUBROUTINE PO_MSHELL(PA1,PA2,XM1,XM2,P1,P2) +C******************************************************************** +C +C rescaling of momenta of two partons to put both +C on mass shell +C +C input: PA1,PA2 input momentum vectors +C XM1,2 desired masses of particles afterwards +C P1,P2 changed momentum vectors +C +C (taken from PHOJET 1.12, R.E. 08/98) +C +C******************************************************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + + PARAMETER ( DEPS = 1.D-5 ) + + DIMENSION PA1(4),PA2(4),P1(4),P2(4) + +C Lorentz transformation into system CMS + PX = PA1(1)+PA2(1) + PY = PA1(2)+PA2(2) + PZ = PA1(3)+PA2(3) + EE = PA1(4)+PA2(4) + XMS = EE**2-PX**2-PY**2-PZ**2 + XMS = SQRT(XMS) + BGX = PX/XMS + BGY = PY/XMS + BGZ = PZ/XMS + GAM = EE/XMS + CALL PO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3), + & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4)) +C rotation angles + PTOT1 = MAX(DEPS,PTOT1) + COD= P1(3)/PTOT1 + SID= SQRT((1.D0-COD)*(1.D0+COD)) + COF=1.D0 + SIF=0.D0 + IF(PTOT1*SID.GT.1.D-5) THEN + COF=P1(1)/(SID*PTOT1) + SIF=P1(2)/(SID*PTOT1) + ANORF=SQRT(COF*COF+SIF*SIF) + COF=COF/ANORF + SIF=SIF/ANORF + ENDIF + +C new CM momentum and energies (for masses XM1,XM2) + XM12 = XM1**2 + XM22 = XM2**2 + SS = XMS**2 + PCMP = PO_XLAM(SS,XM12,XM22)/(2.D0*XMS) + EE1 = SQRT(XM12+PCMP**2) + EE2 = XMS-EE1 +C back rotation + CALL PO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ) + CALL PO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1, + & PTOT1,P1(1),P1(2),P1(3),P1(4)) + CALL PO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2, + & PTOT2,P2(1),P2(2),P2(3),P2(4)) + + END + + + DOUBLE PRECISION FUNCTION PO_XLAM(X,Y,Z) +C********************************************************************** +C +C auxiliary function for two/three particle decay mode +C (standard LAMBDA**(1/2) function) +C +C (taken from PHOJET 1.12, R.E. 08/98) +C +C********************************************************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + + YZ=Y-Z + XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ + IF(XLAM.LT.0.D0) XLAM=-XLAM + PO_XLAM=SQRT(XLAM) + + END + + + + SUBROUTINE INITIAL(L0) + +c******************************************************************* +c initialization routine for setting parameters of resonances +c******************************************************************* + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + COMMON /RES_PROP/ AMRES(9),SIG0(9),WIDTH(9), + + NAMPRES(0:9) + COMMON /RES_PROPp/ AMRESp(9), BGAMMAp(9),WIDTHp(9), + + RATIOJp(9),NAMPRESp(0:9) + COMMON /RES_PROPn/ AMRESn(9), BGAMMAn(9),WIDTHn(9), + + RATIOJn(9),NAMPRESn(0:9) + COMMON /S_MASS1/ AM(49), AM2(49) + CHARACTER NAMPRESp*6, NAMPRESn*6 + CHARACTER NAMPRES*6 + + if (L0.eq.13) then + do i=1,9 + SIG0(i) = 4.893089117D0/AM2(13)*RATIOJp(i)*BGAMMAp(i) + AMRES(i) = AMRESp(i) + WIDTH(i) = WIDTHp(i) + NAMPRES(i) = NAMPRESp(i) + enddo + endif + + if (L0.eq.14) then + do i=1,9 + SIG0(i) = 4.893089117D0/AM2(14)*RATIOJn(i)*BGAMMAn(i) + AMRES(i) = AMRESn(i) + WIDTH(i) = WIDTHn(i) + NAMPRES(i) = NAMPRESn(i) + enddo + endif + + RETURN + END diff --git a/src/external/SOPHIA/inpoutput.f b/src/external/SOPHIA/inpoutput.f new file mode 100644 index 0000000..17565e0 --- /dev/null +++ b/src/external/SOPHIA/inpoutput.f @@ -0,0 +1,656 @@ +c***************************************************************************** +c**!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*** +c**!! IF YOU USE THIS PROGRAM, PLEASE CITE: !!*** +c**!! A.M"ucke, Ralph Engel, J.P.Rachen, R.J.Protheroe and Todor Stanev, !!*** +c**!! 1999, astro-ph/9903478, to appear in Comp.Phys.Commun. !!*** +c**!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*** +c***************************************************************************** +c** Further SOPHIA related papers: *** +c** (1) M"ucke A., et al 1999, astro-ph/9808279, to appear in PASA. *** +c** (2) M"ucke A., et al 1999, to appear in: Proc. of the *** +c** 19th Texas Symposium on Relativistic Astrophysics, Paris, France, *** +c** Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg (CEA Saclay) *** +c** (3) M"ucke A., et al 1999, astro-ph/9905153, to appear in: Proc. of *** +c** 19th Texas Symposium on Relativistic Astrophysics, Paris, France, *** +c** Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg (CEA Saclay) *** +c** (4) M"ucke A., et al 1999, to appear in: Proc. of 26th Int.Cosmic Ray *** +c** Conf. (Salt Lake City, Utah) *** +c***************************************************************************** + + +c********************************* +c*** Routines related to output: * +c********************************* + + + subroutine LISTDISTR(E0,Dg,Dnum,Dnuma,Dnue,Dnuea,Dp,Dn,Dem, + & Dep,nbins,delx) + +c********************************************************************* +c** calculates distribution of energy of given particle to incident ** +c** proton energy; considered particles are: ** +c** photons, protons, neutrons, e-neutrinos, nu-neutrinos ** +c** Note: Dg(),Dnum(),Dnue(),Dp(),Dn(),Dem(),Dep(),Dnuea(),Dnuma() ** +c** gives # of photons per logarithmic bin width: dN/dlog(f) ** +c********************************************************************* +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + COMMON /S_PLIST/ P(2000,5), LLIST(2000), NP, Ideb + DIMENSION Dg(201),Dnum(201),Dnue(201),Dp(201),Dn(201) + DIMENSION Dem(201),Dep(201),Dnuea(201),Dnuma(201) + + do i=1,201 + Dg(i) = 0. + Dnum(i) = 0. + Dnue(i) = 0. + Dp(i) = 0. + Dn(i) = 0. + Dem(i) = 0. + Dep(i) = 0. + Dnuma(i) = 0. + Dnuea(i) = 0. + enddo + + xini = -nbins*delx +c go through LLIST: + do 10 i=1,NP + LA = abs(LLIST(i)) + EI = abs(P(i,4)) + Ep = E0/1.D10 + r = EI/Ep/1.D10 + x = log10(r) + if (LA.lt.10000) then +c** gamma ray distribution + if (LA.eq.1) then + do 20 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dg(j) = Dg(j)+1.D0 + endif + if (x.eq.0.D0) then + Dg(nbins) = Dg(nbins)+1.D0 + endif + 20 continue + endif +c** neutron distribution + if (LA.eq.14) then + do 21 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dn(j) = Dn(j)+1.D0 + endif + if (x.eq.0.D0) then + Dn(nbins) = Dn(nbins)+1.D0 + endif + 21 continue + endif +c** proton distribution + if (LA.eq.13) then + do 22 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dp(j) = Dp(j)+1.D0 + endif + if (x.eq.0.D0) then + Dp(nbins) = Dp(nbins)+1.D0 + endif + 22 continue + endif +c** neutrino distribution + if (LA.eq.17) then + do 23 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dnum(j) = Dnum(j)+1.D0 + endif + if (x.eq.0.D0) then + Dnum(nbins) = Dnum(nbins)+1.D0 + endif + 23 continue + endif + + if (LA.eq.18) then + do 27 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dnuma(j) = Dnuma(j)+1.D0 + endif + if (x.eq.0.D0) then + Dnuma(nbins) = Dnuma(nbins)+1.D0 + endif + 27 continue + endif + + + if (LA.eq.15) then + do 24 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dnue(j) = Dnue(j)+1.D0 + endif + if (x.eq.0.D0) then + Dnue(nbins) = Dnue(nbins)+1.D0 + endif + 24 continue + endif + + if (LA.eq.16) then + do 28 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dnuea(j) = Dnuea(j)+1.D0 + endif + if (x.eq.0.D0) then + Dnuea(nbins) = Dnuea(nbins)+1.D0 + endif + 28 continue + endif + +c** electron distribution + if (LA.eq.3) then + do 25 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dem(j) = Dem(j)+1.D0 + endif + if (x.eq.0.D0) then + Dem(nbins) = Dem(nbins)+1.D0 + endif + 25 continue + endif + +c** positron distribution + if (LA.eq.2) then + do 26 j=1,nbins + x1 = xini+delx*(j-1) + x2 = xini+delx*j + if (x.ge.x1.and.x.lt.x2) then + Dep(j) = Dep(j)+1.D0 + endif + if (x.eq.0.D0) then + Dep(nbins) = Dep(nbins)+1.D0 + endif + 26 continue + endif + + endif + 10 continue + + RETURN + + END + + subroutine output(Dg,Dnum,Dnuma,Dnue,Dnuea,Dp,Dn,Dem,Dep,nbins, + & ninc,nameinc,delx,Emin,Emax,E0_arr,epsmin,epsmax) + +c******************************************************************** +c*** OUTPUT ROUTINE for particle spectra: ******* +c*** considered particles: ******* +c*** photons, protons, neutrons, e-neutrinos, nu-neutrinos, ******* +c*** electron, positron ******* +c*** spectra of each particle stored in separate files ******* +c******************************************************************** +c** Date: 20/02/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-M) + SAVE + + COMMON/input/ tbb,E0,alpha1,alpha2, + & epsm1,epsm2,epsb,L0 + + DIMENSION Dg(101,201),Dnum(101,201),Dnue(101,201) + DIMENSION Dp(101,201),Dn(101,201),Dnuma(101,201),E0_arr(101) + DIMENSION Dem(101,201),Dep(101,201),Dnuea(101,201) + character*5 particle + character*7 spart,fpart + character*13 filename + character*6 nameinc + character mat*20, strnm1*2 + character mat1*20, strnm11*2 + character mat2*20, strnm12*2 + + 571 format(2(3x,E10.5),3x,I3,5(3x,E10.5), + & 3x,I3,3x,E10.5,3x,A10,3x,A10) + 572 format(E10.5,3x,2(I3,3x)) + 573 format(2x,E10.5) + + print* + print*,'OUTPUT files:' +c********************************************** +c******** GAMMA spectra: ********************** + particle = 'gamma' + filename = nameinc // '.' // particle + print*,'filename = ',filename + if (L0.eq.13) spart = 'proton' + if (L0.eq.14) spart = 'neutron' + fpart = 'photon' + if (tbb.gt.0.) then + target1 = tbb + target2 = 0. + else + target1 = alpha1 + target2 = alpha2 + endif + open(1,file=filename) +c... write input parameters: + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dg(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dg(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dg(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dg(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + +c********************************************** +c******** MU-NEUTRINO spectra: ********************** + particle = 'muneu' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dnum(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dnum(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dnum(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dnum(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + + particle = 'muane' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dnuma(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dnuma(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dnuma(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dnuma(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + +c********************************************** +c******** ELECTRON NEUTRINO spectra: ********** + particle = 'e_neu' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dnue(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dnue(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dnue(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dnue(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + + particle = 'eaneu' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dnuea(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dnuea(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dnuea(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dnuea(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + +c********************************************** +c******** ELECTRON spectra: ********************** + particle = 'elect' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dem(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dem(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dem(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dem(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + +c********************************************** +c******** POSITRON spectra: ********************** + particle = 'posit' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dep(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dep(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dep(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dep(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + +c********************************************** +c******** PROTON spectra: ********************** + particle = 'proto' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dp(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dp(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dp(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dp(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + +c********************************************** +c******** NEUTRON spectra: ********************** + particle = 'neutr' + filename = nameinc // '.' // particle + print*,'filename = ',filename + open(1,file=filename) + write(1,571) Emin,Emax,ninc,target1,target2, + & epsmin,epsb,epsmax,nbins,delx,spart,fpart +c... nucleon energy loop: + do i=1,ninc +c ... determine j-range = range of energy bins not equal zero + jini = 0 + jfin = 0 +c... particle spectrum loop: + do j=1,nbins + if (Dn(i,j).gt.0.D0) then + jfin = j + if (jini.eq.0) jini = j + endif + enddo + nm = jfin-jini+1 + nm1 = nm+1 + write(strnm1,'(I2)') nm1 + mat = '(' // strnm1 // '(5X,E10.4))' + nmc = 81 + nmc2 = 82 + write(strnm11,'(I2)') nmc2 + mat1 = '(' // strnm11 // '(5X,E10.4))' + nmcf = jfin-jini-80+1 + nmcf2 = nmcf+1 + write(strnm12,'(I2)') nmcf2 + mat2 = '(' // strnm12 // '(5X,E10.4))' + if (jfin.gt.0) then + write(1,572) E0_arr(i),jini,jfin +c... values written in one line: + if (jfin-jini.lt.80) then + write(1,FMT=mat) (Dn(i,jl),jl=jini,jfin) + else + jfin0 = jini+80 + write(1,FMT=mat1) (Dn(i,jl),jl=jini,jfin0) + write(1,FMT=mat2) (Dn(i,jl),jl=jfin0+1,jfin) + endif + endif + enddo + close(1) + + RETURN + END diff --git a/src/external/SOPHIA/jetset74dp.f b/src/external/SOPHIA/jetset74dp.f new file mode 100644 index 0000000..1bff736 --- /dev/null +++ b/src/external/SOPHIA/jetset74dp.f @@ -0,0 +1,11670 @@ +cFrom eng@lepton.bartol.udel.edu +cDate: Sun, 15 Nov 1998 18:18:44 -0500 +cFrom: Ralph R Engel +cTo: amuecke@physics.adelaide.edu.au +cSubject: File: jetset74dp.f +c +C +C WARNING: this file has been changed to double precision, +C alignment problems made it necessary to change also +C /LUJETS/, /PYSUBS/, and /PYINT5/ +C +C********************************************************************* +C********************************************************************* +C* ** +C* December 1993 ** +C* ** +C* The Lund Monte Carlo for Jet Fragmentation and e+e- Physics ** +C* ** +C* JETSET version 7.4 ** +C* ** +C* Torbjorn Sjostrand ** +C* Department of theoretical physics 2 ** +C* University of Lund ** +C* Solvegatan 14A, S-223 62 Lund, Sweden ** +C* E-mail torbjorn@thep.lu.se ** +C* phone +46 - 46 - 222 48 16 ** +C* ** +C* LUSHOW is written together with Mats Bengtsson ** +C* ** +C* The latest program version and documentation is found on WWW ** +C* http://thep.lu.se/tf2/staff/torbjorn/Welcome.html ** +C* ** +C* Copyright Torbjorn Sjostrand and CERN, Geneva 1993 ** +C* ** +C********************************************************************* +C********************************************************************* +C * +C List of subprograms in order of appearance, with main purpose * +C (S = subroutine, F = function, B = block data) * +C * +C S LU1ENT to fill one entry (= parton or particle) * +C S LU2ENT to fill two entries * +C S LU3ENT to fill three entries * +C S LU4ENT to fill four entries * +C S LUJOIN to connect entries with colour flow information * +C S LUGIVE to fill (or query) commonblock variables * +C S LUEXEC to administrate fragmentation and decay chain * +C S LUPREP to rearrange showered partons along strings * +C S LUSTRF to do string fragmentation of jet system * +C S LUINDF to do independent fragmentation of one or many jets * +C S LUDECY to do the decay of a particle * +C S LUKFDI to select parton and hadron flavours in fragm * +C S LUPTDI to select transverse momenta in fragm * +C S LUZDIS to select longitudinal scaling variable in fragm * +C S LUSHOW to do timelike parton shower evolution * +C S LUBOEI to include Bose-Einstein effects (crudely) * +C F ULMASS to give the mass of a particle or parton * +C S LUNAME to give the name of a particle or parton * +C F LUCHGE to give three times the electric charge * +C F LUCOMP to compress standard KF flavour code to internal KC * +C S LUERRM to write error messages and abort faulty run * +C F ULALEM to give the alpha_electromagnetic value * +C F ULALPS to give the alpha_strong value * +C F ULANGL to give the angle from known x and y components * +C F RLU to provide a random number generator * +C S RLUGET to save the state of the random number generator * +C S RLUSET to set the state of the random number generator * +C S LUROBO to rotate and/or boost an event * +C S LUEDIT to remove unwanted entries from record * +C S LULIST to list event record or particle data * +C S LULOGO to write a logo for JETSET and PYTHIA * +C S LUUPDA to update particle data * +C F KLU to provide integer-valued event information * +C F PLU to provide real-valued event information * +C S LUSPHE to perform sphericity analysis * +C S LUTHRU to perform thrust analysis * +C S LUCLUS to perform three-dimensional cluster analysis * +C S LUCELL to perform cluster analysis in (eta, phi, E_T) * +C S LUJMAS to give high and low jet mass of event * +C S LUFOWO to give Fox-Wolfram moments * +C S LUTABU to analyze events, with tabular output * +C * +C S LUEEVT to administrate the generation of an e+e- event * +C S LUXTOT to give the total cross-section at given CM energy * +C S LURADK to generate initial state photon radiation * +C S LUXKFL to select flavour of primary qqbar pair * +C S LUXJET to select (matrix element) jet multiplicity * +C S LUX3JT to select kinematics of three-jet event * +C S LUX4JT to select kinematics of four-jet event * +C S LUXDIF to select angular orientation of event * +C S LUONIA to perform generation of onium decay to gluons * +C * +C S LUHEPC to convert between /LUJETS/ and /HEPEVT/ records * +C S LUTEST to test the proper functioning of the package * +C B LUDATA to contain default values and particle data * +C * +C********************************************************************* + +CDECK ID>, LU1ENT + SUBROUTINE LU1ENT(IP,KF,PE,THE,PHI) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to store one parton/particle in commonblock LUJETS. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).GE.1) CALL LULIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)) CALL LUERRM(21, + &'(LU1ENT:) writing outside LUJETS memory') + KC=LUCOMP(KF) + IF(KC.EQ.0) CALL LUERRM(12,'(LU1ENT:) unknown flavour code') + +C...Find mass. Reset K, P and V vectors. + PM=0. + IF(MSTU(10).EQ.1) PM=P(IPA,5) + IF(MSTU(10).GE.2) PM=ULMASS(KF) + DO 100 J=1,5 + K(IPA,J)=0 + P(IPA,J)=0. + V(IPA,J)=0. + 100 CONTINUE + +C...Store parton/particle in K and P vectors. + K(IPA,1)=1 + IF(IP.LT.0) K(IPA,1)=2 + K(IPA,2)=KF + P(IPA,5)=PM + P(IPA,4)=MAX(PE,PM) + PA=SQRT(P(IPA,4)**2-P(IPA,5)**2) + P(IPA,1)=PA*SIN(THE)*COS(PHI) + P(IPA,2)=PA*SIN(THE)*SIN(PHI) + P(IPA,3)=PA*COS(THE) + +C...Set N. Optionally fragment/decay. + N=IPA + IF(IP.EQ.0) CALL LUEXEC + + RETURN + END + +C********************************************************************* + +CDECK ID>, LU2ENT + SUBROUTINE LU2ENT(IP,KF1,KF2,PECM) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to store two partons/particles in their CM frame, +C...with the first along the +z axis. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).GE.1) CALL LULIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21, + &'(LU2ENT:) writing outside LUJETS memory') + KC1=LUCOMP(KF1) + KC2=LUCOMP(KF2) + IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12, + &'(LU2ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0. + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=ULMASS(KF1) + PM2=0. + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=ULMASS(KF2) + DO 110 I=IPA,IPA+1 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0. + V(I,J)=0. + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSE + IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2, + & '(LU2ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2 + K(IPA+1,1)=1 + +C...Store partons in K vectors for parton shower evolution. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA,4)=MSTU(5)*(IPA+1) + K(IPA,5)=K(IPA,4) + K(IPA+1,4)=MSTU(5)*IPA + K(IPA+1,5)=K(IPA+1,4) + ENDIF + +C...Check kinematics and store partons/particles in P vectors. + IF(PECM.LE.PM1+PM2) CALL LUERRM(13, + &'(LU2ENT:) energy smaller than sum of masses') + PA=SQRT(MAX(0.D0,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/ + &(2.*PECM) + P(IPA,3)=PA + P(IPA,4)=SQRT(PM1**2+PA**2) + P(IPA,5)=PM1 + P(IPA+1,3)=-PA + P(IPA+1,4)=SQRT(PM2**2+PA**2) + P(IPA+1,5)=PM2 + +C...Set N. Optionally fragment/decay. + N=IPA+1 + IF(IP.EQ.0) CALL LUEXEC + + RETURN + END + +C********************************************************************* + +CDECK ID>, LU3ENT + SUBROUTINE LU3ENT(IP,KF1,KF2,KF3,PECM,X1,X3) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to store three partons or particles in their CM frame, +C...with the first along the +z axis and the third in the (x,z) +C...plane with x > 0. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).GE.1) CALL LULIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-2) CALL LUERRM(21, + &'(LU3ENT:) writing outside LUJETS memory') + KC1=LUCOMP(KF1) + KC2=LUCOMP(KF2) + KC3=LUCOMP(KF3) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LUERRM(12, + &'(LU3ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0. + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=ULMASS(KF1) + PM2=0. + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=ULMASS(KF2) + PM3=0. + IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) + IF(MSTU(10).GE.2) PM3=ULMASS(KF3) + DO 110 I=IPA,IPA+2 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0. + V(I,J)=0. + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + KQ3=KCHG(KC3,2)*ISIGN(1,KF3) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN + ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR. + &KQ1+KQ3.EQ.4)) THEN + ELSE + CALL LUERRM(2,'(LU3ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + K(IPA+2,2)=KF3 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2 + K(IPA+1,1)=1 + IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2 + K(IPA+2,1)=1 + +C...Store partons in K vectors for parton shower evolution. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + KCS=4 + IF(KQ1.EQ.-1) KCS=5 + K(IPA,KCS)=MSTU(5)*(IPA+1) + K(IPA,9-KCS)=MSTU(5)*(IPA+2) + K(IPA+1,KCS)=MSTU(5)*(IPA+2) + K(IPA+1,9-KCS)=MSTU(5)*IPA + K(IPA+2,KCS)=MSTU(5)*IPA + K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) + ENDIF + +C...Check kinematics. + MKERR=0 + IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR. + &0.5*X3*PECM.LE.PM3) MKERR=1 + PA1=SQRT(MAX(1D-10,(0.5*X1*PECM)**2-PM1**2)) + PA2=SQRT(MAX(1D-10,(0.5*(2.-X1-X3)*PECM)**2-PM2**2)) + PA3=SQRT(MAX(1D-10,(0.5*X3*PECM)**2-PM3**2)) + CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2) + CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3) + IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1 + CTHE3=MAX(-1.D0,MIN(1.D0,CTHE3)) + IF(MKERR.NE.0) CALL LUERRM(13, + &'(LU3ENT:) unphysical kinematical variable setup') + +C...Store partons/particles in P vectors. + P(IPA,3)=PA1 + P(IPA,4)=SQRT(PA1**2+PM1**2) + P(IPA,5)=PM1 + P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2) + P(IPA+2,3)=PA3*CTHE3 + P(IPA+2,4)=SQRT(PA3**2+PM3**2) + P(IPA+2,5)=PM3 + P(IPA+1,1)=-P(IPA+2,1) + P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3) + P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2) + P(IPA+1,5)=PM2 + +C...Set N. Optionally fragment/decay. + N=IPA+2 + IF(IP.EQ.0) CALL LUEXEC + + RETURN + END + +C********************************************************************* + +CDECK ID>, LU4ENT + SUBROUTINE LU4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to store four partons or particles in their CM frame, with +C...the first along the +z axis, the last in the xz plane with x > 0 +C...and the second having y < 0 and y > 0 with equal probability. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).GE.1) CALL LULIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-3) CALL LUERRM(21, + &'(LU4ENT:) writing outside LUJETS momory') + KC1=LUCOMP(KF1) + KC2=LUCOMP(KF2) + KC3=LUCOMP(KF3) + KC4=LUCOMP(KF4) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LUERRM(12, + &'(LU4ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0. + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=ULMASS(KF1) + PM2=0. + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=ULMASS(KF2) + PM3=0. + IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) + IF(MSTU(10).GE.2) PM3=ULMASS(KF3) + PM4=0. + IF(MSTU(10).EQ.1) PM4=P(IPA+3,5) + IF(MSTU(10).GE.2) PM4=ULMASS(KF4) + DO 110 I=IPA,IPA+3 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0. + V(I,J)=0. + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + KQ3=KCHG(KC3,2)*ISIGN(1,KF3) + KQ4=KCHG(KC4,2)*ISIGN(1,KF4) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN + ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR. + &KQ1+KQ4.EQ.4)) THEN + ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.) + &THEN + ELSE + CALL LUERRM(2,'(LU4ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + K(IPA+2,2)=KF3 + K(IPA+3,2)=KF4 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2 + K(IPA+1,1)=1 + IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0)) + & K(IPA+1,1)=2 + K(IPA+2,1)=1 + IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2 + K(IPA+3,1)=1 + +C...Store partons for parton shower evolution from q-g-g-qbar or +C...g-g-g-g event. + ELSEIF(KQ1+KQ2.NE.0) THEN + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + K(IPA+3,1)=3 + KCS=4 + IF(KQ1.EQ.-1) KCS=5 + K(IPA,KCS)=MSTU(5)*(IPA+1) + K(IPA,9-KCS)=MSTU(5)*(IPA+3) + K(IPA+1,KCS)=MSTU(5)*(IPA+2) + K(IPA+1,9-KCS)=MSTU(5)*IPA + K(IPA+2,KCS)=MSTU(5)*(IPA+3) + K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) + K(IPA+3,KCS)=MSTU(5)*IPA + K(IPA+3,9-KCS)=MSTU(5)*(IPA+2) + +C...Store partons for parton shower evolution from q-qbar-q-qbar event. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + K(IPA+3,1)=3 + K(IPA,4)=MSTU(5)*(IPA+1) + K(IPA,5)=K(IPA,4) + K(IPA+1,4)=MSTU(5)*IPA + K(IPA+1,5)=K(IPA+1,4) + K(IPA+2,4)=MSTU(5)*(IPA+3) + K(IPA+2,5)=K(IPA+2,4) + K(IPA+3,4)=MSTU(5)*(IPA+2) + K(IPA+3,5)=K(IPA+3,4) + ENDIF + +C...Check kinematics. + MKERR=0 + IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)* + &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1 + PA1=SQRT(MAX(1D-10,(0.5*X1*PECM)**2-PM1**2)) + PA2=SQRT(MAX(1D-10,(0.5*X2*PECM)**2-PM2**2)) + PA4=SQRT(MAX(1D-10,(0.5*X4*PECM)**2-PM4**2)) + X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2 + CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4) + IF(ABS(CTHE4).GE.1.002) MKERR=1 + CTHE4=MAX(-1.D0,MIN(1.D0,CTHE4)) + STHE4=SQRT(1.-CTHE4**2) + CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2) + IF(ABS(CTHE2).GE.1.002) MKERR=1 + CTHE2=MAX(-1.D0,MIN(1.D0,CTHE2)) + STHE2=SQRT(1.-CTHE2**2) + CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/ + &MAX(1D-8*PECM**2,4.*PA2*STHE2*PA4*STHE4) + IF(ABS(CPHI2).GE.1.05) MKERR=1 + CPHI2=MAX(-1.D0,MIN(1.D0,CPHI2)) + IF(MKERR.EQ.1) CALL LUERRM(13, + &'(LU4ENT:) unphysical kinematical variable setup') + +C...Store partons/particles in P vectors. + P(IPA,3)=PA1 + P(IPA,4)=SQRT(PA1**2+PM1**2) + P(IPA,5)=PM1 + P(IPA+3,1)=PA4*STHE4 + P(IPA+3,3)=PA4*CTHE4 + P(IPA+3,4)=SQRT(PA4**2+PM4**2) + P(IPA+3,5)=PM4 + P(IPA+1,1)=PA2*STHE2*CPHI2 + P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLU(0)+0.5) + P(IPA+1,3)=PA2*CTHE2 + P(IPA+1,4)=SQRT(PA2**2+PM2**2) + P(IPA+1,5)=PM2 + P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1) + P(IPA+2,2)=-P(IPA+1,2) + P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3) + P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2) + P(IPA+2,5)=PM3 + +C...Set N. Optionally fragment/decay. + N=IPA+3 + IF(IP.EQ.0) CALL LUEXEC + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUJOIN + SUBROUTINE LUJOIN(NJOIN,IJOIN) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to connect a sequence of partons with colour flow indices, +C...as required for subsequent shower evolution (or other operations). + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION IJOIN(*) + +C...Check that partons are of right types to be connected. + IF(NJOIN.LT.2) GOTO 120 + KQSUM=0 + DO 100 IJN=1,NJOIN + I=IJOIN(IJN) + IF(I.LE.0.OR.I.GT.N) GOTO 120 + IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 120 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 120 + IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120 + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(IJN.EQ.1) KQS=KQ + 100 CONTINUE + IF(KQSUM.NE.0) GOTO 120 + +C...Connect the partons sequentially (closing for gluon loop). + KCS=(9-KQS)/2 + IF(KQS.EQ.2) KCS=INT(4.5+RLU(0)) + DO 110 IJN=1,NJOIN + I=IJOIN(IJN) + K(I,1)=3 + IF(IJN.NE.1) IP=IJOIN(IJN-1) + IF(IJN.EQ.1) IP=IJOIN(NJOIN) + IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1) + IF(IJN.EQ.NJOIN) IN=IJOIN(1) + K(I,KCS)=MSTU(5)*IN + K(I,9-KCS)=MSTU(5)*IP + IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0 + IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0 + 110 CONTINUE + +C...Error exit: no action taken. + RETURN + 120 CALL LUERRM(12, + &'(LUJOIN:) given entries can not be joined by one string') + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUGIVE + SUBROUTINE LUGIVE(CHIN) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to set values of commonblock variables (also in PYTHIA!). + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + COMMON/LUDAT4/CHAF(500) + CHARACTER CHAF*8 + COMMON/LUDATR/MRLU(6),RRLU(100) + COMMON/PYSUBS/MSUB(200),KFIN(2,-40:40),CKIN(200),MSEL + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3) + COMMON/PYINT5/XSEC(0:200,3),NGEN(0:200,3) + COMMON/PYINT6/PROC(0:200) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + CHARACTER PROC*28 + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/ + SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/, + &/PYINT5/,/PYINT6/,/PYINT7/ + CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28, + &CHNEW2*28,CHNAM*4,CHVAR(43)*4,CHALP(2)*26,CHIND*8,CHINI*10, + &CHINR*16 + DIMENSION MSVAR(43,8) + +C...For each variable to be translated give: name, +C...integer/real/character, no. of indices, lower&upper index bounds. + DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG', + &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU', + &'RRLU','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI', + &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH', + &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC','SIGT'/ + DATA ((MSVAR(I,J),J=1,8),I=1,43)/ 1,7*0, 1,2,1,4000,1,5,2*0, + & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0, + & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, + & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0, + & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0, + & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0, + & 1,1,1,6,4*0, 2,1,1,100,4*0, + & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0, + & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, + & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0, + & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2, + & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0, + & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0, + & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0, + & 2,3,0,6,0,6,0,5/ + DATA CHALP/'abcdefghijklmnopqrstuvwxyz', + &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + +C...Length of character variable. Subdivide it into instructions. + IF(MSTU(12).GE.1) CALL LULIST(0) + CHBIT=CHIN//' ' + LBIT=101 + 100 LBIT=LBIT-1 + IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100 + LTOT=0 + DO 110 LCOM=1,LBIT + IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110 + LTOT=LTOT+1 + CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM) + 110 CONTINUE + LLOW=0 + 120 LHIG=LLOW+1 + 130 LHIG=LHIG+1 + IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130 + LBIT=LHIG-LLOW-1 + CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1) + +C...Identify commonblock variable. + LNAM=1 + 140 LNAM=LNAM+1 + IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND. + &LNAM.LE.4) GOTO 140 + CHNAM=CHBIT(1:LNAM-1)//' ' + DO 160 LCOM=1,LNAM-1 + DO 150 LALP=1,26 + IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)= + &CHALP(2)(LALP:LALP) + 150 CONTINUE + 160 CONTINUE + IVAR=0 + DO 170 IV=1,43 + IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV + 170 CONTINUE + IF(IVAR.EQ.0) THEN + CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Identify any indices. + I1=0 + I2=0 + I3=0 + NINDX=0 + IF(CHBIT(LNAM:LNAM).EQ.'(') THEN + LIND=LNAM + 180 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180 + CHIND=' ' + IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c'). + & AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN + CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1) + READ(CHIND,'(I8)') KF + I1=LUCOMP(KF) + ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ. + & 'c') THEN + CALL LUERRM(18,'(LUGIVE:) not allowed to use C index for '// + & CHNAM) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ELSE + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I1 + ENDIF + LNAM=LIND + IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 + NINDX=1 + ENDIF + IF(CHBIT(LNAM:LNAM).EQ.',') THEN + LIND=LNAM + 190 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190 + CHIND=' ' + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I2 + LNAM=LIND + IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 + NINDX=2 + ENDIF + IF(CHBIT(LNAM:LNAM).EQ.',') THEN + LIND=LNAM + 200 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200 + CHIND=' ' + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I3 + LNAM=LIND+1 + NINDX=3 + ENDIF + +C...Check that indices allowed. + IERR=0 + IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1 + IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4))) + &IERR=2 + IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6))) + &IERR=3 + IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8))) + &IERR=4 + IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5 + IF(IERR.GE.1) THEN + CALL LUERRM(18,'(LUGIVE:) unallowed indices for '// + & CHBIT(1:LNAM-1)) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Save old value of variable. + IF(IVAR.EQ.1) THEN + IOLD=N + ELSEIF(IVAR.EQ.2) THEN + IOLD=K(I1,I2) + ELSEIF(IVAR.EQ.3) THEN + ROLD=P(I1,I2) + ELSEIF(IVAR.EQ.4) THEN + ROLD=V(I1,I2) + ELSEIF(IVAR.EQ.5) THEN + IOLD=MSTU(I1) + ELSEIF(IVAR.EQ.6) THEN + ROLD=PARU(I1) + ELSEIF(IVAR.EQ.7) THEN + IOLD=MSTJ(I1) + ELSEIF(IVAR.EQ.8) THEN + ROLD=PARJ(I1) + ELSEIF(IVAR.EQ.9) THEN + IOLD=KCHG(I1,I2) + ELSEIF(IVAR.EQ.10) THEN + ROLD=PMAS(I1,I2) + ELSEIF(IVAR.EQ.11) THEN + ROLD=PARF(I1) + ELSEIF(IVAR.EQ.12) THEN + ROLD=VCKM(I1,I2) + ELSEIF(IVAR.EQ.13) THEN + IOLD=MDCY(I1,I2) + ELSEIF(IVAR.EQ.14) THEN + IOLD=MDME(I1,I2) + ELSEIF(IVAR.EQ.15) THEN + ROLD=BRAT(I1) + ELSEIF(IVAR.EQ.16) THEN + IOLD=KFDP(I1,I2) + ELSEIF(IVAR.EQ.17) THEN + CHOLD=CHAF(I1) + ELSEIF(IVAR.EQ.18) THEN + IOLD=MRLU(I1) + ELSEIF(IVAR.EQ.19) THEN + ROLD=RRLU(I1) + ELSEIF(IVAR.EQ.20) THEN + IOLD=MSEL + ELSEIF(IVAR.EQ.21) THEN + IOLD=MSUB(I1) + ELSEIF(IVAR.EQ.22) THEN + IOLD=KFIN(I1,I2) + ELSEIF(IVAR.EQ.23) THEN + ROLD=CKIN(I1) + ELSEIF(IVAR.EQ.24) THEN + IOLD=MSTP(I1) + ELSEIF(IVAR.EQ.25) THEN + ROLD=PARP(I1) + ELSEIF(IVAR.EQ.26) THEN + IOLD=MSTI(I1) + ELSEIF(IVAR.EQ.27) THEN + ROLD=PARI(I1) + ELSEIF(IVAR.EQ.28) THEN + IOLD=MINT(I1) + ELSEIF(IVAR.EQ.29) THEN + ROLD=VINT(I1) + ELSEIF(IVAR.EQ.30) THEN + IOLD=ISET(I1) + ELSEIF(IVAR.EQ.31) THEN + IOLD=KFPR(I1,I2) + ELSEIF(IVAR.EQ.32) THEN + ROLD=COEF(I1,I2) + ELSEIF(IVAR.EQ.33) THEN + IOLD=ICOL(I1,I2,I3) + ELSEIF(IVAR.EQ.34) THEN + ROLD=XSFX(I1,I2) + ELSEIF(IVAR.EQ.35) THEN + IOLD=ISIG(I1,I2) + ELSEIF(IVAR.EQ.36) THEN + ROLD=SIGH(I1) + ELSEIF(IVAR.EQ.37) THEN + ROLD=WIDP(I1,I2) + ELSEIF(IVAR.EQ.38) THEN + ROLD=WIDE(I1,I2) + ELSEIF(IVAR.EQ.39) THEN + ROLD=WIDS(I1,I2) + ELSEIF(IVAR.EQ.40) THEN + IOLD=NGEN(I1,I2) + ELSEIF(IVAR.EQ.41) THEN + ROLD=XSEC(I1,I2) + ELSEIF(IVAR.EQ.42) THEN + CHOLD2=PROC(I1) + ELSEIF(IVAR.EQ.43) THEN + ROLD=SIGT(I1,I2,I3) + ENDIF + +C...Print current value of variable. Loop back. + IF(LNAM.GE.LBIT) THEN + CHBIT(LNAM:14)=' ' + CHBIT(15:60)=' has the value ' + IF(MSVAR(IVAR,1).EQ.1) THEN + WRITE(CHBIT(51:60),'(I10)') IOLD + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + WRITE(CHBIT(47:60),'(F14.5)') ROLD + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHBIT(53:60)=CHOLD + ELSE + CHBIT(33:60)=CHOLD + ENDIF + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Read in new variable value. + IF(MSVAR(IVAR,1).EQ.1) THEN + CHINI=' ' + CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT) + READ(CHINI,'(I10)') INEW + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + CHINR=' ' + CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT) + READ(CHINR,'(F16.2)') RNEW + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHNEW=CHBIT(LNAM+1:LBIT)//' ' + ELSE + CHNEW2=CHBIT(LNAM+1:LBIT)//' ' + ENDIF + +C...Store new variable value. + IF(IVAR.EQ.1) THEN + N=INEW + ELSEIF(IVAR.EQ.2) THEN + K(I1,I2)=INEW + ELSEIF(IVAR.EQ.3) THEN + P(I1,I2)=RNEW + ELSEIF(IVAR.EQ.4) THEN + V(I1,I2)=RNEW + ELSEIF(IVAR.EQ.5) THEN + MSTU(I1)=INEW + ELSEIF(IVAR.EQ.6) THEN + PARU(I1)=RNEW + ELSEIF(IVAR.EQ.7) THEN + MSTJ(I1)=INEW + ELSEIF(IVAR.EQ.8) THEN + PARJ(I1)=RNEW + ELSEIF(IVAR.EQ.9) THEN + KCHG(I1,I2)=INEW + ELSEIF(IVAR.EQ.10) THEN + PMAS(I1,I2)=RNEW + ELSEIF(IVAR.EQ.11) THEN + PARF(I1)=RNEW + ELSEIF(IVAR.EQ.12) THEN + VCKM(I1,I2)=RNEW + ELSEIF(IVAR.EQ.13) THEN + MDCY(I1,I2)=INEW + ELSEIF(IVAR.EQ.14) THEN + MDME(I1,I2)=INEW + ELSEIF(IVAR.EQ.15) THEN + BRAT(I1)=RNEW + ELSEIF(IVAR.EQ.16) THEN + KFDP(I1,I2)=INEW + ELSEIF(IVAR.EQ.17) THEN + CHAF(I1)=CHNEW + ELSEIF(IVAR.EQ.18) THEN + MRLU(I1)=INEW + ELSEIF(IVAR.EQ.19) THEN + RRLU(I1)=RNEW + ELSEIF(IVAR.EQ.20) THEN + MSEL=INEW + ELSEIF(IVAR.EQ.21) THEN + MSUB(I1)=INEW + ELSEIF(IVAR.EQ.22) THEN + KFIN(I1,I2)=INEW + ELSEIF(IVAR.EQ.23) THEN + CKIN(I1)=RNEW + ELSEIF(IVAR.EQ.24) THEN + MSTP(I1)=INEW + ELSEIF(IVAR.EQ.25) THEN + PARP(I1)=RNEW + ELSEIF(IVAR.EQ.26) THEN + MSTI(I1)=INEW + ELSEIF(IVAR.EQ.27) THEN + PARI(I1)=RNEW + ELSEIF(IVAR.EQ.28) THEN + MINT(I1)=INEW + ELSEIF(IVAR.EQ.29) THEN + VINT(I1)=RNEW + ELSEIF(IVAR.EQ.30) THEN + ISET(I1)=INEW + ELSEIF(IVAR.EQ.31) THEN + KFPR(I1,I2)=INEW + ELSEIF(IVAR.EQ.32) THEN + COEF(I1,I2)=RNEW + ELSEIF(IVAR.EQ.33) THEN + ICOL(I1,I2,I3)=INEW + ELSEIF(IVAR.EQ.34) THEN + XSFX(I1,I2)=RNEW + ELSEIF(IVAR.EQ.35) THEN + ISIG(I1,I2)=INEW + ELSEIF(IVAR.EQ.36) THEN + SIGH(I1)=RNEW + ELSEIF(IVAR.EQ.37) THEN + WIDP(I1,I2)=RNEW + ELSEIF(IVAR.EQ.38) THEN + WIDE(I1,I2)=RNEW + ELSEIF(IVAR.EQ.39) THEN + WIDS(I1,I2)=RNEW + ELSEIF(IVAR.EQ.40) THEN + NGEN(I1,I2)=INEW + ELSEIF(IVAR.EQ.41) THEN + XSEC(I1,I2)=RNEW + ELSEIF(IVAR.EQ.42) THEN + PROC(I1)=CHNEW2 + ELSEIF(IVAR.EQ.43) THEN + SIGT(I1,I2,I3)=RNEW + ENDIF + +C...Write old and new value. Loop back. + CHBIT(LNAM:14)=' ' + CHBIT(15:60)=' changed from to ' + IF(MSVAR(IVAR,1).EQ.1) THEN + WRITE(CHBIT(33:42),'(I10)') IOLD + WRITE(CHBIT(51:60),'(I10)') INEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + WRITE(CHBIT(29:42),'(F14.5)') ROLD + WRITE(CHBIT(47:60),'(F14.5)') RNEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHBIT(35:42)=CHOLD + CHBIT(53:60)=CHNEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSE + CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2 + IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88) + ENDIF + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + +C...Format statement for output on unit MSTU(11) (by default 6). + 5000 FORMAT(5X,A60) + 5100 FORMAT(5X,A88) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUEXEC + SUBROUTINE LUEXEC + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to administrate the fragmentation and decay chain. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/ + DIMENSION PS(2,6) + +C...Initialize and reset. + MSTU(24)=0 + IF(MSTU(12).GE.1) CALL LULIST(0) + MSTU(31)=MSTU(31)+1 + MSTU(1)=0 + MSTU(2)=0 + MSTU(3)=0 + IF(MSTU(17).LE.0) MSTU(90)=0 + MCONS=1 + +C...Sum up momentum, energy and charge for starting entries. + NSAV=N + DO 110 I=1,2 + DO 100 J=1,6 + PS(I,J)=0. + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130 + DO 120 J=1,4 + PS(1,J)=PS(1,J)+P(I,J) + 120 CONTINUE + PS(1,6)=PS(1,6)+LUCHGE(K(I,2)) + 130 CONTINUE + PARU(21)=PS(1,4) + +C...Prepare system for subsequent fragmentation/decay. + CALL LUPREP(0) + +C...Loop through jet fragmentation and particle decays. + MBE=0 + 140 MBE=MBE+1 + IP=0 + 150 IP=IP+1 + KC=0 + IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2)) + IF(KC.EQ.0) THEN + +C...Particle decay if unstable and allowed. Save long-lived particle +C...decays until second pass after Bose-Einstein effects. + ELSEIF(KCHG(KC,2).EQ.0) THEN + IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE + & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311)) + & CALL LUDECY(IP) + +C...Decay products may develop a shower. + IF(MSTJ(92).GT.0) THEN + IP1=MSTJ(92) + QMAX=SQRT(MAX(0.D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1, + & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2)) + CALL LUSHOW(IP1,IP1+1,QMAX) + CALL LUPREP(IP1) + MSTJ(92)=0 + ELSEIF(MSTJ(92).LT.0) THEN + IP1=-MSTJ(92) + CALL LUSHOW(IP1,-3,P(IP,5)) + CALL LUPREP(IP1) + MSTJ(92)=0 + ENDIF + +C...Jet fragmentation: string or independent fragmentation. + ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN + MFRAG=MSTJ(1) + IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2 + IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN + IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND. + & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN + IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG) + ENDIF + ENDIF + IF(MFRAG.EQ.1) CALL LUSTRF(IP) + IF(MFRAG.EQ.2) CALL LUINDF(IP) + IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0 + IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0 + ENDIF + +C...Loop back if enough space left in LUJETS and no error abort. + IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN + ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN + GOTO 150 + ELSEIF(IP.LT.N) THEN + CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS') + ENDIF + +C...Include simple Bose-Einstein effect parametrization if desired. + IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN + CALL LUBOEI(NSAV) + GOTO 140 + ENDIF + +C...Check that momentum, energy and charge were conserved. + DO 170 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170 + DO 160 J=1,4 + PS(2,J)=PS(2,J)+P(I,J) + 160 CONTINUE + PS(2,6)=PS(2,6)+LUCHGE(K(I,2)) + 170 CONTINUE + PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)- + &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4))) + IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15, + &'(LUEXEC:) four-momentum was not conserved') + IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15, + &'(LUEXEC:) charge was not conserved') + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUPREP + SUBROUTINE LUPREP(IP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to rearrange partons along strings, to allow small systems +C...to collapse into one or two particles and to check flavours. +C IMPLICIT DOUBLE PRECISION(D) + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/ + DIMENSION DPS(5),DPC(5),UE(3) + +C...Rearrange parton shower product listing along strings: begin loop. + I1=N + DO 130 MQGST=1,2 + DO 120 I=MAX(1,IP),N + IF(K(I,1).NE.3) GOTO 120 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 120 + KQ=KCHG(KC,2) + IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120 + +C...Pick up loose string end. + KCS=4 + IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 + IA=I + NSTP=0 + 100 NSTP=NSTP+1 + IF(NSTP.GT.4*N) THEN + CALL LUERRM(14,'(LUPREP:) caught in infinite loop') + RETURN + ENDIF + +C...Copy undecayed parton. + IF(K(IA,1).EQ.3) THEN + IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS') + RETURN + ENDIF + I1=I1+1 + K(I1,1)=2 + IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1 + K(I1,2)=K(IA,2) + K(I1,3)=IA + K(I1,4)=0 + K(I1,5)=0 + DO 110 J=1,5 + P(I1,J)=P(IA,J) + V(I1,J)=V(IA,J) + 110 CONTINUE + K(IA,1)=K(IA,1)+10 + IF(K(I1,1).EQ.1) GOTO 120 + ENDIF + +C...Go to next parton in colour space. + IB=IA + IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)) + &.NE.0) THEN + IA=MOD(K(IB,KCS),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 + MREV=0 + ELSE + IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)) + & .EQ.0) KCS=9-KCS + IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 + MREV=1 + ENDIF + IF(IA.LE.0.OR.IA.GT.N) THEN + CALL LUERRM(12,'(LUPREP:) colour rearrangement failed') + RETURN + ENDIF + IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), + &MSTU(5)).EQ.IB) THEN + IF(MREV.EQ.1) KCS=9-KCS + IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS + K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 + ELSE + IF(MREV.EQ.0) KCS=9-KCS + IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS + K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 + ENDIF + IF(IA.NE.I) GOTO 100 + K(I1,1)=1 + 120 CONTINUE + 130 CONTINUE + N=I1 + IF(MSTJ(14).LT.0) RETURN + +C...Find lowest-mass colour singlet jet system, OK if above threshold. + IF(MSTJ(14).EQ.0) GOTO 320 + NS=N + 140 NSIN=N-NS + PDM=1.+PARJ(32) + IC=0 + DO 190 I=MAX(1,IP),NS + IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN + ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN + NSIN=NSIN+1 + IC=I + DO 150 J=1,4 + DPS(J)=P(I,J) + 150 CONTINUE + MSTJ(93)=1 + DPS(5)=ULMASS(K(I,2)) + ELSEIF(K(I,1).EQ.2) THEN + DO 160 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 160 CONTINUE + ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN + DO 170 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 170 CONTINUE + MSTJ(93)=1 + DPS(5)=DPS(5)+ULMASS(K(I,2)) + PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5) + IF(PD.LT.PDM) THEN + PDM=PD + DO 180 J=1,5 + DPC(J)=DPS(J) + 180 CONTINUE + IC1=IC + IC2=I + ENDIF + IC=0 + ELSE + NSIN=NSIN+1 + ENDIF + 190 CONTINUE + IF(PDM.GE.PARJ(32)) GOTO 320 + +C...Fill small-mass system as cluster. + NSAV=N + PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)) + K(N+1,1)=11 + K(N+1,2)=91 + K(N+1,3)=IC1 + K(N+1,4)=N+2 + K(N+1,5)=N+3 + P(N+1,1)=DPC(1) + P(N+1,2)=DPC(2) + P(N+1,3)=DPC(3) + P(N+1,4)=DPC(4) + P(N+1,5)=PECM + +C...Form two particles from flavours of lowest-mass system, if feasible. + K(N+2,1)=1 + K(N+3,1)=1 + IF(MSTU(16).NE.2) THEN + K(N+2,3)=N+1 + K(N+3,3)=N+1 + ELSE + K(N+2,3)=IC1 + K(N+3,3)=IC2 + ENDIF + K(N+2,4)=0 + K(N+3,4)=0 + K(N+2,5)=0 + K(N+3,5)=0 + IF(IABS(K(IC1,2)).NE.21) THEN + KC1=LUCOMP(K(IC1,2)) + KC2=LUCOMP(K(IC2,2)) + IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320 + KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2)) + KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2)) + IF(KQ1+KQ2.NE.0) GOTO 320 + 200 CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2)) + CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200 + ELSE + IF(IABS(K(IC2,2)).NE.21) GOTO 320 + 210 CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP) + CALL LUKFDI(KFLN,0,KFLM,K(N+2,2)) + CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210 + ENDIF + P(N+2,5)=ULMASS(K(N+2,2)) + P(N+3,5)=ULMASS(K(N+3,2)) + IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320 + IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260 + +C...Perform two-particle decay of jet system, if possible. + IF(PECM.GE.0.02*DPC(4)) THEN + PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2- + & (P(N+2,5)-P(N+3,5))**2))/(2.*PECM) + UE(3)=2.*RLU(0)-1. + PHI=PARU(2)*RLU(0) + UE(1)=SQRT(1.-UE(3)**2)*COS(PHI) + UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI) + DO 220 J=1,3 + P(N+2,J)=PA*UE(J) + P(N+3,J)=-PA*UE(J) + 220 CONTINUE + P(N+2,4)=SQRT(PA**2+P(N+2,5)**2) + P(N+3,4)=SQRT(PA**2+P(N+3,5)**2) + MSTU(33)=1 + CALL LUDBRB(N+2,N+3,0.D0,0.D0,DPC(1)/DPC(4),DPC(2)/DPC(4), + & DPC(3)/DPC(4)) + ELSE + NP=0 + DO 230 I=IC1,IC2 + IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1 + 230 CONTINUE + HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)- + & P(IC1,3)*P(IC2,3) + IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260 + HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2) + HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2) + HR=SQRT(MAX(0.D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/ + & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1. + HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2 + HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC + HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC + DO 240 J=1,4 + P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J) + P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J) + 240 CONTINUE + ENDIF + DO 250 J=1,4 + V(N+1,J)=V(IC1,J) + V(N+2,J)=V(IC1,J) + V(N+3,J)=V(IC2,J) + 250 CONTINUE + V(N+1,5)=0. + V(N+2,5)=0. + V(N+3,5)=0. + N=N+3 + GOTO 300 + +C...Else form one particle from the flavours available, if possible. + 260 K(N+1,5)=N+2 + IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN + GOTO 320 + ELSEIF(IABS(K(IC1,2)).NE.21) THEN + CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2)) + ELSE + KFLN=1+INT((2.+PARJ(2))*RLU(0)) + CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2)) + ENDIF + IF(K(N+2,2).EQ.0) GOTO 260 + P(N+2,5)=ULMASS(K(N+2,2)) + +C...Find parton/particle which combines to largest extra mass. + IR=0 + HA=0. + HSM=0. + DO 280 MCOMB=1,3 + IF(IR.NE.0) GOTO 280 + DO 270 I=MAX(1,IP),N + IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2 + &.AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270 + IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2)) + IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270 + IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270 + IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100) + &GOTO 270 + HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3) + HSR=2.*HCR+PECM**2-P(N+2,5)**2-2.*P(N+2,5)*P(I,5) + IF(HSR.GT.HSM) THEN + IR=I + HA=HCR + HSM=HSR + ENDIF + 270 CONTINUE + 280 CONTINUE + +C...Shuffle energy and momentum to put new particle on mass shell. + IF(IR.NE.0) THEN + HB=PECM**2+HA + HC=P(N+2,5)**2+HA + HD=P(IR,5)**2+HA + HK2=0.5*(HB*SQRT(MAX(0.D0,((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/ + & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD) + HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB + DO 290 J=1,4 + P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J) + P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J) + V(N+1,J)=V(IC1,J) + V(N+2,J)=V(IC1,J) + 290 CONTINUE + V(N+1,5)=0. + V(N+2,5)=0. + N=N+2 + ELSE + CALL LUERRM(3,'(LUPREP:) no match for collapsing cluster') + RETURN + ENDIF + +C...Mark collapsed system and store daughter pointers. Iterate. + 300 DO 310 I=IC1,IC2 + IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0) + &THEN + K(I,1)=K(I,1)+10 + IF(MSTU(16).NE.2) THEN + K(I,4)=NSAV+1 + K(I,5)=NSAV+1 + ELSE + K(I,4)=NSAV+2 + K(I,5)=N + ENDIF + ENDIF + 310 CONTINUE + IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140 + +C...Check flavours and invariant masses in parton systems. + 320 NP=0 + KFN=0 + KQS=0 + DO 330 J=1,5 + DPS(J)=0. + 330 CONTINUE + DO 360 I=MAX(1,IP),N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 360 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 360 + NP=NP+1 + IF(KQ.NE.2) THEN + KFN=KFN+1 + KQS=KQS+KQ + MSTJ(93)=1 + DPS(5)=DPS(5)+ULMASS(K(I,2)) + ENDIF + DO 340 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 340 CONTINUE + IF(K(I,1).EQ.1) THEN + IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL + & LUERRM(2,'(LUPREP:) unphysical flavour combination') + IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT. + & (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3, + & '(LUPREP:) too small mass in jet system') + NP=0 + KFN=0 + KQS=0 + DO 350 J=1,5 + DPS(J)=0. + 350 CONTINUE + ENDIF + 360 CONTINUE + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUSTRF + SUBROUTINE LUSTRF(IP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C...Purpose: to handle the fragmentation of an arbitrary colour singlet +C...jet system according to the Lund string fragmentation model. +C IMPLICIT DOUBLE PRECISION(D) + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2), + &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5), + &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8) + +C...Function: four-product of two vectors. + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)- + &DP(I,3)*DP(J,3) + +C...Reset counters. Identify parton system. + MSTJ(91)=0 + NSAV=N + MSTU90=MSTU(90) + NP=0 + KQSUM=0 + DO 100 J=1,5 + DPS(J)=0D0 + 100 CONTINUE + MJU(1)=0 + MJU(2)=0 + I=IP-1 + 110 I=I+1 + IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN + CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 110 + IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Take copy of partons to be considered. Check flavour sum. + NP=NP+1 + DO 120 J=1,5 + K(N+NP,J)=K(I,J) + P(N+NP,J)=P(I,J) + IF(J.NE.4) DPS(J)=DPS(J)+P(I,J) + 120 CONTINUE + DPS(4)=DPS(4)+SQRT(DBLE(P(I,1))**2+DBLE(P(I,2))**2+ + &DBLE(P(I,3))**2+DBLE(P(I,5))**2) + K(N+NP,3)=I + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(K(I,1).EQ.41) THEN + KQSUM=KQSUM+2*KQ + IF(KQSUM.EQ.KQ) MJU(1)=N+NP + IF(KQSUM.NE.KQ) MJU(2)=N+NP + ENDIF + IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110 + IF(KQSUM.NE.0) THEN + CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Boost copied system to CM frame (for better numerical precision). + IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN + MBST=0 + MSTU(33)=1 + CALL LUDBRB(N+1,N+NP,0.D0,0.D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), + & -DPS(3)/DPS(4)) + ELSE + MBST=1 + HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3))) + DO 130 I=N+1,N+NP + HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 + IF(P(I,3).GT.0.) THEN + HHPEZ=(P(I,4)+P(I,3))/HHBZ + P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ) + ELSE + HHPEZ=(P(I,4)-P(I,3))*HHBZ + P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ) + ENDIF + 130 CONTINUE + ENDIF + +C...Search for very nearby partons that may be recombined. + NTRYR=0 + PARU12=PARU(12) + PARU13=PARU(13) + MJU(3)=MJU(1) + MJU(4)=MJU(2) + NR=NP + 140 IF(NR.GE.3) THEN + PDRMIN=2.*PARU12 + DO 150 I=N+1,N+NR + IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150 + I1=I+1 + IF(I.EQ.N+NR) I1=N+1 + IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150 + IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21) + & GOTO 150 + IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 150 + PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+ + & P(I1,2)**2+P(I1,3)**2)) + PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3) + PDR=4.*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2.*(PAP-PVP)) + IF(PDR.LT.PDRMIN) THEN + IR=I + PDRMIN=PDR + ENDIF + 150 CONTINUE + +C...Recombine very nearby partons to avoid machine precision problems. + IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN + DO 160 J=1,4 + P(N+1,J)=P(N+1,J)+P(N+NR,J) + 160 CONTINUE + P(N+1,5)=SQRT(MAX(0.D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + NR=NR-1 + GOTO 140 + ELSEIF(PDRMIN.LT.PARU12) THEN + DO 170 J=1,4 + P(IR,J)=P(IR,J)+P(IR+1,J) + 170 CONTINUE + P(IR,5)=SQRT(MAX(0.D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2- + & P(IR,3)**2)) + DO 190 I=IR+1,N+NR-1 + K(I,2)=K(I+1,2) + DO 180 J=1,5 + P(I,J)=P(I+1,J) + 180 CONTINUE + 190 CONTINUE + IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2) + NR=NR-1 + IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1 + IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1 + GOTO 140 + ENDIF + ENDIF + NTRYR=NTRYR+1 + +C...Reset particle counter. Skip ahead if no junctions are present; +C...this is usually the case! + NRS=MAX(5*NR+11,NP) + NTRY=0 + 200 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN + PARU12=4.*PARU12 + PARU13=2.*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100) THEN + CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=N+NRS + MSTU(90)=MSTU90 + IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580 + DO 570 JT=1,2 + NJS(JT)=0 + IF(MJU(JT).EQ.0) GOTO 570 + JS=3-2*JT + +C...Find and sum up momentum on three sides of junction. Check flavours. + DO 220 IU=1,3 + IJU(IU)=0 + DO 210 J=1,5 + PJU(IU,J)=0. + 210 CONTINUE + 220 CONTINUE + IU=0 + DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS + IF(K(I1,2).NE.21.AND.IU.LE.2) THEN + IU=IU+1 + IJU(IU)=I1 + ENDIF + DO 230 J=1,4 + PJU(IU,J)=PJU(IU,J)+P(I1,J) + 230 CONTINUE + 240 CONTINUE + DO 250 IU=1,3 + PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2) + 250 CONTINUE + IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND. + &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN + CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Calculate (approximate) boost to rest frame of junction. + T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/ + &(PJU(1,5)*PJU(2,5)) + T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/ + &(PJU(1,5)*PJU(3,5)) + T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/ + &(PJU(2,5)*PJU(3,5)) + T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23)) + T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13)) + TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12)) + T1F=(TSQ-T22*(1.+T12))/(1.-T12**2) + T2F=(TSQ-T11*(1.+T12))/(1.-T12**2) + DO 260 J=1,3 + TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5)) + 260 CONTINUE + TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2) + DO 270 IU=1,3 + PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)- + &TJU(3)*PJU(IU,3) + 270 CONTINUE + +C...Put junction at rest if motion could give inconsistencies. + IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN + DO 280 J=1,3 + TJU(J)=0. + 280 CONTINUE + TJU(4)=1. + PJU(1,5)=PJU(1,4) + PJU(2,5)=PJU(2,4) + PJU(3,5)=PJU(3,4) + ENDIF + +C...Start preparing for fragmentation of two strings from junction. + ISTA=I + DO 550 IU=1,2 + NS=IJU(IU+1)-IJU(IU) + +C...Junction strings: find longitudinal string directions. + DO 310 IS=1,NS + IS1=IJU(IU)+IS-1 + IS2=IJU(IU)+IS + DO 290 J=1,5 + DP(1,J)=0.5*P(IS1,J) + IF(IS.EQ.1) DP(1,J)=P(IS1,J) + DP(2,J)=0.5*P(IS2,J) + IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J) + 290 CONTINUE + IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2) + IF(IS.EQ.NS) DP(2,5)=0. + DP(3,5)=DFOUR(1,1) + DP(4,5)=DFOUR(2,2) + DHKC=DFOUR(1,2) + IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(3,5)=0D0 + DP(4,5)=0D0 + DHKC=DFOUR(1,2) + ENDIF + DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) + DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.) + DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.) + IN1=N+NR+4*IS-3 + P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5)) + DO 300 J=1,4 + P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J) + P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J) + 300 CONTINUE + 310 CONTINUE + +C...Junction strings: initialize flavour, momentum and starting pos. + ISAV=I + MSTU91=MSTU(90) + 320 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN + PARU12=4.*PARU12 + PARU13=2.*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100) THEN + CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=ISAV + MSTU(90)=MSTU91 + IRANKJ=0 + IE(1)=K(N+1+(JT/2)*(NP-1),3) + IN(4)=N+NR+1 + IN(5)=IN(4)+1 + IN(6)=N+NR+4*NS+1 + DO 340 JQ=1,2 + DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4 + P(IN1,1)=2-JQ + P(IN1,2)=JQ-1 + P(IN1,3)=1. + 330 CONTINUE + 340 CONTINUE + KFL(1)=K(IJU(IU),2) + PX(1)=0. + PY(1)=0. + GAM(1)=0. + DO 350 J=1,5 + PJU(IU+3,J)=0. + 350 CONTINUE + +C...Junction strings: find initial transverse directions. + DO 360 J=1,4 + DP(1,J)=P(IN(4),J) + DP(2,J)=P(IN(4)+1,J) + DP(3,J)=0. + DP(4,J)=0. + 360 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1. + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1. + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1. + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1. + DHC12=DFOUR(1,2) + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 370 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(6),J)=DP(3,J) + P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + &DHCYX*DP(3,J)) + 370 CONTINUE + +C...Junction strings: produce new particle, origin. + 380 I=I+1 + IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IRANKJ=IRANKJ+1 + K(I,1)=1 + K(I,3)=IE(1) + K(I,4)=0 + K(I,5)=0 + +C...Junction strings: generate flavour, hadron, pT, z and Gamma. + 390 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2)) + IF(K(I,2).EQ.0) GOTO 320 + IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND. + &IABS(KFL(3)).GT.10) THEN + IF(RLU(0).GT.PARJ(19)) GOTO 390 + ENDIF + P(I,5)=ULMASS(K(I,2)) + CALL LUPTDI(KFL(1),PX(3),PY(3)) + PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2 + CALL LUZDIS(KFL(1),KFL(3),PR(1),Z) + IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND. + &MSTU(90).LT.8) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z) + DO 400 J=1,3 + IN(J)=IN(3+J) + 400 CONTINUE + +C...Junction strings: stepping within or from 'low' string region easy. + IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* + &P(IN(1),5)**2.GE.PR(1)) THEN + P(IN(1)+2,4)=Z*P(IN(1)+2,3) + P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2) + DO 410 J=1,4 + P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J) + 410 CONTINUE + GOTO 500 + ELSEIF(IN(1)+1.EQ.IN(2)) THEN + P(IN(2)+2,4)=P(IN(2)+2,3) + P(IN(2)+2,1)=1. + IN(2)=IN(2)+4 + IF(IN(2).GT.N+NR+4*NS) GOTO 320 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0. + IN(1)=IN(1)+4 + ENDIF + ENDIF + +C...Junction strings: find new transverse directions. + 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR. + &IN(1).GT.IN(2)) GOTO 320 + IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN + DO 430 J=1,4 + DP(1,J)=P(IN(1),J) + DP(2,J)=P(IN(2),J) + DP(3,J)=0. + DP(4,J)=0. + 430 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DHC12=DFOUR(1,2) + IF(DHC12.LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0. + IN(1)=IN(1)+4 + GOTO 420 + ENDIF + IN(3)=N+NR+4*NS+5 + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1. + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1. + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1. + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1. + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 440 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(3),J)=DP(3,J) + P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 440 CONTINUE +C...Express pT with respect to new axes, if sensible. + PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3))) + PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1)) + IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN + PX(3)=PXP + PY(3)=PYP + ENDIF + ENDIF + +C...Junction strings: sum up known four-momentum, coefficients for m2. + DO 470 J=1,4 + DHG(J)=0. + P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+ + &PY(3)*P(IN(3)+1,J) + DO 450 IN1=IN(4),IN(1)-4,4 + P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) + 450 CONTINUE + DO 460 IN2=IN(5),IN(2)-4,4 + P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) + 460 CONTINUE + 470 CONTINUE + DHM(1)=FOUR(I,I) + DHM(2)=2.*FOUR(I,IN(1)) + DHM(3)=2.*FOUR(I,IN(2)) + DHM(4)=2.*FOUR(IN(1),IN(2)) + +C...Junction strings: find coefficients for Gamma expression. + DO 490 IN2=IN(1)+1,IN(2),4 + DO 480 IN1=IN(1),IN2-1,4 + DHC=2.*FOUR(IN1,IN2) + DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC + IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC + IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC + IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC + 480 CONTINUE + 490 CONTINUE + +C...Junction strings: solve (m2, Gamma) equation system for energies. + DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3) + IF(ABS(DHS1).LT.1D-4) GOTO 320 + DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)* + &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3) + DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1)) + P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)- + &DHS2/DHS1) + IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 320 + P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/ + &(DHM(2)+DHM(4)*P(IN(2)+2,4)) + +C...Junction strings: step to new region if necessary. + IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN + P(IN(2)+2,4)=P(IN(2)+2,3) + P(IN(2)+2,1)=1. + IN(2)=IN(2)+4 + IF(IN(2).GT.N+NR+4*NS) GOTO 320 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0. + IN(1)=IN(1)+4 + ENDIF + GOTO 420 + ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0. + IN(1)=IN(1)+JS + GOTO 820 + ENDIF + +C...Junction strings: particle four-momentum, remainder, loop back. + 500 DO 510 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) + PJU(IU+3,J)=PJU(IU+3,J)+P(I,J) + 510 CONTINUE + IF(P(I,4).LT.P(I,5)) GOTO 320 + PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)- + &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) + IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN + KFL(1)=-KFL(3) + PX(1)=-PX(3) + PY(1)=-PY(3) + GAM(1)=GAM(3) + IF(IN(3).NE.IN(6)) THEN + DO 520 J=1,4 + P(IN(6),J)=P(IN(3),J) + P(IN(6)+1,J)=P(IN(3)+1,J) + 520 CONTINUE + ENDIF + DO 530 JQ=1,2 + IN(3+JQ)=IN(JQ) + P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) + P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4) + 530 CONTINUE + GOTO 380 + ENDIF + +C...Junction strings: save quantities left after each string. + IF(IABS(KFL(1)).GT.10) GOTO 320 + I=I-1 + KFJH(IU)=KFL(1) + DO 540 J=1,4 + PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J) + 540 CONTINUE + 550 CONTINUE + +C...Junction strings: put together to new effective string endpoint. + NJS(JT)=I-ISTA + KFJS(JT)=K(K(MJU(JT+2),3),2) + KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1 + IF(KFJH(1).EQ.KFJH(2)) KFLS=3 + IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)), + &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+ + &KFLS,KFJH(1)) + DO 560 J=1,4 + PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J) + PJS(JT+2,J)=PJU(4,J)+PJU(5,J) + 560 CONTINUE + PJS(JT,5)=SQRT(MAX(0.D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2- + &PJS(JT,3)**2)) + 570 CONTINUE + +C...Open versus closed strings. Choose breakup region for latter. + 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN + NS=MJU(2)-MJU(1) + NB=MJU(1)-N + ELSEIF(MJU(1).NE.0) THEN + NS=N+NR-MJU(1) + NB=MJU(1)-N + ELSEIF(MJU(2).NE.0) THEN + NS=MJU(2)-N + NB=1 + ELSEIF(IABS(K(N+1,2)).NE.21) THEN + NS=NR-1 + NB=1 + ELSE + NS=NR+1 + W2SUM=0. + DO 590 IS=1,NR + P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR)) + W2SUM=W2SUM+P(N+NR+IS,1) + 590 CONTINUE + W2RAN=RLU(0)*W2SUM + NB=0 + 600 NB=NB+1 + W2SUM=W2SUM-P(N+NR+NB,1) + IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600 + ENDIF + +C...Find longitudinal string directions (i.e. lightlike four-vectors). + DO 630 IS=1,NS + IS1=N+IS+NB-1-NR*((IS+NB-2)/NR) + IS2=N+IS+NB-NR*((IS+NB-1)/NR) + DO 610 J=1,5 + DP(1,J)=P(IS1,J) + IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J) + IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J) + DP(2,J)=P(IS2,J) + IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J) + IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J) + 610 CONTINUE + DP(3,5)=DFOUR(1,1) + DP(4,5)=DFOUR(2,2) + DHKC=DFOUR(1,2) + IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN + DP(3,5)=DP(1,5)**2 + DP(4,5)=DP(2,5)**2 + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2) + DHKC=DFOUR(1,2) + ENDIF + DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) + DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.) + DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.) + IN1=N+NR+4*IS-3 + P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5)) + DO 620 J=1,4 + P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J) + P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J) + 620 CONTINUE + 630 CONTINUE + +C...Begin initialization: sum up energy, set starting position. + ISAV=I + MSTU91=MSTU(90) + 640 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN + PARU12=4.*PARU12 + PARU13=2.*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100) THEN + CALL LUERRM(14,'(LUSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=ISAV + MSTU(90)=MSTU91 + DO 660 J=1,4 + P(N+NRS,J)=0. + DO 650 IS=1,NR + P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J) + 650 CONTINUE + 660 CONTINUE + DO 680 JT=1,2 + IRANK(JT)=0 + IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT) + IF(NS.GT.NR) IRANK(JT)=1 + IE(JT)=K(N+1+(JT/2)*(NP-1),3) + IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1) + IN(3*JT+2)=IN(3*JT+1)+1 + IN(3*JT+3)=N+NR+4*NS+2*JT-1 + DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4 + P(IN1,1)=2-JT + P(IN1,2)=JT-1 + P(IN1,3)=1. + 670 CONTINUE + 680 CONTINUE + +C...Initialize flavour and pT variables for open string. + IF(NS.LT.NR) THEN + PX(1)=0. + PY(1)=0. + IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1)) + PX(2)=-PX(1) + PY(2)=-PY(1) + DO 690 JT=1,2 + KFL(JT)=K(IE(JT),2) + IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT) + MSTJ(93)=1 + PMQ(JT)=ULMASS(KFL(JT)) + GAM(JT)=0. + 690 CONTINUE + +C...Closed string: random initial breakup flavour, pT and vertex. + ELSE + KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5) + CALL LUKFDI(KFL(3),0,KFL(1),KDUMP) + KFL(2)=-KFL(1) + IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN + KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1))) + ELSEIF(IABS(KFL(1)).GT.10) THEN + KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2))) + ENDIF + CALL LUPTDI(KFL(1),PX(1),PY(1)) + PX(2)=-PX(1) + PY(2)=-PY(1) + PR3=MIN(25.D0,0.1*P(N+NR+1,5)**2) + 700 CALL LUZDIS(KFL(1),KFL(2),PR3,Z) + ZR=PR3/(Z*P(N+NR+1,5)**2) + IF(ZR.GE.1.) GOTO 700 + DO 710 JT=1,2 + MSTJ(93)=1 + PMQ(JT)=ULMASS(KFL(JT)) + GAM(JT)=PR3*(1.-Z)/Z + IN1=N+NR+3+4*(JT/2)*(NS-1) + P(IN1,JT)=1.-Z + P(IN1,3-JT)=JT-1 + P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z + P(IN1+1,JT)=ZR + P(IN1+1,3-JT)=2-JT + P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR + 710 CONTINUE + ENDIF + +C...Find initial transverse directions (i.e. spacelike four-vectors). + DO 750 JT=1,2 + IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN + IN1=IN(3*JT+1) + IN3=IN(3*JT+3) + DO 720 J=1,4 + DP(1,J)=P(IN1,J) + DP(2,J)=P(IN1+1,J) + DP(3,J)=0. + DP(4,J)=0. + 720 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1. + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1. + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1. + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1. + DHC12=DFOUR(1,2) + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 730 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN3,J)=DP(3,J) + P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 730 CONTINUE + ELSE + DO 740 J=1,4 + P(IN3+2,J)=P(IN3,J) + P(IN3+3,J)=P(IN3+1,J) + 740 CONTINUE + ENDIF + 750 CONTINUE + +C...Remove energy used up in junction string fragmentation. + IF(MJU(1)+MJU(2).GT.0) THEN + DO 770 JT=1,2 + IF(NJS(JT).EQ.0) GOTO 770 + DO 760 J=1,4 + P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J) + 760 CONTINUE + 770 CONTINUE + ENDIF + +C...Produce new particle: side, origin. + 780 I=I+1 + IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + JT=1.5+RLU(0) + IF(IABS(KFL(3-JT)).GT.10) JT=3-JT + IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT + JR=3-JT + JS=3-2*JT + IRANK(JT)=IRANK(JT)+1 + K(I,1)=1 + K(I,3)=IE(JT) + K(I,4)=0 + K(I,5)=0 + +C...Generate flavour, hadron and pT. + 790 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2)) + IF(K(I,2).EQ.0) GOTO 640 + IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND. + &IABS(KFL(3)).GT.10) THEN + IF(RLU(0).GT.PARJ(19)) GOTO 790 + ENDIF + P(I,5)=ULMASS(K(I,2)) + CALL LUPTDI(KFL(JT),PX(3),PY(3)) + PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2 + +C...Final hadrons for small invariant mass. + MSTJ(93)=1 + PMQ(3)=ULMASS(KFL(3)) + PARJST=PARJ(33) + IF(MSTJ(11).EQ.2) PARJST=PARJ(34) + WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3) + IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN= + &WMIN-0.5*PARJ(36)*PMQ(3) + WREM2=FOUR(N+NRS,N+NRS) + IF(WREM2.LT.0.10) GOTO 640 + IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)), + &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 940 + +C...Choose z, which gives Gamma. Shift z for heavy flavours. + CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z) + IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND. + &MSTU(90).LT.8) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + KFL1A=IABS(KFL(1)) + KFL2A=IABS(KFL(2)) + IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), + &MOD(KFL2A/1000,10)).GE.4) THEN + PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + PW12=SQRT(MAX(0.D0,(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)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 940 + ENDIF + GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z) + DO 800 J=1,3 + IN(J)=IN(3*JT+J) + 800 CONTINUE + +C...Stepping within or from 'low' string region easy. + IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* + &P(IN(1),5)**2.GE.PR(JT)) THEN + P(IN(JT)+2,4)=Z*P(IN(JT)+2,3) + P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2) + DO 810 J=1,4 + P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J) + 810 CONTINUE + GOTO 900 + 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 640 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0. + IN(JT)=IN(JT)+4*JS + ENDIF + ENDIF + +C...Find new transverse directions (i.e. spacelike string vectors). + 820 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 640 + IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN + DO 830 J=1,4 + DP(1,J)=P(IN(1),J) + DP(2,J)=P(IN(2),J) + DP(3,J)=0. + DP(4,J)=0. + 830 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DHC12=DFOUR(1,2) + IF(DHC12.LE.1D-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 820 + ENDIF + IN(3)=N+NR+4*NS+5 + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1. + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1. + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1. + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1. + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 840 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(3),J)=DP(3,J) + P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 840 CONTINUE +C...Express pT with respect to new axes, if sensible. + PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)* + & FOUR(IN(3*JT+3)+1,IN(3))) + PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)* + & FOUR(IN(3*JT+3)+1,IN(3)+1)) + IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN + PX(3)=PXP + PY(3)=PYP + ENDIF + ENDIF + +C...Sum up known four-momentum. Gives coefficients for m2 expression. + DO 870 J=1,4 + DHG(J)=0. + P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+ + &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J) + DO 850 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS + P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) + 850 CONTINUE + DO 860 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS + P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) + 860 CONTINUE + 870 CONTINUE + DHM(1)=FOUR(I,I) + DHM(2)=2.*FOUR(I,IN(1)) + DHM(3)=2.*FOUR(I,IN(2)) + DHM(4)=2.*FOUR(IN(1),IN(2)) + +C...Find coefficients for Gamma expression. + DO 890 IN2=IN(1)+1,IN(2),4 + DO 880 IN1=IN(1),IN2-1,4 + DHC=2.*FOUR(IN1,IN2) + DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC + IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC + IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC + IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC + 880 CONTINUE + 890 CONTINUE + +C...Solve (m2, Gamma) equation system for energies taken. + DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1) + IF(ABS(DHS1).LT.1D-4) GOTO 640 + DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)* + &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1) + DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1)) + P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)- + &DHS2/DHS1) + IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 640 + P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/ + &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4)) + +C...Step to new region if necessary. + IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN + P(IN(JR)+2,4)=P(IN(JR)+2,3) + P(IN(JR)+2,JT)=1. + IN(JR)=IN(JR)+4*JS + IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640 + IF(FOUR(IN(1),IN(2)).LE.1D-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 820 + 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 820 + ENDIF + +C...Four-momentum of particle. Remaining quantities. Loop back. + 900 DO 910 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) + P(N+NRS,J)=P(N+NRS,J)-P(I,J) + 910 CONTINUE + IF(P(I,4).LT.P(I,5)) GOTO 640 + KFL(JT)=-KFL(3) + PMQ(JT)=PMQ(3) + PX(JT)=-PX(3) + PY(JT)=-PY(3) + GAM(JT)=GAM(3) + IF(IN(3).NE.IN(3*JT+3)) THEN + DO 920 J=1,4 + P(IN(3*JT+3),J)=P(IN(3),J) + P(IN(3*JT+3)+1,J)=P(IN(3)+1,J) + 920 CONTINUE + ENDIF + DO 930 JQ=1,2 + IN(3*JT+JQ)=IN(JQ) + P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) + P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4) + 930 CONTINUE + GOTO 780 + +C...Final hadron: side, flavour, hadron, mass. + 940 I=I+1 + K(I,1)=1 + K(I,3)=IE(JR) + K(I,4)=0 + K(I,5)=0 + CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2)) + IF(K(I,2).EQ.0) GOTO 640 + P(I,5)=ULMASS(K(I,2)) + PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + +C...Final two hadrons: find common setup of four-vectors. + JQ=1 + IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)* + &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2 + DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2)) + DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12 + DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12 + IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN + PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ) + PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ) + PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS* + & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2 + ENDIF + +C...Solve kinematics for final two hadrons, if possible. + WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2 + FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2) + IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 200 + IF(FD.GE.1.) GOTO 640 + FA=WREM2+PR(JT)-PR(JR) + IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-50.D0,LOG(FD)*PARJ(38)* + &(PR(1)+PR(2))**2)) + IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(39) + FB=SIGN(SQRT(MAX(0.D0,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV)) + KFL1A=IABS(KFL(1)) + KFL2A=IABS(KFL(2)) + IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), + &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.D0,FA**2- + &4.*WREM2*PR(JT))),DBLE(JS)) + DO 950 J=1,4 + P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))* + &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+ + &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2 + P(I,J)=P(N+NRS,J)-P(I-1,J) + 950 CONTINUE + IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640 + +C...Mark jets as fragmented and give daughter pointers. + N=I-NRS+1 + DO 960 I=NSAV+1,NSAV+NP + IM=K(I,3) + K(IM,1)=K(IM,1)+10 + IF(MSTU(16).NE.2) THEN + K(IM,4)=NSAV+1 + K(IM,5)=NSAV+1 + ELSE + K(IM,4)=NSAV+2 + K(IM,5)=N + ENDIF + 960 CONTINUE + +C...Document string system. Move up particles. + NSAV=NSAV+1 + K(NSAV,1)=11 + K(NSAV,2)=92 + K(NSAV,3)=IP + K(NSAV,4)=NSAV+1 + K(NSAV,5)=N + DO 970 J=1,4 + P(NSAV,J)=DPS(J) + V(NSAV,J)=V(IP,J) + 970 CONTINUE + P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) + V(NSAV,5)=0. + DO 990 I=NSAV+1,N + DO 980 J=1,5 + K(I,J)=K(I+NRS-1,J) + P(I,J)=P(I+NRS-1,J) + V(I,J)=0. + 980 CONTINUE + 990 CONTINUE + MSTU91=MSTU(90) + DO 1000 IZ=MSTU90+1,MSTU91 + MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N + PARU9T(IZ)=PARU(90+IZ) + 1000 CONTINUE + MSTU(90)=MSTU90 + +C...Order particles in rank along the chain. Update mother pointer. + DO 1020 I=NSAV+1,N + DO 1010 J=1,5 + K(I-NSAV+N,J)=K(I,J) + P(I-NSAV+N,J)=P(I,J) + 1010 CONTINUE + 1020 CONTINUE + I1=NSAV + DO 1050 I=N+1,2*N-NSAV + IF(K(I,3).NE.IE(1)) GOTO 1050 + I1=I1+1 + DO 1030 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + 1030 CONTINUE + IF(MSTU(16).NE.2) K(I1,3)=NSAV + DO 1040 IZ=MSTU90+1,MSTU91 + IF(MSTU9T(IZ).EQ.I) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU9T(IZ) + ENDIF + 1040 CONTINUE + 1050 CONTINUE + DO 1080 I=2*N-NSAV,N+1,-1 + IF(K(I,3).EQ.IE(1)) GOTO 1080 + I1=I1+1 + DO 1060 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + 1060 CONTINUE + IF(MSTU(16).NE.2) K(I1,3)=NSAV + DO 1070 IZ=MSTU90+1,MSTU91 + IF(MSTU9T(IZ).EQ.I) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU9T(IZ) + ENDIF + 1070 CONTINUE + 1080 CONTINUE + +C...Boost back particle system. Set production vertices. + IF(MBST.EQ.0) THEN + MSTU(33)=1 + CALL LUDBRB(NSAV+1,N,0.D0,0.D0,DPS(1)/DPS(4),DPS(2)/DPS(4), + & DPS(3)/DPS(4)) + ELSE + DO 1090 I=NSAV+1,N + HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 + IF(P(I,3).GT.0.) THEN + HHPEZ=(P(I,4)+P(I,3))*HHBZ + P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ) + ELSE + HHPEZ=(P(I,4)-P(I,3))/HHBZ + P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ) + ENDIF + 1090 CONTINUE + ENDIF + DO 1110 I=NSAV+1,N + DO 1100 J=1,4 + V(I,J)=V(IP,J) + 1100 CONTINUE + 1110 CONTINUE + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUINDF + SUBROUTINE LUINDF(IP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to handle the fragmentation of a jet system (or a single +C...jet) according to independent fragmentation models. +C IMPLICIT DOUBLE PRECISION(D) + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3), + &KFLO(2),PXO(2),PYO(2),WO(2) + +C...Reset counters. Identify parton system and take copy. Check flavour. + NSAV=N + MSTU90=MSTU(90) + NJET=0 + KQSUM=0 + DO 100 J=1,5 + DPS(J)=0. + 100 CONTINUE + I=IP-1 + 110 I=I+1 + IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN + CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 110 + NJET=NJET+1 + IF(KQ.NE.2) KQSUM=KQSUM+KQ + DO 120 J=1,5 + K(NSAV+NJET,J)=K(I,J) + P(NSAV+NJET,J)=P(I,J) + DPS(J)=DPS(J)+P(I,J) + 120 CONTINUE + K(NSAV+NJET,3)=I + IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND. + &K(I+1,1).EQ.2)) GOTO 110 + IF(NJET.NE.1.AND.KQSUM.NE.0) THEN + CALL LUERRM(12,'(LUINDF:) unphysical flavour combination') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Boost copied system to CM frame. Find CM energy and sum flavours. + IF(NJET.NE.1) THEN + MSTU(33)=1 + CALL LUDBRB(NSAV+1,NSAV+NJET,0.D0,0.D0,-DPS(1)/DPS(4), + & -DPS(2)/DPS(4),-DPS(3)/DPS(4)) + ENDIF + PECM=0. + DO 130 J=1,3 + NFI(J)=0 + 130 CONTINUE + DO 140 I=NSAV+1,NSAV+NJET + PECM=PECM+P(I,4) + KFA=IABS(K(I,2)) + IF(KFA.LE.3) THEN + NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2)) + ELSEIF(KFA.GT.1000) THEN + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2)) + IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2)) + ENDIF + 140 CONTINUE + +C...Loop over attempts made. Reset counters. + NTRY=0 + 150 NTRY=NTRY+1 + IF(NTRY.GT.200) THEN + CALL LUERRM(14,'(LUINDF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + N=NSAV+NJET + MSTU(90)=MSTU90 + DO 160 J=1,3 + NFL(J)=NFI(J) + IFET(J)=0 + KFLF(J)=0 + 160 CONTINUE + +C...Loop over jets to be fragmented. + DO 230 IP1=NSAV+1,NSAV+NJET + MSTJ(91)=0 + NSAV1=N + MSTU91=MSTU(90) + +C...Initial flavour and momentum values. Jet along +z axis. + KFLH=IABS(K(IP1,2)) + IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10) + KFLO(2)=0 + WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2) + +C...Initial values for quark or diquark jet. + 170 IF(IABS(K(IP1,2)).NE.21) THEN + NSTR=1 + KFLO(1)=K(IP1,2) + CALL LUPTDI(0,PXO(1),PYO(1)) + WO(1)=WF + +C...Initial values for gluon treated like random quark jet. + ELSEIF(MSTJ(2).LE.2) THEN + NSTR=1 + IF(MSTJ(2).EQ.2) MSTJ(91)=1 + KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5) + CALL LUPTDI(0,PXO(1),PYO(1)) + WO(1)=WF + +C...Initial values for gluon treated like quark-antiquark jet pair, +C...sharing energy according to Altarelli-Parisi splitting function. + ELSE + NSTR=2 + IF(MSTJ(2).EQ.4) MSTJ(91)=1 + KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5) + KFLO(2)=-KFLO(1) + CALL LUPTDI(0,PXO(1),PYO(1)) + PXO(2)=-PXO(1) + PYO(2)=-PYO(1) + WO(1)=WF*RLU(0)**(1./3.) + WO(2)=WF-WO(1) + ENDIF + +C...Initial values for rank, flavour, pT and W+. + DO 220 ISTR=1,NSTR + 180 I=N + MSTU(90)=MSTU91 + IRANK=0 + KFL1=KFLO(ISTR) + PX1=PXO(ISTR) + PY1=PYO(ISTR) + W=WO(ISTR) + +C...New hadron. Generate flavour and hadron species. + 190 I=I+1 + IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN + CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IRANK=IRANK+1 + K(I,1)=1 + K(I,3)=IP1 + K(I,4)=0 + K(I,5)=0 + 200 CALL LUKFDI(KFL1,0,KFL2,K(I,2)) + IF(K(I,2).EQ.0) GOTO 180 + IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND. + &IABS(KFL2).GT.10) THEN + IF(RLU(0).GT.PARJ(19)) GOTO 200 + ENDIF + +C...Find hadron mass. Generate four-momentum. + P(I,5)=ULMASS(K(I,2)) + CALL LUPTDI(KFL1,PX2,PY2) + P(I,1)=PX1+PX2 + P(I,2)=PY1+PY2 + PR=P(I,5)**2+P(I,1)**2+P(I,2)**2 + CALL LUZDIS(KFL1,KFL2,PR,Z) + MZSAV=0 + IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN + MZSAV=1 + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + P(I,3)=0.5*(Z*W-PR/MAX(1D-4,Z*W)) + P(I,4)=0.5*(Z*W+PR/MAX(1D-4,Z*W)) + IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND. + &P(I,3).LE.0.001) THEN + IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180 + P(I,3)=0.0001 + P(I,4)=SQRT(PR) + Z=P(I,4)/W + ENDIF + +C...Remaining flavour and momentum. + KFL1=-KFL2 + PX1=-PX2 + PY1=-PY2 + W=(1.-Z)*W + DO 210 J=1,5 + V(I,J)=0. + 210 CONTINUE + +C...Check if pL acceptable. Go back for new hadron if enough energy. + IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) THEN + I=I-1 + IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1 + ENDIF + IF(W.GT.PARJ(31)) GOTO 190 + N=I + 220 CONTINUE + IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32) + IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170 + +C...Rotate jet to new direction. + THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2)) + PHI=ULANGL(P(IP1,1),P(IP1,2)) + MSTU(33)=1 + CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0) + K(K(IP1,3),4)=NSAV1+1 + K(K(IP1,3),5)=N + +C...End of jet generation loop. Skip conservation in some cases. + 230 CONTINUE + IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490 + IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150 + +C...Subtract off produced hadron flavours, finished if zero. + DO 240 I=NSAV+NJET+1,N + KFA=IABS(K(I,2)) + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + KFLC=MOD(KFA/10,10) + IF(KFLA.EQ.0) THEN + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB + ELSE + IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2)) + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2)) + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2)) + ENDIF + 240 CONTINUE + NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ + &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 + IF(NREQ.EQ.0) GOTO 320 + +C...Take away flavour of low-momentum particles until enough freedom. + NREM=0 + 250 IREM=0 + P2MIN=PECM**2 + DO 260 I=NSAV+NJET+1,N + P2=P(I,1)**2+P(I,2)**2+P(I,3)**2 + IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I + IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2 + 260 CONTINUE + IF(IREM.EQ.0) GOTO 150 + K(IREM,1)=7 + KFA=IABS(K(IREM,2)) + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + KFLC=MOD(KFA/10,10) + IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8 + IF(K(IREM,1).EQ.8) GOTO 250 + IF(KFLA.EQ.0) THEN + ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN + ELSE + IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2)) + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2)) + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2)) + ENDIF + NREM=NREM+1 + NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ + &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 + IF(NREQ.GT.NREM) GOTO 250 + DO 270 I=NSAV+NJET+1,N + IF(K(I,1).EQ.8) K(I,1)=1 + 270 CONTINUE + +C...Find combination of existing and new flavours for hadron. + 280 NFET=2 + IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3 + IF(NREQ.LT.NREM) NFET=1 + IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0 + DO 290 J=1,NFET + IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0) + KFLF(J)=ISIGN(1,NFL(1)) + IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2)) + IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3)) + 290 CONTINUE + IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0)) + &GOTO 280 + IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR. + &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3) + &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280 + IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0)) + IF(NFET.EQ.0) KFLF(2)=-KFLF(1) + IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1)) + IF(NFET.LE.2) KFLF(3)=0 + IF(KFLF(3).NE.0) THEN + KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+ + & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1)) + IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.) + & KFLFC=KFLFC+ISIGN(2,KFLFC) + ELSE + KFLFC=KFLF(1) + ENDIF + CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF) + IF(KF.EQ.0) GOTO 280 + DO 300 J=1,MAX(2,NFET) + NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J)) + 300 CONTINUE + +C...Store hadron at random among free positions. + NPOS=MIN(1+INT(RLU(0)*NREM),NREM) + DO 310 I=NSAV+NJET+1,N + IF(K(I,1).EQ.7) NPOS=NPOS-1 + IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310 + K(I,1)=1 + K(I,2)=KF + P(I,5)=ULMASS(K(I,2)) + P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + 310 CONTINUE + NREM=NREM-1 + NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ + &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 + IF(NREM.GT.0) GOTO 280 + +C...Compensate for missing momentum in global scheme (3 options). + 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN + DO 340 J=1,3 + PSI(J)=0. + DO 330 I=NSAV+NJET+1,N + PSI(J)=PSI(J)+P(I,J) + 330 CONTINUE + 340 CONTINUE + PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2 + PWS=0. + DO 350 I=NSAV+NJET+1,N + IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4) + IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ + & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) + IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1. + 350 CONTINUE + DO 370 I=NSAV+NJET+1,N + IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4) + IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ + & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) + IF(MOD(MSTJ(3),5).EQ.3) PW=1. + DO 360 J=1,3 + P(I,J)=P(I,J)-PSI(J)*PW/PWS + 360 CONTINUE + P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + 370 CONTINUE + +C...Compensate for missing momentum withing each jet separately. + ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN + DO 390 I=N+1,N+NJET + K(I,1)=0 + DO 380 J=1,5 + P(I,J)=0. + 380 CONTINUE + 390 CONTINUE + DO 410 I=NSAV+NJET+1,N + IR1=K(I,3) + IR2=N+IR1-NSAV + K(IR2,1)=K(IR2,1)+1 + PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ + & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) + DO 400 J=1,3 + P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J) + 400 CONTINUE + P(IR2,4)=P(IR2,4)+P(I,4) + P(IR2,5)=P(IR2,5)+PLS + 410 CONTINUE + PSS=0. + DO 420 I=N+1,N+NJET + IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2)) + 420 CONTINUE + DO 440 I=NSAV+NJET+1,N + IR1=K(I,3) + IR2=N+IR1-NSAV + PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ + & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) + DO 430 J=1,3 + P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS* + & P(IR1,J) + 430 CONTINUE + P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + 440 CONTINUE + ENDIF + +C...Scale momenta for energy conservation. + IF(MOD(MSTJ(3),5).NE.0) THEN + PMS=0. + PES=0. + PQS=0. + DO 450 I=NSAV+NJET+1,N + PMS=PMS+P(I,5) + PES=PES+P(I,4) + PQS=PQS+P(I,5)**2/P(I,4) + 450 CONTINUE + IF(PMS.GE.PECM) GOTO 150 + NECO=0 + 460 NECO=NECO+1 + PFAC=(PECM-PQS)/(PES-PQS) + PES=0. + PQS=0. + DO 480 I=NSAV+NJET+1,N + DO 470 J=1,3 + P(I,J)=PFAC*P(I,J) + 470 CONTINUE + 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) + PQS=PQS+P(I,5)**2/P(I,4) + 480 CONTINUE + IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460 + ENDIF + +C...Origin of produced particles and parton daughter pointers. + 490 DO 500 I=NSAV+NJET+1,N + IF(MSTU(16).NE.2) K(I,3)=NSAV+1 + IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3) + 500 CONTINUE + DO 510 I=NSAV+1,NSAV+NJET + I1=K(I,3) + K(I1,1)=K(I1,1)+10 + IF(MSTU(16).NE.2) THEN + K(I1,4)=NSAV+1 + K(I1,5)=NSAV+1 + ELSE + K(I1,4)=K(I1,4)-NJET+1 + K(I1,5)=K(I1,5)-NJET+1 + IF(K(I1,5).LT.K(I1,4)) THEN + K(I1,4)=0 + K(I1,5)=0 + ENDIF + ENDIF + 510 CONTINUE + +C...Document independent fragmentation system. Remove copy of jets. + NSAV=NSAV+1 + K(NSAV,1)=11 + K(NSAV,2)=93 + K(NSAV,3)=IP + K(NSAV,4)=NSAV+1 + K(NSAV,5)=N-NJET+1 + DO 520 J=1,4 + P(NSAV,J)=DPS(J) + V(NSAV,J)=V(IP,J) + 520 CONTINUE + P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) + V(NSAV,5)=0. + DO 540 I=NSAV+NJET,N + DO 530 J=1,5 + K(I-NJET+1,J)=K(I,J) + P(I-NJET+1,J)=P(I,J) + V(I-NJET+1,J)=V(I,J) + 530 CONTINUE + 540 CONTINUE + N=N-NJET+1 + DO 550 IZ=MSTU90+1,MSTU(90) + MSTU(90+IZ)=MSTU(90+IZ)-NJET+1 + 550 CONTINUE + +C...Boost back particle system. Set production vertices. + IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.D0,0.D0,DPS(1)/DPS(4), + &DPS(2)/DPS(4),DPS(3)/DPS(4)) + DO 570 I=NSAV+1,N + DO 560 J=1,4 + V(I,J)=V(IP,J) + 560 CONTINUE + 570 CONTINUE + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUDECY + SUBROUTINE LUDECY(IP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to handle the decay of unstable particles. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/ + DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3), + &WTCOR(10),PTAU(4),PCMTAU(4) +C DOUBLE PRECISION DBETAU(3) + DIMENSION DBETAU(3) + DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./ + +C...Functions: momentum in two-particle decays, four-product and +C...matrix element times phase space in weak decays. + PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A) + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))* + &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA) + +C...Initial values. + NTRY=0 + NSAV=N + KFA=IABS(K(IP,2)) + KFS=ISIGN(1,K(IP,2)) + KC=LUCOMP(KFA) + MSTJ(92)=0 + +C...Choose lifetime and determine decay vertex. + IF(K(IP,1).EQ.5) THEN + V(IP,5)=0. + ELSEIF(K(IP,1).NE.4) THEN + V(IP,5)=-PMAS(KC,4)*LOG(RLU(0)) + ENDIF + DO 100 J=1,4 + VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5) + 100 CONTINUE + +C...Determine whether decay allowed or not. + MOUT=0 + IF(MSTJ(22).EQ.2) THEN + IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1 + ELSEIF(MSTJ(22).EQ.3) THEN + IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 + ELSEIF(MSTJ(22).EQ.4) THEN + IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 + IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 + ENDIF + IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN + K(IP,1)=4 + RETURN + ENDIF + +C...Interface to external tau decay library (for tau polarization). + IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN + +C...Starting values for pointers and momenta. + ITAU=IP + DO 110 J=1,4 + PTAU(J)=P(ITAU,J) + PCMTAU(J)=P(ITAU,J) + 110 CONTINUE + +C...Iterate to find position and code of mother of tau. + IMTAU=ITAU + 120 IMTAU=K(IMTAU,3) + + IF(IMTAU.EQ.0) THEN +C...If no known origin then impossible to do anything further. + KFORIG=0 + IORIG=0 + + ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN +C...If tau -> tau + gamma then add gamma energy and loop. + IF(K(K(IMTAU,4),2).EQ.22) THEN + DO 130 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J) + 130 CONTINUE + ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN + DO 140 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J) + 140 CONTINUE + ENDIF + GOTO 120 + + ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN +C...If coming from weak decay of hadron then W is not stored in record, +C...but can be reconstructed by adding neutrino momentum. + KFORIG=-ISIGN(24,K(ITAU,2)) + IORIG=0 + DO 160 II=K(IMTAU,4),K(IMTAU,5) + IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN + DO 150 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(II,J) + 150 CONTINUE + ENDIF + 160 CONTINUE + + ELSE +C...If coming from resonance decay then find latest copy of this +C...resonance (may not completely agree). + KFORIG=K(IMTAU,2) + IORIG=IMTAU + DO 170 II=IMTAU+1,IP-1 + IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND. + & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II + 170 CONTINUE + DO 180 J=1,4 + PCMTAU(J)=P(IORIG,J) + 180 CONTINUE + ENDIF + +C...Boost tau to rest frame of production process (where known) +C...and rotate it to sit along +z axis. + DO 190 J=1,3 + DBETAU(J)=PCMTAU(J)/PCMTAU(4) + 190 CONTINUE + IF(KFORIG.NE.0) CALL LUDBRB(ITAU,ITAU,0.D0,0.D0,-DBETAU(1), + & -DBETAU(2),-DBETAU(3)) + PHITAU=ULANGL(P(ITAU,1),P(ITAU,2)) + CALL LUDBRB(ITAU,ITAU,0.D0,-PHITAU,0D0,0D0,0D0) + THETAU=ULANGL(P(ITAU,3),P(ITAU,1)) + CALL LUDBRB(ITAU,ITAU,-THETAU,0.D0,0D0,0D0,0D0) + +C...Call tau decay routine (if meaningful) and fill extra info. + IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN + CALL LUTAUD(ITAU,IORIG,KFORIG,NDECAY) + DO 200 II=NSAV+1,NSAV+NDECAY + K(II,1)=1 + K(II,3)=IP + K(II,4)=0 + K(II,5)=0 + 200 CONTINUE + N=NSAV+NDECAY + ENDIF + +C...Boost back decay tau and decay products. + DO 210 J=1,4 + P(ITAU,J)=PTAU(J) + 210 CONTINUE + IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN + CALL LUDBRB(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0) + IF(KFORIG.NE.0) CALL LUDBRB(NSAV+1,N,0.D0,0.D0,DBETAU(1), + & DBETAU(2),DBETAU(3)) + +C...Skip past ordinary tau decay treatment. + MMAT=0 + MBST=0 + ND=0 + GOTO 660 + ENDIF + ENDIF + +C...B-B~ mixing: flip sign of meson appropriately. + MMIX=0 + IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN + XBBMIX=PARJ(76) + IF(KFA.EQ.531) XBBMIX=PARJ(77) + IF(SIN(0.5*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.RLU(0)) MMIX=1 + IF(MMIX.EQ.1) KFS=-KFS + ENDIF + +C...Check existence of decay channels. Particle/antiparticle rules. + KCA=KC + IF(MDCY(KC,2).GT.0) THEN + MDMDCY=MDME(MDCY(KC,2),2) + IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY + ENDIF + IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN + CALL LUERRM(9,'(LUDECY:) no decay channel defined') + RETURN + ENDIF + IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS + IF(KCHG(KC,3).EQ.0) THEN + KFSP=1 + KFSN=0 + IF(RLU(0).GT.0.5) KFS=-KFS + ELSEIF(KFS.GT.0) THEN + KFSP=1 + KFSN=0 + ELSE + KFSP=0 + KFSN=1 + ENDIF + +C...Sum branching ratios of allowed decay channels. + 220 NOPE=0 + BRSU=0. + DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1 + IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. + &KFSN*MDME(IDL,1).NE.3) GOTO 230 + IF(MDME(IDL,2).GT.100) GOTO 230 + NOPE=NOPE+1 + BRSU=BRSU+BRAT(IDL) + 230 CONTINUE + IF(NOPE.EQ.0) THEN + CALL LUERRM(2,'(LUDECY:) all decay channels closed by user') + RETURN + ENDIF + +C...Select decay channel among allowed ones. + 240 RBR=BRSU*RLU(0) + IDL=MDCY(KCA,2)-1 + 250 IDL=IDL+1 + IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. + &KFSN*MDME(IDL,1).NE.3) THEN + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 + ELSEIF(MDME(IDL,2).GT.100) THEN + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 + ELSE + IDC=IDL + RBR=RBR-BRAT(IDL) + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 250 + ENDIF + +C...Start readout of decay channel: matrix element, reset counters. + MMAT=MDME(IDC,2) + 260 NTRY=NTRY+1 + IF(NTRY.GT.1000) THEN + CALL LUERRM(14,'(LUDECY:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=N + NP=0 + NQ=0 + MBST=0 + IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1 + DO 270 J=1,4 + PV(1,J)=0. + IF(MBST.EQ.0) PV(1,J)=P(IP,J) + 270 CONTINUE + IF(MBST.EQ.1) PV(1,4)=P(IP,5) + PV(1,5)=P(IP,5) + PS=0. + PSQ=0. + MREM=0 + MHADDY=0 + IF(KFA.GT.80) MHADDY=1 + +C...Read out decay products. Convert to standard flavour code. + JTMAX=5 + IF(MDME(IDC+1,2).EQ.101) JTMAX=10 + DO 280 JT=1,JTMAX + IF(JT.LE.5) KP=KFDP(IDC,JT) + IF(JT.GE.6) KP=KFDP(IDC+1,JT-5) + IF(KP.EQ.0) GOTO 280 + KPA=IABS(KP) + KCP=LUCOMP(KPA) + IF(KPA.GT.80) MHADDY=1 + IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN + KFP=KP + ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN + KFP=KFS*KP + ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN + KFP=-KFS*MOD(KFA/10,10) + ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN + KFP=KFS*(100*MOD(KFA/10,100)+3) + ELSEIF(KPA.EQ.81) THEN + KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1) + ELSEIF(KP.EQ.82) THEN + CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP) + IF(KFP.EQ.0) GOTO 260 + MSTJ(93)=1 + IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 260 + ELSEIF(KP.EQ.-82) THEN + KFP=-KFP + IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP) + ENDIF + IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP) + +C...Add decay product to event record or to quark flavour list. + KFPA=IABS(KFP) + KQP=KCHG(KCP,2) + IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN + NQ=NQ+1 + KFLO(NQ)=KFP + MSTJ(93)=2 + PSQ=PSQ+ULMASS(KFLO(NQ)) + ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND. + &MOD(NQ,2).EQ.1) THEN + NQ=NQ-1 + PS=PS-P(I,5) + K(I,1)=1 + KFI=K(I,2) + CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2)) + IF(K(I,2).EQ.0) GOTO 260 + MSTJ(93)=1 + P(I,5)=ULMASS(K(I,2)) + PS=PS+P(I,5) + ELSE + I=I+1 + NP=NP+1 + IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1 + IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1 + K(I,1)=1+MOD(NQ,2) + IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2 + IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1 + K(I,2)=KFP + K(I,3)=IP + K(I,4)=0 + K(I,5)=0 + P(I,5)=ULMASS(KFP) + IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32) + PS=PS+P(I,5) + ENDIF + 280 CONTINUE + +C...Check masses for resonance decays. + IF(MHADDY.EQ.0) THEN + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240 + ENDIF + +C...Choose decay multiplicity in phase space model. + 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN + PSP=PS + CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0)) + IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63) + 300 NTRY=NTRY+1 + IF(NTRY.GT.1000) THEN + CALL LUERRM(14,'(LUDECY:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(MMAT.LE.20) THEN + GAUSS=SQRT(-2.*CNDE*LOG(MAX(1D-10,RLU(0))))* + & SIN(PARU(2)*RLU(0)) + ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS + IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300 + IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300 + IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300 + IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300 + ELSE + ND=MMAT-20 + ENDIF + +C...Form hadrons from flavour content. + DO 310 JT=1,4 + KFL1(JT)=KFLO(JT) + 310 CONTINUE + IF(ND.EQ.NP+NQ/2) GOTO 330 + DO 320 I=N+NP+1,N+ND-NQ/2 + JT=1+INT((NQ-1)*RLU(0)) + CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2)) + IF(K(I,2).EQ.0) GOTO 300 + KFL1(JT)=-KFL2 + 320 CONTINUE + 330 JT=2 + JT2=3 + JT3=4 + IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4 + IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))* + & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3 + IF(JT.EQ.3) JT2=2 + IF(JT.EQ.4) JT3=2 + CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2)) + IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300 + IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2)) + IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300 + +C...Check that sum of decay product masses not too large. + PS=PSP + DO 340 I=N+NP+1,N+ND + K(I,1)=1 + K(I,3)=IP + K(I,4)=0 + K(I,5)=0 + P(I,5)=ULMASS(K(I,2)) + PS=PS+P(I,5) + 340 CONTINUE + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300 + +C...Rescale energy to subtract off spectator quark mass. + ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45) + &.AND.NP.GE.3) THEN + PS=PS-P(N+NP,5) + PQT=(P(N+NP,5)+PARJ(65))/PV(1,5) + DO 350 J=1,5 + P(N+NP,J)=PQT*PV(1,J) + PV(1,J)=(1.-PQT)*PV(1,J) + 350 CONTINUE + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 + ND=NP-1 + MREM=1 + +C...Phase space factors imposed in W decay. + ELSEIF(MMAT.EQ.46) THEN + MSTJ(93)=1 + PSMC=ULMASS(K(N+1,2)) + MSTJ(93)=1 + PSMC=PSMC+ULMASS(K(N+2,2)) + IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 240 + HR1=(P(N+1,5)/PV(1,5))**2 + HR2=(P(N+2,5)/PV(1,5))**2 + IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2) + & .LT.2.*RLU(0)) GOTO 240 + ND=NP + +C...Fully specified final state: check mass broadening effects. + ELSE + IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260 + ND=NP + ENDIF + +C...Select W mass in decay Q -> W + q, without W propagator. + IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN + HLQ=(PARJ(32)/PV(1,5))**2 + HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2 + HRQ=(P(N+2,5)/PV(1,5))**2 + 360 HW=HLQ+RLU(0)*(HUQ-HLQ) + IF(HMEPS(HW).LT.RLU(0)) GOTO 360 + P(N+1,5)=PV(1,5)*SQRT(HW) + +C...Ditto, including W propagator. Divide mass range into three regions. + ELSEIF(MMAT.EQ.45) THEN + HQW=(PV(1,5)/PMAS(24,1))**2 + HLW=(PARJ(32)/PMAS(24,1))**2 + HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2 + HRQ=(P(N+2,5)/PV(1,5))**2 + HG=PMAS(24,2)/PMAS(24,1) + HATL=ATAN((HLW-1.)/HG) + HM=MIN(1.D0,HUW-0.001) + HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2) + 370 HM=HM-HG + HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2) + IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN + HMV1=HMV2 + GOTO 370 + ENDIF + HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2) + HM1=1.-SQRT(1./HMV-HG**2) + IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN + HM=HM1 + ELSEIF(HMV2.LE.HMV1) THEN + HM=MAX(HLW,HM-MIN(0.1D0,1.-HM)) + ENDIF + HATM=ATAN((HM-1.)/HG) + HWT1=(HATM-HATL)/HG + HWT2=HMV*(MIN(1.D0,HUW)-HM) + HWT3=0. + IF(HUW.GT.1.) THEN + HATU=ATAN((HUW-1.)/HG) + HMP1=HMEPS(1./HQW) + HWT3=HMP1*HATU/HG + ENDIF + +C...Select mass region and W mass there. Accept according to weight. + 380 HREG=RLU(0)*(HWT1+HWT2+HWT3) + IF(HREG.LE.HWT1) THEN + HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL)) + HACC=HMEPS(HW/HQW) + ELSEIF(HREG.LE.HWT1+HWT2) THEN + HW=HM+RLU(0)*(MIN(1.D0,HUW)-HM) + HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV + ELSE + HW=1.+HG*TAN(RLU(0)*HATU) + HACC=HMEPS(HW/HQW)/HMP1 + ENDIF + IF(HACC.LT.RLU(0)) GOTO 380 + P(N+1,5)=PMAS(24,1)*SQRT(HW) + ENDIF + +C...Determine position of grandmother, number of sisters, Q -> W sign. + NM=0 + KFAS=0 + MSGN=0 + IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN + IM=K(IP,3) + IF(IM.LT.0.OR.IM.GE.IP) IM=0 + IF(MMAT.EQ.46.AND.MSTJ(27).EQ.1) THEN + IM=0 + ELSEIF(MMAT.EQ.46.AND.MSTJ(27).GE.2.AND.IM.NE.0) THEN + IF(K(IM,2).EQ.94) THEN + IM=K(K(IM,3),3) + IF(IM.LT.0.OR.IM.GE.IP) IM=0 + ENDIF + ENDIF + IF(IM.NE.0) KFAM=IABS(K(IM,2)) + IF(IM.NE.0.AND.MMAT.EQ.3) THEN + DO 390 IL=MAX(IP-2,IM+1),MIN(IP+2,N) + IF(K(IL,3).EQ.IM) NM=NM+1 + IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL + 390 CONTINUE + IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR. + & MOD(KFAM/1000,10).NE.0) NM=0 + IF(NM.EQ.2) THEN + KFAS=IABS(K(ISIS,2)) + IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR. + & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0 + ENDIF + ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN + MSGN=ISIGN(1,K(IM,2)*K(IP,2)) + IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN= + & MSGN*(-1)**MOD(KFAM/100,10) + ENDIF + ENDIF + +C...Kinematics of one-particle decays. + IF(ND.EQ.1) THEN + DO 400 J=1,4 + P(N+1,J)=P(IP,J) + 400 CONTINUE + GOTO 660 + ENDIF + +C...Calculate maximum weight ND-particle decay. + PV(ND,5)=P(N+ND,5) + IF(ND.GE.3) THEN + WTMAX=1./WTCOR(ND-2) + PMAX=PV(1,5)-PS+P(N+ND,5) + PMIN=0. + DO 410 IL=ND-1,1,-1 + PMAX=PMAX+P(N+IL,5) + PMIN=PMIN+P(N+IL+1,5) + WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5)) + 410 CONTINUE + ENDIF + +C...Find virtual gamma mass in Dalitz decay. + 420 IF(ND.EQ.2) THEN + ELSEIF(MMAT.EQ.2) THEN + PMES=4.*PMAS(11,1)**2 + PMRHO2=PMAS(131,1)**2 + PGRHO2=PMAS(131,2)**2 + 430 PMST=PMES*(P(IP,5)**2/PMES)**RLU(0) + WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.D0,1.-PMES/PMST))* + & (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/ + & ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2) + IF(WT.LT.RLU(0)) GOTO 430 + PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST)) + +C...M-generator gives weight. If rejected, try again. + ELSE + 440 RORD(1)=1. + DO 470 IL1=2,ND-1 + RSAV=RLU(0) + DO 450 IL2=IL1-1,1,-1 + IF(RSAV.LE.RORD(IL2)) GOTO 460 + RORD(IL2+1)=RORD(IL2) + 450 CONTINUE + 460 RORD(IL2+1)=RSAV + 470 CONTINUE + RORD(ND)=0. + WT=1. + DO 480 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) + WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + 480 CONTINUE + IF(WT.LT.RLU(0)*WTMAX) GOTO 440 + ENDIF + +C...Perform two-particle decays in respective CM frame. + 490 DO 510 IL=1,ND-1 + PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + UE(3)=2.*RLU(0)-1. + PHI=PARU(2)*RLU(0) + UE(1)=SQRT(1.-UE(3)**2)*COS(PHI) + UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI) + DO 500 J=1,3 + P(N+IL,J)=PA*UE(J) + PV(IL+1,J)=-PA*UE(J) + 500 CONTINUE + P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2) + PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2) + 510 CONTINUE + +C...Lorentz transform decay products to lab frame. + DO 520 J=1,4 + P(N+ND,J)=PV(ND,J) + 520 CONTINUE + DO 560 IL=ND-1,1,-1 + DO 530 J=1,3 + BE(J)=PV(IL,J)/PV(IL,4) + 530 CONTINUE + GA=PV(IL,4)/PV(IL,5) + DO 550 I=N+IL,N+ND + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 540 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J) + 540 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 550 CONTINUE + 560 CONTINUE + +C...Check that no infinite loop in matrix element weight. + NTRY=NTRY+1 + IF(NTRY.GT.800) GOTO 590 + +C...Matrix elements for omega and phi decays. + IF(MMAT.EQ.1) THEN + WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2 + & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2 + & +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3) + IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.RLU(0)) GOTO 420 + +C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. + ELSEIF(MMAT.EQ.2) THEN + FOUR12=FOUR(N+1,N+2) + FOUR13=FOUR(N+1,N+3) + WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+ + & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2) + IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 490 + +C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, +C...V vector), of form cos**2(theta02) in V1 rest frame, and for +C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02). + ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN + FOUR10=FOUR(IP,IM) + FOUR12=FOUR(IP,N+1) + FOUR02=FOUR(IM,N+1) + PMS1=P(IP,5)**2 + PMS0=P(IM,5)**2 + PMS2=P(N+1,5)**2 + IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2 + IF(KFAS.EQ.22) HNUM=PMS1*(2.*FOUR10*FOUR12*FOUR02- + & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2) + HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM) + HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2) + IF(HNUM.LT.RLU(0)*HDEN) GOTO 490 + +C...Matrix element for "onium" -> g + g + g or gamma + g + g. + ELSEIF(MMAT.EQ.4) THEN + HX1=2.*FOUR(IP,N+1)/P(IP,5)**2 + HX2=2.*FOUR(IP,N+2)/P(IP,5)**2 + HX3=2.*FOUR(IP,N+3)/P(IP,5)**2 + WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+ + & ((1.-HX3)/(HX1*HX2))**2 + IF(WT.LT.2.*RLU(0)) GOTO 420 + IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2) + & GOTO 420 + +C...Effective matrix element for nu spectrum in tau -> nu + hadrons. + ELSEIF(MMAT.EQ.41) THEN + HX1=2.*FOUR(IP,N+1)/P(IP,5)**2 + HXM=MIN(0.75D0,2.*(1.-PS/P(IP,5))) + IF(HX1*(3.-2.*HX1).LT.RLU(0)*HXM*(3.-2.*HXM)) GOTO 420 + +C...Matrix elements for weak decays (only semileptonic for c and b) + ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) + &.AND.ND.EQ.3) THEN + IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3) + IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3) + IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 420 + ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN + DO 580 J=1,4 + P(N+NP+1,J)=0. + DO 570 IS=N+3,N+NP + P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J) + 570 CONTINUE + 580 CONTINUE + IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1) + IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1) + IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 420 + +C...Angular distribution in W decay. + ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN + IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1) + IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1) + IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 490 + ENDIF + +C...Scale back energy and reattach spectator. + 590 IF(MREM.EQ.1) THEN + DO 600 J=1,5 + PV(1,J)=PV(1,J)/(1.-PQT) + 600 CONTINUE + ND=ND+1 + MREM=0 + ENDIF + +C...Low invariant mass for system with spectator quark gives particle, +C...not two jets. Readjust momenta accordingly. + IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN + MSTJ(93)=1 + PM2=ULMASS(K(N+2,2)) + MSTJ(93)=1 + PM3=ULMASS(K(N+3,2)) + IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE. + & (PARJ(32)+PM2+PM3)**2) GOTO 660 + K(N+2,1)=1 + KFTEMP=K(N+2,2) + CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2)) + IF(K(N+2,2).EQ.0) GOTO 260 + P(N+2,5)=ULMASS(K(N+2,2)) + PS=P(N+1,5)+P(N+2,5) + PV(2,5)=P(N+2,5) + MMAT=0 + ND=2 + GOTO 490 + ELSEIF(MMAT.EQ.44) THEN + MSTJ(93)=1 + PM3=ULMASS(K(N+3,2)) + MSTJ(93)=1 + PM4=ULMASS(K(N+4,2)) + IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE. + & (PARJ(32)+PM3+PM4)**2) GOTO 630 + K(N+3,1)=1 + KFTEMP=K(N+3,2) + CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2)) + IF(K(N+3,2).EQ.0) GOTO 260 + P(N+3,5)=ULMASS(K(N+3,2)) + DO 610 J=1,3 + P(N+3,J)=P(N+3,J)+P(N+4,J) + 610 CONTINUE + 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 620 J=1,3 + PCOR=HH*(P(N+1,J)-P(N+2,J)) + P(N+1,J)=P(N+1,J)+PCOR + P(N+2,J)=P(N+2,J)-PCOR + 620 CONTINUE + P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2) + P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2) + ND=ND-1 + ENDIF + +C...Check invariant mass of W jets. May give one particle or start over. + 630 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) + &.AND.IABS(K(N+1,2)).LT.10) THEN + PMR=SQRT(MAX(0.D0,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2))) + MSTJ(93)=1 + PM1=ULMASS(K(N+1,2)) + MSTJ(93)=1 + PM2=ULMASS(K(N+2,2)) + IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 640 + KFLDUM=INT(1.5+RLU(0)) + CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1) + CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2) + IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260 + PSM=ULMASS(KF1)+ULMASS(KF2) + IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 640 + IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 640 + IF(MMAT.EQ.48) GOTO 420 + IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260 + K(N+1,1)=1 + KFTEMP=K(N+1,2) + CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2)) + IF(K(N+1,2).EQ.0) GOTO 260 + P(N+1,5)=ULMASS(K(N+1,2)) + K(N+2,2)=K(N+3,2) + P(N+2,5)=P(N+3,5) + PS=P(N+1,5)+P(N+2,5) + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 + PV(2,5)=P(N+3,5) + MMAT=0 + ND=2 + GOTO 490 + ENDIF + +C...Phase space decay of partons from W decay. + 640 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN + KFLO(1)=K(N+1,2) + KFLO(2)=K(N+2,2) + K(N+1,1)=K(N+3,1) + K(N+1,2)=K(N+3,2) + DO 650 J=1,5 + PV(1,J)=P(N+1,J)+P(N+2,J) + P(N+1,J)=P(N+3,J) + 650 CONTINUE + PV(1,5)=PMR + N=N+1 + NP=0 + NQ=2 + PS=0. + MSTJ(93)=2 + PSQ=ULMASS(KFLO(1)) + MSTJ(93)=2 + PSQ=PSQ+ULMASS(KFLO(2)) + MMAT=11 + GOTO 290 + ENDIF + +C...Boost back for rapidly moving particle. + 660 N=N+ND + IF(MBST.EQ.1) THEN + DO 670 J=1,3 + BE(J)=P(IP,J)/P(IP,4) + 670 CONTINUE + GA=P(IP,4)/P(IP,5) + DO 690 I=NSAV+1,N + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 680 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J) + 680 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 690 CONTINUE + ENDIF + +C...Fill in position of decay vertex. + DO 710 I=NSAV+1,N + DO 700 J=1,4 + V(I,J)=VDCY(J) + 700 CONTINUE + V(I,5)=0. + 710 CONTINUE + +C...Set up for parton shower evolution from jets. + IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+2) + K(NSAV+1,5)=MSTU(5)*(NSAV+3) + K(NSAV+2,4)=MSTU(5)*(NSAV+3) + K(NSAV+2,5)=MSTU(5)*(NSAV+1) + K(NSAV+3,4)=MSTU(5)*(NSAV+1) + K(NSAV+3,5)=MSTU(5)*(NSAV+2) + MSTJ(92)=-(NSAV+1) + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + K(NSAV+2,4)=MSTU(5)*(NSAV+3) + K(NSAV+2,5)=MSTU(5)*(NSAV+3) + K(NSAV+3,4)=MSTU(5)*(NSAV+2) + K(NSAV+3,5)=MSTU(5)*(NSAV+2) + MSTJ(92)=NSAV+2 + ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46) + &.AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+2) + K(NSAV+1,5)=MSTU(5)*(NSAV+2) + K(NSAV+2,4)=MSTU(5)*(NSAV+1) + K(NSAV+2,5)=MSTU(5)*(NSAV+1) + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46) + &.AND.IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21) + &THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + KCP=LUCOMP(K(NSAV+1,2)) + KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2)) + JCON=4 + IF(KQP.LT.0) JCON=5 + K(NSAV+1,JCON)=MSTU(5)*(NSAV+2) + K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1) + K(NSAV+2,JCON)=MSTU(5)*(NSAV+3) + K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2) + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN + K(NSAV+1,1)=3 + K(NSAV+3,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+3) + K(NSAV+1,5)=MSTU(5)*(NSAV+3) + K(NSAV+3,4)=MSTU(5)*(NSAV+1) + K(NSAV+3,5)=MSTU(5)*(NSAV+1) + MSTJ(92)=NSAV+1 + +C...Set up for parton shower evolution in t -> W + b. + ELSEIF(MSTJ(27).GE.1.AND.MMAT.EQ.45.AND.ND.EQ.3) THEN + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + K(NSAV+2,4)=MSTU(5)*(NSAV+3) + K(NSAV+2,5)=MSTU(5)*(NSAV+3) + K(NSAV+3,4)=MSTU(5)*(NSAV+2) + K(NSAV+3,5)=MSTU(5)*(NSAV+2) + MSTJ(92)=NSAV+1 + ENDIF + +C...Mark decayed particle; special option for B-B~ mixing. + IF(K(IP,1).EQ.5) K(IP,1)=15 + IF(K(IP,1).LE.10) K(IP,1)=11 + IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12 + K(IP,4)=NSAV+1 + K(IP,5)=N + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUKFDI + SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to generate a new flavour pair and combine off a hadron. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT1/,/LUDAT2/ + +C...Default flavour values. Input consistency checks. + KF1A=IABS(KFL1) + KF2A=IABS(KFL2) + KFL3=0 + KF=0 + IF(KF1A.EQ.0) RETURN + IF(KF2A.NE.0) THEN + IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN + IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN + IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN + ENDIF + +C...Check if tabulated flavour probabilities are to be used. + IF(MSTJ(15).EQ.1) THEN + KTAB1=-1 + IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A + KFL1A=MOD(KF1A/1000,10) + KFL1B=MOD(KF1A/100,10) + KFL1S=MOD(KF1A,10) + IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4) + & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2 + IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1 + IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A + KTAB2=0 + IF(KF2A.NE.0) THEN + KTAB2=-1 + IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A + KFL2A=MOD(KF2A/1000,10) + KFL2B=MOD(KF2A/100,10) + KFL2S=MOD(KF2A,10) + IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4) + & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2 + IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1 + ENDIF + IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 150 + ENDIF + +C...Parameters and breaking diquark parameter combinations. + 100 PAR2=PARJ(2) + PAR3=PARJ(3) + PAR4=3.*PARJ(4) + IF(MSTJ(12).GE.2) THEN + PAR3M=SQRT(PARJ(3)) + PAR4M=1./(3.*SQRT(PARJ(4))) + PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6)) + PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M)) + PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+ + & PAR2*PAR3M*PARJ(6)*PARJ(7)) + PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M) + PARSM=MAX(PARS0,PARS1,PARS2) + PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M)) + ENDIF + +C...Choice of whether to generate meson or baryon. + 110 MBARY=0 + KFDA=0 + IF(KF1A.LE.10) THEN + IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.) + & MBARY=1 + IF(KF2A.GT.10) MBARY=2 + IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A + ELSE + MBARY=2 + IF(KF1A.LE.10000) KFDA=KF1A + ENDIF + +C...Possibility of process diquark -> meson + new diquark. + IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN + KFLDA=MOD(KFDA/1000,10) + KFLDB=MOD(KFDA/100,10) + KFLDS=MOD(KFDA,10) + WTDQ=PARS0 + IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1 + IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2 + IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M) + IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1 + IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN + ENDIF + +C...Flavour for meson, possibly with new flavour. + IF(MBARY.LE.0) THEN + KFS=ISIGN(1,KFL1) + IF(MBARY.EQ.0) THEN + IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1) + KFLA=MAX(KF1A,KF2A+IABS(KFL3)) + KFLB=MIN(KF1A,KF2A+IABS(KFL3)) + IF(KFLA.NE.KF1A) KFS=-KFS + +C...Splitting of diquark into meson plus new diquark. + ELSE + KFL1A=MOD(KF1A/1000,10) + KFL1B=MOD(KF1A/100,10) + 120 KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A) + KFL1E=KFL1A+KFL1B-KFL1D + IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND. + & RLU(0).LT.PARDM)) THEN + KFL1D=KFL1A+KFL1B-KFL1D + KFL1E=KFL1A+KFL1B-KFL1E + ENDIF + KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0)) + IF + & ((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.D0,1.+PAR4M)) + & .OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.D0,1.+PAR4M))) + & GOTO 120 + KFLDS=3 + IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1 + KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+ + & KFLDS,-KFL1) + KFLA=MAX(KFL1D,KFL3A) + KFLB=MIN(KFL1D,KFL3A) + IF(KFLA.NE.KFL1D) KFS=-KFS + ENDIF + +C...Form meson, with spin and flavour mixing for diagonal states. + IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0)) + IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0)) + IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0)) + IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN + IF(RLU(0).LT.PARJ(14)) KMUL=2 + ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN + RMUL=RLU(0) + IF(RMUL.LT.PARJ(15)) KMUL=3 + IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4 + IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5 + ENDIF + KFLS=3 + IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 + IF(KMUL.EQ.5) KFLS=5 + IF(KFLA.NE.KFLB) THEN + KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA + ELSE + RMIX=RLU(0) + IMIX=2*KFLA+10*KMUL + IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+ + & INT(RMIX+PARF(IMIX)))+KFLS + IF(KFLA.GE.4) KF=110*KFLA+KFLS + ENDIF + IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF) + IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF) + +C...Optional extra suppression of eta and eta'. + IF(KF.EQ.221) THEN + IF(RLU(0).GT.PARJ(25)) GOTO 110 + ELSEIF(KF.EQ.331) THEN + IF(RLU(0).GT.PARJ(26)) GOTO 110 + ENDIF + +C...Generate diquark flavour. + ELSE + 130 IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN + KFLA=KF1A + 140 KFLB=1+INT((2.+PAR2*PAR3)*RLU(0)) + KFLC=1+INT((2.+PAR2*PAR3)*RLU(0)) + KFLDS=1 + IF(KFLB.GE.KFLC) KFLDS=3 + IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 140 + IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 140 + KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1) + +C...Take diquark flavour from input. + ELSEIF(KF1A.LE.10) THEN + KFLA=KF1A + KFLB=MOD(KF2A/1000,10) + KFLC=MOD(KF2A/100,10) + KFLDS=MOD(KF2A,10) + +C...Generate (or take from input) quark to go with diquark. + ELSE + IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1) + KFLA=KF2A+IABS(KFL3) + KFLB=MOD(KF1A/1000,10) + KFLC=MOD(KF1A/100,10) + KFLDS=MOD(KF1A,10) + ENDIF + +C...SU(6) factors for formation of baryon. Try again if fails. + KBARY=KFLDS + IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5 + IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1 + WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY) + IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN + WTDQ=PARS0 + IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1 + IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2 + IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M) + IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M)) + IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM) + ENDIF + IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 130 + +C...Form baryon. Distinguish Lambda- and Sigmalike baryons. + KFLD=MAX(KFLA,KFLB,KFLC) + KFLF=MIN(KFLA,KFLB,KFLC) + KFLE=KFLA+KFLB+KFLC-KFLD-KFLF + KFLS=2 + IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT. + & PARF(60+KBARY)) KFLS=4 + KFLL=0 + IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN + IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1 + IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0)) + IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0)) + ENDIF + IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1) + IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1) + ENDIF + RETURN + +C...Use tabulated probabilities to select new flavour and hadron. + 150 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN + KT3L=1 + KT3U=6 + ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN + KT3L=1 + KT3U=6 + ELSEIF(KTAB2.EQ.0) THEN + KT3L=1 + KT3U=22 + ELSE + KT3L=KTAB2 + KT3U=KTAB2 + ENDIF + RFL=0. + DO 170 KTS=0,2 + DO 160 KT3=KT3L,KT3U + RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3) + 160 CONTINUE + 170 CONTINUE + RFL=RLU(0)*RFL + DO 190 KTS=0,2 + KTABS=KTS + DO 180 KT3=KT3L,KT3U + KTAB3=KT3 + RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3) + IF(RFL.LE.0.) GOTO 200 + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + +C...Reconstruct flavour of produced quark/diquark. + IF(KTAB3.LE.6) THEN + KFL3A=KTAB3 + KFL3B=0 + KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13)) + ELSE + KFL3A=1 + IF(KTAB3.GE.8) KFL3A=2 + IF(KTAB3.GE.11) KFL3A=3 + IF(KTAB3.GE.16) KFL3A=4 + KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2 + KFL3=1000*KFL3A+100*KFL3B+1 + IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3= + & KFL3+2 + KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1)) + ENDIF + +C...Reconstruct meson code. + IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR. + &KFL3B.NE.0)) THEN + RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ + & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS)) + KF=110+2*KTABS+1 + IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1 + IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ + & 25*KTABS)) KF=330+2*KTABS+1 + ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN + KFLA=MAX(KTAB1,KTAB3) + KFLB=MIN(KTAB1,KTAB3) + KFS=ISIGN(1,KFL1) + IF(KFLA.NE.KF1A) KFS=-KFS + KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA + ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN + KFS=ISIGN(1,KFL1) + IF(KFL1A.EQ.KFL3A) THEN + KFLA=MAX(KFL1B,KFL3B) + KFLB=MIN(KFL1B,KFL3B) + IF(KFLA.NE.KFL1B) KFS=-KFS + ELSEIF(KFL1A.EQ.KFL3B) THEN + KFLA=KFL3A + KFLB=KFL1B + KFS=-KFS + ELSEIF(KFL1B.EQ.KFL3A) THEN + KFLA=KFL1A + KFLB=KFL3B + ELSEIF(KFL1B.EQ.KFL3B) THEN + KFLA=MAX(KFL1A,KFL3A) + KFLB=MIN(KFL1A,KFL3A) + IF(KFLA.NE.KFL1A) KFS=-KFS + ELSE + CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq') + GOTO 100 + ENDIF + KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA + +C...Reconstruct baryon code. + ELSE + IF(KTAB1.GE.7) THEN + KFLA=KFL3A + KFLB=KFL1A + KFLC=KFL1B + ELSE + KFLA=KFL1A + KFLB=KFL3A + KFLC=KFL3B + ENDIF + KFLD=MAX(KFLA,KFLB,KFLC) + KFLF=MIN(KFLA,KFLB,KFLC) + KFLE=KFLA+KFLB+KFLC-KFLD-KFLF + IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1) + IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1) + ENDIF + +C...Check that constructed flavour code is an allowed one. + IF(KFL2.NE.0) KFL3=0 + KC=LUCOMP(KF) + IF(KC.EQ.0) THEN + CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '// + & 'failed') + GOTO 100 + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUPTDI + SUBROUTINE LUPTDI(KFL,PX,PY) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to generate transverse momentum according to a Gaussian. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUDAT1/ + +C...Generate p_T and azimuthal angle, gives p_x and p_y. + KFLA=IABS(KFL) + PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,RLU(0)))) + IF(PARJ(23).GT.RLU(0)) PT=PARJ(24)*PT + IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT + IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0. + PHI=PARU(2)*RLU(0) + PX=PT*COS(PHI) + PY=PT*SIN(PHI) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUZDIS + SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to generate the longitudinal splitting variable z. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT1/,/LUDAT2/ + +C...Check if heavy flavour fragmentation. + KFLA=IABS(KFL1) + KFLB=IABS(KFL2) + KFLH=KFLA + IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10) + +C...Lund symmetric scaling function: determine parameters of shape. + IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR. + &MSTJ(11).GE.4) THEN + FA=PARJ(41) + IF(MSTJ(91).EQ.1) FA=PARJ(43) + IF(KFLB.GE.10) FA=FA+PARJ(45) + FBB=PARJ(42) + IF(MSTJ(91).EQ.1) FBB=PARJ(44) + FB=FBB*PR + FC=1. + IF(KFLA.GE.10) FC=FC-PARJ(45) + IF(KFLB.GE.10) FC=FC+PARJ(45) + IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN + FRED=PARJ(46) + IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47) + FC=FC+FRED*FBB*PARF(100+KFLH)**2 + ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN + FRED=PARJ(46) + IF(MSTJ(11).EQ.5) FRED=PARJ(48) + FC=FC+FRED*FBB*PMAS(KFLH,1)**2 + ENDIF + MC=1 + IF(ABS(FC-1.).GT.0.01) MC=2 + +C...Determine position of maximum. Special cases for a = 0 or a = c. + IF(FA.LT.0.02) THEN + MA=1 + ZMAX=1. + IF(FC.GT.FB) ZMAX=FB/FC + ELSEIF(ABS(FC-FA).LT.0.01) THEN + MA=2 + ZMAX=FB/(FB+FC) + ELSE + MA=3 + ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA) + IF(ZMAX.GT.0.9999.AND.FB.GT.100.) ZMAX=MIN(ZMAX,1.-FA/FB) + ENDIF + +C...Subdivide z range if distribution very peaked near endpoint. + MMAX=2 + IF(ZMAX.LT.0.1) THEN + MMAX=1 + ZDIV=2.75*ZMAX + IF(MC.EQ.1) THEN + FINT=1.-LOG(ZDIV) + ELSE + ZDIVC=ZDIV**(1.-FC) + FINT=1.+(1.-1./ZDIVC)/(FC-1.) + ENDIF + ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN + MMAX=3 + FSCB=SQRT(4.+(FC/FB)**2) + ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB)) + IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX) + ZDIV=MIN(ZMAX,MAX(0.D0,ZDIV)) + FINT=1.+FB*(1.-ZDIV) + ENDIF + +C...Choice of z, preweighted for peaks at low or high z. + 100 Z=RLU(0) + FPRE=1. + IF(MMAX.EQ.1) THEN + IF(FINT*RLU(0).LE.1.) THEN + Z=ZDIV*Z + ELSEIF(MC.EQ.1) THEN + Z=ZDIV**Z + FPRE=ZDIV/Z + ELSE + Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC)) + FPRE=(ZDIV/Z)**FC + ENDIF + ELSEIF(MMAX.EQ.3) THEN + IF(FINT*RLU(0).LE.1.) THEN + Z=ZDIV+LOG(Z)/FB + FPRE=EXP(FB*(Z-ZDIV)) + ELSE + Z=ZDIV+Z*(1.-ZDIV) + ENDIF + ENDIF + +C...Weighting according to correct formula. + IF(Z.LE.0..OR.Z.GE.1.) GOTO 100 + FEXP=FC*LOG(ZMAX/Z)+FB*(1./ZMAX-1./Z) + IF(MA.GE.2) FEXP=FEXP+FA*LOG((1.-Z)/(1.-ZMAX)) + FVAL=EXP(MAX(-50.D0,MIN(50.D0,FEXP))) + IF(FVAL.LT.RLU(0)*FPRE) GOTO 100 + +C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c. + ELSE + FC=PARJ(50+MAX(1,KFLH)) + IF(MSTJ(91).EQ.1) FC=PARJ(59) + 110 Z=RLU(0) + IF(FC.GE.0..AND.FC.LE.1.) THEN + IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.) + ELSEIF(FC.GT.-1.AND.FC.LT.0.) THEN + IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110 + ELSE + IF(FC.GT.0.) Z=1.-Z**(1./FC) + IF(FC.LT.0.) Z=Z**(-1./FC) + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUSHOW + SUBROUTINE LUSHOW(IP1,IP2,QMAX) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to generate timelike parton showers from given partons. +C IMPLICIT DOUBLE PRECISION(D) + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4), + &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4), + &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2), + &ISII(2) + +C...Initialization of cutoff masses etc. + IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR. + &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN + DO 100 IFL=0,40 + KSH(IFL)=0 + 100 CONTINUE + KSH(21)=1 + PMTH(1,21)=ULMASS(21) + PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2) + PMTH(3,21)=2.*PMTH(2,21) + PMTH(4,21)=PMTH(3,21) + PMTH(5,21)=PMTH(3,21) + PMTH(1,22)=ULMASS(22) + PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2) + PMTH(3,22)=2.*PMTH(2,22) + PMTH(4,22)=PMTH(3,22) + PMTH(5,22)=PMTH(3,22) + PMQTH1=PARJ(82) + IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83)) + PMQTH2=PMTH(2,21) + IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22)) + DO 110 IFL=1,8 + KSH(IFL)=1 + PMTH(1,IFL)=ULMASS(IFL) + PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PMQTH1**2) + PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2 + PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(82)**2)+PMTH(2,21) + PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(83)**2)+PMTH(2,22) + 110 CONTINUE + DO 120 IFL=11,17,2 + IF(MSTJ(41).GE.2) KSH(IFL)=1 + PMTH(1,IFL)=ULMASS(IFL) + PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(83)**2) + PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22) + PMTH(4,IFL)=PMTH(3,IFL) + PMTH(5,IFL)=PMTH(3,IFL) + 120 CONTINUE + PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2 + ALAMS=PARJ(81)**2 + ALFM=LOG(PT2MIN/ALAMS) + +C...Store positions of shower initiating partons. + IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN + NPA=1 + IPA(1)=IP1 + ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)- + &MSTU(32))) THEN + NPA=2 + IPA(1)=IP1 + IPA(2)=IP2 + ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0 + &.AND.IP2.GE.-3) THEN + NPA=IABS(IP2) + DO 130 I=1,NPA + IPA(I)=IP1+I-1 + 130 CONTINUE + ELSE + CALL LUERRM(12, + & '(LUSHOW:) failed to reconstruct showering system') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Check on phase space available for emission. + IREJ=0 + DO 140 J=1,5 + PS(J)=0. + 140 CONTINUE + PM=0. + DO 160 I=1,NPA + KFLA(I)=IABS(K(IPA(I),2)) + PMA(I)=P(IPA(I),5) +C...Special cutoff masses for t, l, h with variable masses. + IFLA=KFLA(I) + IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN + IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2)) + PMTH(1,IFLA)=PMA(I) + PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PMQTH1**2) + PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2 + PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PARJ(82)**2)+PMTH(2,21) + PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PARJ(83)**2)+PMTH(2,22) + ENDIF + IF(KFLA(I).LE.40) THEN + IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA) + ENDIF + PM=PM+PMA(I) + IF(KFLA(I).GT.40) THEN + IREJ=IREJ+1 + ELSE + IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1 + ENDIF + DO 150 J=1,4 + PS(J)=PS(J)+P(IPA(I),J) + 150 CONTINUE + 160 CONTINUE + IF(IREJ.EQ.NPA) RETURN + PS(5)=SQRT(MAX(0.D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) + IF(NPA.EQ.1) PS(5)=PS(4) + IF(PS(5).LE.PM+PMQTH1) RETURN + +C...Check if 3-jet matrix elements to be used. + M3JC=0 + IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN + IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND. + & KFLA(2).LE.8) M3JC=1 + IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR. + & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1 + IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR. + & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1 + IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR. + & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1 + IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1 + M3JCM=0 + IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN + M3JCM=1 + QME=(2.*PMTH(1,KFLA(1))/PS(5))**2 + ENDIF + ENDIF + +C...Find if interference with initial state partons. + MIIS=0 + IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50) + IF(MIIS.NE.0) THEN + DO 180 I=1,2 + KCII(I)=0 + KCA=LUCOMP(KFLA(I)) + IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2)) + NIIS(I)=0 + IF(KCII(I).NE.0) THEN + DO 170 J=1,2 + ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5)) + IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND. + & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN + NIIS(I)=NIIS(I)+1 + IIIS(I,NIIS(I))=ICSI + ENDIF + 170 CONTINUE + ENDIF + 180 CONTINUE + IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0 + ENDIF + +C...Boost interfering initial partons to rest frame +C...and reconstruct their polar and azimuthal angles. + IF(MIIS.NE.0) THEN + DO 200 I=1,2 + DO 190 J=1,5 + K(N+I,J)=K(IPA(I),J) + P(N+I,J)=P(IPA(I),J) + V(N+I,J)=0. + 190 CONTINUE + 200 CONTINUE + DO 220 I=3,2+NIIS(1) + DO 210 J=1,5 + K(N+I,J)=K(IIIS(1,I-2),J) + P(N+I,J)=P(IIIS(1,I-2),J) + V(N+I,J)=0. + 210 CONTINUE + 220 CONTINUE + DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2) + DO 230 J=1,5 + K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J) + P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J) + V(N+I,J)=0. + 230 CONTINUE + 240 CONTINUE + CALL + & LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),0.D0,0.D0,-DBLE(PS(1)/PS(4)), + & -DBLE(PS(2)/PS(4)),-DBLE(PS(3)/PS(4))) + PHI=ULANGL(P(N+1,1),P(N+1,2)) + CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),0.D0,-PHI,0D0,0D0,0D0) + THE=ULANGL(P(N+1,3),P(N+1,1)) + CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),-THE,0.D0,0D0,0D0,0D0) + DO 250 I=3,2+NIIS(1) + THEIIS(1,I-2)=ULANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2)) + PHIIIS(1,I-2)=ULANGL(P(N+I,1),P(N+I,2)) + 250 CONTINUE + DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2) + THEIIS(2,I-2-NIIS(1))=PARU(1)-ULANGL(P(N+I,3), + & SQRT(P(N+I,1)**2+P(N+I,2)**2)) + PHIIIS(2,I-2-NIIS(1))=ULANGL(P(N+I,1),P(N+I,2)) + 260 CONTINUE + ENDIF + +C...Define imagined single initiator of shower for parton system. + NS=N + IF(N.GT.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(NPA.GE.2) THEN + K(N+1,1)=11 + K(N+1,2)=21 + K(N+1,3)=0 + K(N+1,4)=0 + K(N+1,5)=0 + P(N+1,1)=0. + P(N+1,2)=0. + P(N+1,3)=0. + P(N+1,4)=PS(5) + P(N+1,5)=PS(5) + V(N+1,5)=PS(5)**2 + N=N+1 + ENDIF + +C...Loop over partons that may branch. + NEP=NPA + IM=NS + IF(NPA.EQ.1) IM=NS-1 + 270 IM=IM+1 + IF(N.GT.NS) THEN + IF(IM.GT.N) GOTO 510 + KFLM=IABS(K(IM,2)) + IF(KFLM.GT.40) GOTO 270 + IF(KSH(KFLM).EQ.0) GOTO 270 + IFLM=KFLM + IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2)) + IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270 + IGM=K(IM,3) + ELSE + IGM=-1 + ENDIF + IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Position of aunt (sister to branching parton). +C...Origin and flavour of daughters. + IAU=0 + IF(IGM.GT.0) THEN + IF(K(IM-1,3).EQ.IGM) IAU=IM-1 + IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1 + ENDIF + IF(IGM.GE.0) THEN + K(IM,4)=N+1 + DO 280 I=1,NEP + K(N+I,3)=IM + 280 CONTINUE + ELSE + K(N+1,3)=IPA(1) + ENDIF + IF(IGM.LE.0) THEN + DO 290 I=1,NEP + K(N+I,2)=K(IPA(I),2) + 290 CONTINUE + ELSEIF(KFLM.NE.21) THEN + K(N+1,2)=K(IM,2) + K(N+2,2)=K(IM,5) + ELSEIF(K(IM,5).EQ.21) THEN + K(N+1,2)=21 + K(N+2,2)=21 + ELSE + K(N+1,2)=K(IM,5) + K(N+2,2)=-K(IM,5) + ENDIF + +C...Reset flags on daughers and tries made. + DO 300 IP=1,NEP + K(N+IP,1)=3 + K(N+IP,4)=0 + K(N+IP,5)=0 + KFLD(IP)=IABS(K(N+IP,2)) + IF(KCHG(LUCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1 + ITRY(IP)=0 + ISL(IP)=0 + ISI(IP)=0 + IF(KFLD(IP).LE.40) THEN + IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1 + ENDIF + 300 CONTINUE + ISLM=0 + +C...Maximum virtuality of daughters. + IF(IGM.LE.0) THEN + DO 310 I=1,NPA + IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)- + & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5) + P(N+I,5)=MIN(QMAX,PS(5)) + IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4)) + IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5) + 310 CONTINUE + ELSE + IF(MSTJ(43).LE.2) PEM=V(IM,2) + IF(MSTJ(43).GE.3) PEM=P(IM,4) + P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM) + P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM) + IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22) + ENDIF + DO 320 I=1,NEP + PMSD(I)=P(N+I,5) + IF(ISI(I).EQ.1) THEN + IFLD=KFLD(I) + IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+ + & ISIGN(2,K(N+I,2)) + IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD) + ENDIF + V(N+I,5)=P(N+I,5)**2 + 320 CONTINUE + +C...Choose one of the daughters for evolution. + 330 INUM=0 + IF(NEP.EQ.1) INUM=1 + DO 340 I=1,NEP + IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I + 340 CONTINUE + DO 350 I=1,NEP + IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN + IFLD=KFLD(I) + IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+ + & ISIGN(2,K(N+I,2)) + IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I + ENDIF + 350 CONTINUE + IF(INUM.EQ.0) THEN + RMAX=0. + DO 360 I=1,NEP + IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN + RPM=P(N+I,5)/PMSD(I) + IFLD=KFLD(I) + IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+ + & ISIGN(2,K(N+I,2)) + IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN + RMAX=RPM + INUM=I + ENDIF + ENDIF + 360 CONTINUE + ENDIF + +C...Store information on choice of evolving daughter. + INUM=MAX(1,INUM) + IEP(1)=N+INUM + DO 370 I=2,NEP + IEP(I)=IEP(I-1)+1 + IF(IEP(I).GT.N+NEP) IEP(I)=N+1 + 370 CONTINUE + DO 380 I=1,NEP + KFL(I)=IABS(K(IEP(I),2)) + 380 CONTINUE + ITRY(INUM)=ITRY(INUM)+1 + IF(ITRY(INUM).GT.200) THEN + CALL LUERRM(14,'(LUSHOW:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + Z=0.5 + IF(KFL(1).GT.40) GOTO 430 + IF(KSH(KFL(1)).EQ.0) GOTO 430 + IFL=KFL(1) + IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+ + &ISIGN(2,K(IEP(1),2)) + IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430 + +C...Select side for interference with initial state partons. + IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN + III=IEP(1)-NS-1 + ISII(III)=0 + IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN + ISII(III)=1 + ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN + IF(RLU(0).GT.0.5) ISII(III)=1 + ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN + ISII(III)=1 + IF(RLU(0).GT.0.5) ISII(III)=2 + ENDIF + ENDIF + +C...Calculate allowed z range. + IF(NEP.EQ.1) THEN + PMED=PS(4) + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PMED=P(IM,5) + ELSE + IF(INUM.EQ.1) PMED=V(IM,1)*PEM + IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + ZC=PMTH(2,21)/PMED + ZCE=PMTH(2,22)/PMED + ELSE + ZC=0.5*(1.-SQRT(MAX(0.D0,1.-(2.*PMTH(2,21)/PMED)**2))) + IF(ZC.LT.1D-4) ZC=(PMTH(2,21)/PMED)**2 + ZCE=0.5*(1.-SQRT(MAX(0.D0,1.-(2.*PMTH(2,22)/PMED)**2))) + IF(ZCE.LT.1D-4) ZCE=(PMTH(2,22)/PMED)**2 + ENDIF + ZC=MIN(ZC,0.491D0) + ZCE=MIN(ZCE,0.491D0) + IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).GE.2.AND. + &MIN(ZC,ZCE).GT.0.49)) THEN + P(IEP(1),5)=PMTH(1,IFL) + V(IEP(1),5)=P(IEP(1),5)**2 + GOTO 430 + ENDIF + +C...Integral of Altarelli-Parisi z kernel for QCD. + IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN + FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC) + ELSEIF(MSTJ(49).EQ.0) THEN + FBR=(8./3.)*LOG((1.-ZC)/ZC) + +C...Integral of Altarelli-Parisi z kernel for scalar gluon. + ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN + FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC) + ELSEIF(MSTJ(49).EQ.1) THEN + FBR=(1.-2.*ZC)/3. + IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR + +C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. + ELSEIF(KFL(1).EQ.21) THEN + FBR=6.*MSTJ(45)*(0.5-ZC) + ELSE + FBR=2.*LOG((1.-ZC)/ZC) + ENDIF + +C...Reset QCD probability for lepton. + IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0. + +C...Integral of Altarelli-Parisi kernel for photon emission. + IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN + FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE) + IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE + ENDIF + +C...Inner veto algorithm starts. Find maximum mass for evolution. + 390 PMS=V(IEP(1),5) + IF(IGM.GE.0) THEN + PM2=0. + DO 400 I=2,NEP + PM=P(IEP(I),5) + IF(KFL(I).LE.40) THEN + IFLI=KFL(I) + IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+ + & ISIGN(2,K(IEP(I),2)) + IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI) + ENDIF + PM2=PM2+PM + 400 CONTINUE + PMS=MIN(PMS,(P(IM,5)-PM2)**2) + ENDIF + +C...Select mass for daughter in QCD evolution. + B0=27./6. + DO 410 IFF=4,MSTJ(45) + IF(PMS.GT.4.*PMTH(2,IFF)**2) B0=(33.-2.*IFF)/6. + 410 CONTINUE + IF(FBR.LT.1D-3) THEN + PMSQCD=0. + ELSEIF(MSTJ(44).LE.0) THEN + PMSQCD=PMS*EXP(MAX(-50.D0,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR))) + ELSEIF(MSTJ(44).EQ.1) THEN + PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR)) + ELSE + PMSQCD=PMS*EXP(MAX(-50.D0,ALFM*B0*LOG(RLU(0))/FBR)) + ENDIF + IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2 + V(IEP(1),5)=PMSQCD + MCE=1 + +C...Select mass for daughter in QED evolution. + IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN + PMSQED=PMS*EXP(MAX(-50.D0,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE))) + IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED= + & PMTH(2,IFL)**2 + IF(PMSQED.GT.PMSQCD) THEN + V(IEP(1),5)=PMSQED + MCE=2 + ENDIF + ENDIF + +C...Check whether daughter mass below cutoff. + P(IEP(1),5)=SQRT(V(IEP(1),5)) + IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN + P(IEP(1),5)=PMTH(1,IFL) + V(IEP(1),5)=P(IEP(1),5)**2 + GOTO 430 + ENDIF + +C...Select z value of branching: q -> qgamma. + IF(MCE.EQ.2) THEN + Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0) + IF(1.+Z**2.LT.2.*RLU(0)) GOTO 390 + K(IEP(1),5)=22 + +C...Select z value of branching: q -> qg, g -> gg, g -> qqbar. + ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN + Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0) + IF(1.+Z**2.LT.2.*RLU(0)) GOTO 390 + K(IEP(1),5)=21 + ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN + Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0) + IF(RLU(0).GT.0.5) Z=1.-Z + IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 390 + K(IEP(1),5)=21 + ELSEIF(MSTJ(49).NE.1) THEN + Z=ZC+(1.-2.*ZC)*RLU(0) + IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 390 + KFLB=1+INT(MSTJ(45)*RLU(0)) + PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5) + IF(PMQ.GE.1.) GOTO 390 + PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5) + IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT. + & RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 390 + K(IEP(1),5)=KFLB + +C...Ditto for scalar gluon model. + ELSEIF(KFL(1).NE.21) THEN + Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC)) + K(IEP(1),5)=21 + ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN + Z=ZC+(1.-2.*ZC)*RLU(0) + K(IEP(1),5)=21 + ELSE + Z=ZC+(1.-2.*ZC)*RLU(0) + KFLB=1+INT(MSTJ(45)*RLU(0)) + PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5) + IF(PMQ.GE.1.) GOTO 390 + K(IEP(1),5)=KFLB + ENDIF + IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN + IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390 + IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 390 + ENDIF + +C...Check if z consistent with chosen m. + IF(KFL(1).EQ.21) THEN + KFLGD1=IABS(K(IEP(1),5)) + KFLGD2=KFLGD1 + ELSE + KFLGD1=KFL(1) + KFLGD2=IABS(K(IEP(1),5)) + ENDIF + IF(NEP.EQ.1) THEN + PED=PS(4) + ELSEIF(NEP.GE.3) THEN + PED=P(IEP(1),4) + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5) + ELSE + IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM + IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + IFLGD1=KFLGD1 + IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL + PMQTH3=0.5*PARJ(82) + IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83) + PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5) + PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5) + ZD=SQRT(MAX(0.D0,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2- + & 4.*PMQ1*PMQ2))) + ZH=1.+PMQ1-PMQ2 + ELSE + ZD=SQRT(MAX(0.D0,1.-V(IEP(1),5)/PED**2)) + ZH=1. + ENDIF + ZL=0.5*(ZH-ZD) + ZU=0.5*(ZH+ZD) + IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390 + IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1D-20,ZL* + &(1.-ZU))) + IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1D-10,1.-ZU)) + +C...Width suppression for q -> q + g. + IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN + IF(IGM.EQ.0) THEN + EGLU=0.5*PS(5)*(1.-Z)*(1.+V(IEP(1),5)/V(NS+1,5)) + ELSE + EGLU=PMED*(1.-Z) + ENDIF + CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2) + IF(MSTJ(40).EQ.1) THEN + IF(CHI.LT.RLU(0)) GOTO 390 + ELSEIF(MSTJ(40).EQ.2) THEN + IF(1.-CHI.LT.RLU(0)) GOTO 390 + ENDIF + ENDIF + +C...Three-jet matrix element correction. + IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN + X1=Z*(1.+V(IEP(1),5)/V(NS+1,5)) + X2=1.-V(IEP(1),5)/V(NS+1,5) + X3=(1.-X1)+(1.-X2) + IF(MCE.EQ.2) THEN + KI1=K(IPA(INUM),2) + KI2=K(IPA(3-INUM),2) + QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3. + QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3. + WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+ + & QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2) + WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2) + ELSEIF(MSTJ(49).NE.1) THEN + WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+ + & (1.-X2)/X3*(X2/(2.-X1))**2 + WME=X1**2+X2**2 + IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5*QME**2- + & (0.5*QME+0.25*QME**2)*((1.-X2)/MAX(1D-7,1.-X1)+ + & (1.-X1)/MAX(1D-7,1.-X2)) + ELSE + WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2) + WME=X3**2 + IF(MSTJ(102).GE.2) WME=X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)* + & PARJ(171) + ENDIF + IF(WME.LT.RLU(0)*WSHOW) GOTO 390 + +C...Impose angular ordering by rejection of nonordered emission. + ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN + MAOM=1 + ZM=V(IM,1) + IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1) + THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5) + IAOM=IM + 420 IF(K(IAOM,5).EQ.22) THEN + IAOM=K(IAOM,3) + IF(K(IAOM,3).LE.NS) MAOM=0 + IF(MAOM.EQ.1) GOTO 420 + ENDIF + IF(MAOM.EQ.1) THEN + THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5) + IF(THE2ID.LT.THE2IM) GOTO 390 + ENDIF + ENDIF + +C...Impose user-defined maximum angle at first branching. + IF(MSTJ(48).EQ.1) THEN + IF(NEP.EQ.1.AND.IM.EQ.NS) THEN + THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5) + IF(THE2ID.LT.1./PARJ(85)**2) GOTO 390 + ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN + THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5) + IF(THE2ID.LT.1./PARJ(85)**2) GOTO 390 + ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN + THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5) + IF(THE2ID.LT.1./PARJ(86)**2) GOTO 390 + ENDIF + ENDIF + +C...Impose angular constraint in first branching from interference +C...with initial state partons. + IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN + THE2D=MAX((1.-Z)/Z,Z/(1.-Z))*V(IEP(1),5)/(0.5*P(IM,4))**2 + IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN + IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390 + ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN + IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390 + ENDIF + ENDIF + +C...End of inner veto algorithm. Check if only one leg evolved so far. + 430 V(IEP(1),1)=Z + ISL(1)=0 + ISL(2)=0 + IF(NEP.EQ.1) GOTO 460 + IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330 + DO 440 I=1,NEP + IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN + IF(KSH(KFLD(I)).EQ.1) THEN + IFLD=KFLD(I) + IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+ + & ISIGN(2,K(N+I,2)) + IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330 + ENDIF + ENDIF + 440 CONTINUE + +C...Check if chosen multiplet m1,m2,z1,z2 is physical. + IF(NEP.EQ.3) THEN + PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5)) + PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5)) + PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5)) + PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S- + & PA1S**2-PA2S**2-PA3S**2)/PA1S + IF(PTS.LE.0.) GOTO 330 + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN + DO 450 I1=N+1,N+2 + KFLDA=IABS(K(I1,2)) + IF(KFLDA.GT.40) GOTO 450 + IF(KSH(KFLDA).EQ.0) GOTO 450 + IFLDA=KFLDA + IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+ + & ISIGN(2,K(I1,2)) + IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450 + IF(KFLDA.EQ.21) THEN + KFLGD1=IABS(K(I1,5)) + KFLGD2=KFLGD1 + ELSE + KFLGD1=KFLDA + KFLGD2=IABS(K(I1,5)) + ENDIF + I2=2*N+3-I1 + IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) + ELSE + IF(I1.EQ.N+1) ZM=V(IM,1) + IF(I1.EQ.N+2) ZM=1.-V(IM,1) + PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2- + & 4.*V(N+1,5)*V(N+2,5)) + PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5) + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + PMQTH3=0.5*PARJ(82) + IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83) + IFLGD1=KFLGD1 + IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA + PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5) + PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5) + ZD=SQRT(MAX(0.D0,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2- + & 4.*PMQ1*PMQ2))) + ZH=1.+PMQ1-PMQ2 + ELSE + ZD=SQRT(MAX(0.D0,1.-V(I1,5)/PED**2)) + ZH=1. + ENDIF + ZL=0.5*(ZH-ZD) + ZU=0.5*(ZH+ZD) + IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1 + IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1 + IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1D-20,ZL*(1.-ZU))) + IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1D-10,1.-ZU)) + 450 CONTINUE + IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN + ISL(3-ISLM)=0 + ISLM=3-ISLM + ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN + ZDR1=MAX(0.D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1.) + ZDR2=MAX(0.D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1.) + IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0 + IF(ISL(1).EQ.1) ISL(2)=0 + IF(ISL(1).EQ.0) ISLM=1 + IF(ISL(2).EQ.0) ISLM=2 + ENDIF + IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330 + ENDIF + IFLD1=KFLD(1) + IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+ + &ISIGN(2,K(N+1,2)) + IFLD2=KFLD(2) + IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+ + &ISIGN(2,K(N+2,2)) + IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE. + &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN + PMQ1=V(N+1,5)/V(IM,5) + PMQ2=V(N+2,5)/V(IM,5) + ZD=SQRT(MAX(0.D0,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2- + & 4.*PMQ1*PMQ2))) + ZH=1.+PMQ1-PMQ2 + ZL=0.5*(ZH-ZD) + ZU=0.5*(ZH+ZD) + IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330 + ENDIF + +C...Accepted branch. Construct four-momentum for initial partons. + 460 MAZIP=0 + MAZIC=0 + IF(NEP.EQ.1) THEN + P(N+1,1)=0. + P(N+1,2)=0. + P(N+1,3)=SQRT(MAX(0.D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)- + & P(N+1,5)))) + P(N+1,4)=P(IPA(1),4) + V(N+1,2)=P(N+1,4) + ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN + PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5) + P(N+1,1)=0. + P(N+1,2)=0. + P(N+1,3)=SQRT(MAX(0.D0,(PED1+P(N+1,5))*(PED1-P(N+1,5)))) + P(N+1,4)=PED1 + P(N+2,1)=0. + P(N+2,2)=0. + P(N+2,3)=-P(N+1,3) + P(N+2,4)=P(IM,5)-PED1 + V(N+1,2)=P(N+1,4) + V(N+2,2)=P(N+2,4) + ELSEIF(NEP.EQ.3) THEN + P(N+1,1)=0. + P(N+1,2)=0. + P(N+1,3)=SQRT(MAX(0.D0,PA1S)) + P(N+2,1)=SQRT(PTS) + P(N+2,2)=0. + P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3) + P(N+3,1)=-P(N+2,1) + P(N+3,2)=0. + P(N+3,3)=-(P(N+1,3)+P(N+2,3)) + V(N+1,2)=P(N+1,4) + V(N+2,2)=P(N+2,4) + V(N+3,2)=P(N+3,4) + +C...Construct transverse momentum for ordinary branching in shower. + ELSE + ZM=V(IM,1) + PZM=SQRT(MAX(0.D0,(PEM+P(IM,5))*(PEM-P(IM,5)))) + PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5) + IF(PZM.LE.0.) THEN + PTS=0. + ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN + PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)- + & ZM*V(N+2,5))-0.25*PMLS)/PZM**2 + ELSE + PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2 + ENDIF + PT=SQRT(MAX(0.D0,PTS)) + +C...Find coefficient of azimuthal asymmetry due to gluon polarization. + HAZIP=0. + IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21. + & AND.IAU.NE.0) THEN + IF(K(IGM,3).NE.0) MAZIP=1 + ZAU=V(IGM,1) + IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1) + IF(MAZIP.EQ.0) ZAU=0. + IF(K(IGM,2).NE.21) THEN + HAZIP=2.*ZAU/(1.+ZAU**2) + ELSE + HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2 + ENDIF + IF(K(N+1,2).NE.21) THEN + HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM)) + ELSE + HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2 + ENDIF + ENDIF + +C...Find coefficient of azimuthal asymmetry due to soft gluon +C...interference. + HAZIC=0. + IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR. + & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN + IF(K(IGM,3).NE.0) MAZIC=N+1 + IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2 + IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. + & ZM.GT.0.5) MAZIC=N+2 + IF(K(IAU,2).EQ.22) MAZIC=0 + ZS=ZM + IF(MAZIC.EQ.N+2) ZS=1.-ZM + ZGM=V(IGM,1) + IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1) + IF(MAZIC.EQ.0) ZGM=1. + IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))* + & SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM)) + HAZIC=MIN(0.95D0,HAZIC) + ENDIF + ENDIF + +C...Construct kinematics for ordinary branching in shower. + 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN + IF(MOD(MSTJ(43),2).EQ.1) THEN + P(N+1,4)=PEM*V(IM,1) + ELSE + P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ + & SQRT(PMLS)*ZM)/V(IM,5) + ENDIF + PHI=PARU(2)*RLU(0) + P(N+1,1)=PT*COS(PHI) + P(N+1,2)=PT*SIN(PHI) + IF(PZM.GT.0.) THEN + P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM + ELSE + P(N+1,3)=0. + ENDIF + P(N+2,1)=-P(N+1,1) + P(N+2,2)=-P(N+1,2) + P(N+2,3)=PZM-P(N+1,3) + P(N+2,4)=PEM-P(N+1,4) + IF(MSTJ(43).LE.2) THEN + V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5) + V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5) + ENDIF + ENDIF + +C...Rotate and boost daughters. + IF(IGM.GT.0) THEN + IF(MSTJ(43).LE.2) THEN + BEX=P(IGM,1)/P(IGM,4) + BEY=P(IGM,2)/P(IGM,4) + BEZ=P(IGM,3)/P(IGM,4) + GA=P(IGM,4)/P(IGM,5) + GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)- + & P(IM,4)) + ELSE + BEX=0. + BEY=0. + BEZ=0. + GA=1. + GABEP=0. + ENDIF + THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+ + & (P(IM,2)+GABEP*BEY)**2)) + PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) + DO 480 I=N+1,N+2 + DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ + & SIN(THE)*COS(PHI)*P(I,3) + DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ + & SIN(THE)*SIN(PHI)*P(I,3) + DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3) + DP(4)=P(I,4) + DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3) + DGABP=GA*(GA*DBP/(1D0+GA)+DP(4)) + P(I,1)=DP(1)+DGABP*BEX + P(I,2)=DP(2)+DGABP*BEY + P(I,3)=DP(3)+DGABP*BEZ + P(I,4)=GA*(DP(4)+DBP) + 480 CONTINUE + ENDIF + +C...Weight with azimuthal distribution, if required. + IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN + DO 490 J=1,3 + DPT(1,J)=P(IM,J) + DPT(2,J)=P(IAU,J) + DPT(3,J)=P(N+1,J) + 490 CONTINUE + DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3) + DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3) + DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2 + DO 500 J=1,3 + DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM + DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM + 500 CONTINUE + DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) + DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) + IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN + CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ + & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) + IF(MAZIP.NE.0) THEN + IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP))) + & GOTO 470 + ENDIF + IF(MAZIC.NE.0) THEN + IF(MAZIC.EQ.N+2) CAD=-CAD + IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD) + & .LT.RLU(0)) GOTO 470 + ENDIF + ENDIF + ENDIF + +C...Azimuthal anisotropy due to interference with initial state partons. + IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR. + &K(N+2,2).EQ.21)) THEN + III=IM-NS-1 + IF(ISII(III).GE.1) THEN + IAZIID=N+1 + IF(K(N+1,2).NE.21) IAZIID=N+2 + IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. + & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2 + THEIID=ULANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2)) + IF(III.EQ.2) THEIID=PARU(1)-THEIID + PHIIID=ULANGL(P(IAZIID,1),P(IAZIID,2)) + HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III))) + CAD=COS(PHIIID-PHIIIS(III,ISII(III))) + PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III))) + IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL + IF((1.-HAZII)*(1.-HAZII*CAD)/(1.+HAZII**2-2.*HAZII*CAD) + & .LT.RLU(0)) GOTO 470 + ENDIF + ENDIF + +C...Continue loop over partons that may branch, until none left. + IF(IGM.GE.0) K(IM,1)=14 + N=N+NEP + NEP=2 + IF(N.GT.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS') + IF(MSTU(21).GE.1) N=NS + IF(MSTU(21).GE.1) RETURN + ENDIF + GOTO 270 + +C...Set information on imagined shower initiator. + 510 IF(NPA.GE.2) THEN + K(NS+1,1)=11 + K(NS+1,2)=94 + K(NS+1,3)=IP1 + IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2 + K(NS+1,4)=NS+2 + K(NS+1,5)=NS+1+NPA + IIM=1 + ELSE + IIM=0 + ENDIF + +C...Reconstruct string drawing information. + DO 520 I=NS+1+IIM,N + IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN + K(I,1)=1 + ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND. + &IABS(K(I,2)).LE.18) THEN + K(I,1)=1 + ELSEIF(K(I,1).LE.10) THEN + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) + ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN + ID1=MOD(K(I,4),MSTU(5)) + IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1 + ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 + K(ID1,4)=K(ID1,4)+MSTU(5)*I + K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 + K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 + K(ID2,5)=K(ID2,5)+MSTU(5)*I + ELSE + ID1=MOD(K(I,4),MSTU(5)) + ID2=ID1+1 + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 + IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN + K(ID1,4)=K(ID1,4)+MSTU(5)*I + K(ID1,5)=K(ID1,5)+MSTU(5)*I + ELSE + K(ID1,4)=0 + K(ID1,5)=0 + ENDIF + K(ID2,4)=0 + K(ID2,5)=0 + ENDIF + 520 CONTINUE + +C...Transformation from CM frame. + IF(NPA.GE.2) THEN + BEX=PS(1)/PS(4) + BEY=PS(2)/PS(4) + BEZ=PS(3)/PS(4) + GA=PS(4)/PS(5) + GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3)) + & /(1.+GA)-P(IPA(1),4)) + ELSE + BEX=0. + BEY=0. + BEZ=0. + GABEP=0. + ENDIF + THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1) + &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2)) + PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY) + IF(NPA.EQ.3) THEN + CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)* + & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP* + & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+ + & GABEP*BEY)) + MSTU(33)=1 + CALL LUDBRB(NS+1,N,0.D0,CHI,0D0,0D0,0D0) + ENDIF + DBEX=DBLE(BEX) + DBEY=DBLE(BEY) + DBEZ=DBLE(BEZ) + MSTU(33)=1 + CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ) + +C...Decay vertex of shower. + DO 540 I=NS+1,N + DO 530 J=1,5 + V(I,J)=V(IP1,J) + 530 CONTINUE + 540 CONTINUE + +C...Delete trivial shower, else connect initiators. + IF(N.EQ.NS+NPA+IIM) THEN + N=NS + ELSE + DO 550 IP=1,NPA + K(IPA(IP),1)=14 + K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP + K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP + K(NS+IIM+IP,3)=IPA(IP) + IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1 + IF(K(NS+IIM+IP,1).NE.1) THEN + K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4) + K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5) + ENDIF + 550 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUBOEI + SUBROUTINE LUBOEI(NSAV) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to modify event so as to approximately take into account +C...Bose-Einstein effects according to a simple phenomenological +C...parametrization. +C IMPLICIT DOUBLE PRECISION(D) + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUJETS/,/LUDAT1/ + DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100) + DATA KFBE/211,-211,111,321,-321,130,310,221,331/ + +C...Boost event to overall CM frame. Calculate CM energy. + IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN + DO 100 J=1,4 + DPS(J)=0. + 100 CONTINUE + DO 120 I=1,N + KFA=IABS(K(I,2)) + IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22).AND. + &K(I,3).GT.0) THEN + KFMA=IABS(K(K(I,3),2)) + IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1) + ENDIF + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120 + DO 110 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 110 CONTINUE + 120 CONTINUE + CALL LUDBRB(0,0,0.D0,0.D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), + &-DPS(3)/DPS(4)) + PECM=0. + DO 130 I=1,N + IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4) + 130 CONTINUE + +C...Reserve copy of particles by species at end of record. + NBE(0)=N+MSTU(3) + DO 160 IBE=1,MIN(9,MSTJ(52)) + NBE(IBE)=NBE(IBE-1) + DO 150 I=NSAV+1,N + IF(K(I,2).NE.KFBE(IBE)) GOTO 150 + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150 + IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS') + RETURN + ENDIF + NBE(IBE)=NBE(IBE)+1 + K(NBE(IBE),1)=I + DO 140 J=1,3 + P(NBE(IBE),J)=0. + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280 + +C...Tabulate integral for subsequent momentum shift. + DO 220 IBE=1,MIN(9,MSTJ(52)) + IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180 + IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)) + &.LE.1) GOTO 180 + IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5), + &NBE(7)-NBE(6)).LE.1) GOTO 180 + IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180 + IF(IBE.EQ.1) PMHQ=2.*ULMASS(211) + IF(IBE.EQ.4) PMHQ=2.*ULMASS(321) + IF(IBE.EQ.8) PMHQ=2.*ULMASS(221) + IF(IBE.EQ.9) PMHQ=2.*ULMASS(331) + QDEL=0.1*MIN(PMHQ,PARJ(93)) + IF(MSTJ(51).EQ.1) THEN + NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL)) + BEEX=EXP(0.5*QDEL/PARJ(93)) + BERT=EXP(-QDEL/PARJ(93)) + ELSE + NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL)) + ENDIF + DO 170 IBIN=1,NBIN + QBIN=QDEL*(IBIN-0.5) + BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2) + IF(MSTJ(51).EQ.1) THEN + BEEX=BEEX*BERT + BEI(IBIN)=BEI(IBIN)*BEEX + ELSE + BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2) + ENDIF + IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1) + 170 CONTINUE + +C...Loop through particle pairs and find old relative momentum. + 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1 + I1=K(I1M,1) + DO 200 I2M=I1M+1,NBE(IBE) + I2=K(I2M,1) + Q2OLD=MAX(0.D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+ + &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2) + QOLD=SQRT(Q2OLD) + +C...Calculate new relative momentum. + IF(QOLD.LT.1D-3*QDEL) THEN + GOTO 200 + ELSEIF(QOLD.LE.QDEL) THEN + QMOV=QOLD/3. + ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN + RBIN=QOLD/QDEL + IBIN=RBIN + RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1) + QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))* + & SQRT(Q2OLD+PMHQ**2)/Q2OLD + ELSE + QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD + ENDIF + Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.) + +C...Calculate and save shift to be performed on three-momenta. + HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW) + HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2 + HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2))) + DO 190 J=1,3 + PD=HA*(P(I2,J)-P(I1,J)) + P(I1M,J)=P(I1M,J)+PD + P(I2M,J)=P(I2M,J)-PD + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + 220 CONTINUE + +C...Shift momenta and recalculate energies. + DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52))) + I=K(IM,1) + DO 230 J=1,3 + P(I,J)=P(I,J)+P(IM,J) + 230 CONTINUE + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + 240 CONTINUE + +C...Rescale all momenta for energy conservation. + PES=0. + PQS=0. + DO 250 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250 + PES=PES+P(I,4) + PQS=PQS+P(I,5)**2/P(I,4) + 250 CONTINUE + FAC=(PECM-PQS)/(PES-PQS) + DO 270 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270 + DO 260 J=1,3 + P(I,J)=FAC*P(I,J) + 260 CONTINUE + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + 270 CONTINUE + +C...Boost back to correct reference frame. + 280 CALL + & LUDBRB(0,0,0.D0,0.D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4)) + DO 290 I=1,N + IF(K(I,1).LT.0) K(I,1)=-K(I,1) + 290 CONTINUE + + RETURN + END + +C********************************************************************* + +CDECK ID>, ULMASS + FUNCTION ULMASS(KF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to give the mass of a particle/parton. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT1/,/LUDAT2/ + +C...Reset variables. Compressed code. + ULMASS=0. + KFA=IABS(KF) + KC=LUCOMP(KF) + IF(KC.EQ.0) RETURN + PARF(106)=PMAS(6,1) + PARF(107)=PMAS(7,1) + PARF(108)=PMAS(8,1) + +C...Guarantee use of constituent masses for internal checks. + IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN + ULMASS=PARF(100+KFA) + IF(MSTJ(93).EQ.2) ULMASS=MAX(0.D0,ULMASS-PARF(121)) + +C...Masses that can be read directly off table. + ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN + ULMASS=PMAS(KC,1) + +C...Find constituent partons and their masses. + ELSE + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + KFLC=MOD(KFA/10,10) + KFLS=MOD(KFA,10) + KFLR=MOD(KFA/10000,10) + PMA=PARF(100+KFLA) + PMB=PARF(100+KFLB) + PMC=PARF(100+KFLC) + +C...Construct masses for various meson, diquark and baryon cases. + IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN + IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC) + IF(KFLS.GE.3) PMSPL=1./(PMB*PMC) + ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL + ELSEIF(KFLA.EQ.0) THEN + KMUL=2 + IF(KFLS.EQ.1) KMUL=3 + IF(KFLR.EQ.2) KMUL=4 + IF(KFLS.EQ.5) KMUL=5 + ULMASS=PARF(113+KMUL)+PMB+PMC + ELSEIF(KFLC.EQ.0) THEN + IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB) + IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB) + ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL + IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB + IF(MSTJ(93).EQ.2) ULMASS=MAX(0.D0,ULMASS-PARF(122)- + & 2.*PARF(112)/3.) + ELSE + IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN + PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC) + ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN + PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC) + ELSEIF(KFLS.EQ.2) THEN + PMSPL=-3./(PMB*PMC) + ELSE + PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC) + ENDIF + ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL + ENDIF + ENDIF + +C...Optional mass broadening according to truncated Breit-Wigner +C...(either in m or in m^2). + IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN + IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN + ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)* + & ATAN(2.*PMAS(KC,3)/PMAS(KC,2))) + ELSE + PM0=ULMASS + PMLOW=ATAN((MAX(0.D0,PM0-PMAS(KC,3))**2-PM0**2)/ + & (PM0*PMAS(KC,2))) + PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))) + ULMASS=SQRT(MAX(0.D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+ + & (PMUPP-PMLOW)*RLU(0)))) + ENDIF + ENDIF + MSTJ(93)=0 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUNAME + SUBROUTINE LUNAME(KF,CHAU) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to give the particle/parton name as a character string. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT4/CHAF(500) + CHARACTER CHAF*8 + SAVE /LUDAT1/,/LUDAT2/,/LUDAT4/ + CHARACTER CHAU*16 + +C...Initial values. Charge. Subdivide code. + CHAU=' ' + KFA=IABS(KF) + KC=LUCOMP(KF) + IF(KC.EQ.0) RETURN + KQ=LUCHGE(KF) + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + KFLC=MOD(KFA/10,10) + KFLS=MOD(KFA,10) + KFLR=MOD(KFA/10000,10) + +C...Read out root name and spin for simple particle. + IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN + CHAU=CHAF(KC) + LEN=0 + DO 100 LEM=1,8 + IF(CHAU(LEM:LEM).NE.' ') LEN=LEM + 100 CONTINUE + +C...Construct root name for diquark. Add on spin. + ELSEIF(KFLC.EQ.0) THEN + CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1) + IF(KFLS.EQ.1) CHAU(3:4)='_0' + IF(KFLS.EQ.3) CHAU(3:4)='_1' + LEN=4 + +C...Construct root name for heavy meson. Add on spin and heavy flavour. + ELSEIF(KFLA.EQ.0) THEN + IF(KFLB.EQ.5) CHAU(1:1)='B' + IF(KFLB.EQ.6) CHAU(1:1)='T' + IF(KFLB.EQ.7) CHAU(1:1)='L' + IF(KFLB.EQ.8) CHAU(1:1)='H' + LEN=1 + IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN + ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN + CHAU(2:2)='*' + LEN=2 + ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN + CHAU(2:3)='_1' + LEN=3 + ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN + CHAU(2:4)='*_0' + LEN=4 + ELSEIF(KFLR.EQ.2) THEN + CHAU(2:4)='*_1' + LEN=4 + ELSEIF(KFLS.EQ.5) THEN + CHAU(2:4)='*_2' + LEN=4 + ENDIF + IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN + CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1) + LEN=LEN+2 + ELSEIF(KFLC.GE.3) THEN + CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1) + LEN=LEN+1 + ENDIF + +C...Construct root name and spin for heavy baryon. + ELSE + IF(KFLB.LE.2.AND.KFLC.LE.2) THEN + CHAU='Sigma ' + IF(KFLC.GT.KFLB) CHAU='Lambda' + IF(KFLS.EQ.4) CHAU='Sigma*' + LEN=5 + IF(CHAU(6:6).NE.' ') LEN=6 + ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN + CHAU='Xi ' + IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi''' + IF(KFLS.EQ.4) CHAU='Xi*' + LEN=2 + IF(CHAU(3:3).NE.' ') LEN=3 + ELSE + CHAU='Omega ' + IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega''' + IF(KFLS.EQ.4) CHAU='Omega*' + LEN=5 + IF(CHAU(6:6).NE.' ') LEN=6 + ENDIF + +C...Add on heavy flavour content for heavy baryon. + CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1) + LEN=LEN+2 + IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN + CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1) + LEN=LEN+2 + ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN + CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1) + LEN=LEN+1 + ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN + CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1) + LEN=LEN+2 + ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN + CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1) + LEN=LEN+1 + ENDIF + ENDIF + +C...Add on bar sign for antiparticle (where necessary). + IF(KF.GT.0.OR.LEN.EQ.0) THEN + ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0.AND.MOD(KQ,3).EQ.0) + &THEN + ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN + ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN + ELSEIF(MSTU(15).LE.1) THEN + CHAU(LEN+1:LEN+1)='~' + LEN=LEN+1 + ELSE + CHAU(LEN+1:LEN+3)='bar' + LEN=LEN+3 + ENDIF + +C...Add on charge where applicable (conventional cases skipped). + IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++' + IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--' + IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+' + IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-' + IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN + ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN + ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN + ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND. + &KFLB.NE.1) THEN + ELSEIF(KQ.EQ.0) THEN + CHAU(LEN+1:LEN+1)='0' + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUCHGE + FUNCTION LUCHGE(KF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to give three times the charge for a particle/parton. + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT2/ + +C...Initial values. Simple case of direct readout. + LUCHGE=0 + KFA=IABS(KF) + KC=LUCOMP(KFA) + IF(KC.EQ.0) THEN + ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN + LUCHGE=KCHG(KC,1) + +C...Construction from quark content for heavy meson, diquark, baryon. + ELSEIF(MOD(KFA/1000,10).EQ.0) THEN + LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))* + & (-1)**MOD(KFA/100,10) + ELSEIF(MOD(KFA/10,10).EQ.0) THEN + LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1) + ELSE + LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+ + & KCHG(MOD(KFA/10,10),1) + ENDIF + +C...Add on correct sign. + LUCHGE=LUCHGE*ISIGN(1,KF) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUCOMP + FUNCTION LUCOMP(KF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to compress the standard KF codes for use in mass and decay +C...arrays; also to check whether a given code actually is defined. + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT2/ + DIMENSION KFTAB(25),KCTAB(25) + DATA KFTAB/211,111,221,311,321,130,310,213,113,223, + &313,323,2112,2212,210,2110,2210,110,220,330,440,30443,30553,0,0/ + DATA KCTAB/101,111,112,102,103,221,222,121,131,132, + &122,123,332,333,281,282,283,284,285,286,287,231,235,0,0/ + +C...Starting values. + LUCOMP=0 + KFA=IABS(KF) + +C...Simple cases: direct translation or table. + IF(KFA.EQ.0.OR.KFA.GE.100000) THEN + RETURN + ELSEIF(KFA.LE.100) THEN + LUCOMP=KFA + IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0 + RETURN + ELSE + DO 100 IKF=1,23 + IF(KFA.EQ.KFTAB(IKF)) THEN + LUCOMP=KCTAB(IKF) + IF(KF.LT.0.AND.KCHG(LUCOMP,3).EQ.0) LUCOMP=0 + RETURN + ENDIF + 100 CONTINUE + ENDIF + +C...Subdivide KF code into constituent pieces. + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + KFLC=MOD(KFA/10,10) + KFLS=MOD(KFA,10) + KFLR=MOD(KFA/10000,10) + +C...Mesons. + IF(KFA-10000*KFLR.LT.1000) THEN + IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN + ELSEIF(KFLB.LT.KFLC) THEN + ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN + ELSEIF(KFLB.EQ.KFLC) THEN + IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN + LUCOMP=110+KFLB + ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN + LUCOMP=130+KFLB + ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN + LUCOMP=150+KFLB + ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN + LUCOMP=170+KFLB + ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN + LUCOMP=190+KFLB + ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN + LUCOMP=210+KFLB + ENDIF + ELSEIF(KFLB.LE.5) THEN + IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN + LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC + ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN + LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC + ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN + LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC + ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN + LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC + ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN + LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC + ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN + LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC + ENDIF + ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2) + & .OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN + LUCOMP=80+KFLB + ENDIF + +C...Diquarks. + ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN + IF(KFLS.NE.1.AND.KFLS.NE.3) THEN + ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN + ELSEIF(KFLA.LT.KFLB) THEN + ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN + ELSE + LUCOMP=90 + ENDIF + +C...Spin 1/2 baryons. + ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN + IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN + ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN + ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN + LUCOMP=80+KFLA + ELSEIF(KFLB.LT.KFLC) THEN + LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB + ELSE + LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC + ENDIF + +C...Spin 3/2 baryons. + ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN + IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN + ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN + ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN + LUCOMP=80+KFLA + ELSE + LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUERRM + SUBROUTINE LUERRM(MERR,CHMESS) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to inform user of errors in program execution. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUJETS/,/LUDAT1/ + CHARACTER CHMESS*(*) + +C...Write first few warnings, then be silent. + IF(MERR.LE.10) THEN + MSTU(27)=MSTU(27)+1 + MSTU(28)=MERR + IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000) + & MERR,MSTU(31),CHMESS + +C...Write first few errors, then be silent or stop program. + ELSEIF(MERR.LE.20) THEN + MSTU(23)=MSTU(23)+1 + MSTU(24)=MERR-10 + IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100) + & MERR-10,MSTU(31),CHMESS + IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN + WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS + WRITE(MSTU(11),5200) + IF(MERR.NE.17) CALL LULIST(2) + STOP + ENDIF + +C...Stop program in case of irreparable error. + ELSE + WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS + STOP + ENDIF + +C...Formats for output. + 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6, + &' LUEXEC calls:'/5X,A) + 5100 FORMAT(/5X,'Error type',I2,' has occured after',I6, + &' LUEXEC calls:'/5X,A) + 5200 FORMAT(5X,'Execution will be stopped after listing of last ', + &'event!') + 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6, + &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!') + + RETURN + END + +C********************************************************************* + +CDECK ID>, ULALEM + FUNCTION ULALEM(Q2) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to calculate the running alpha_electromagnetic. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUDAT1/ + +C...Calculate real part of photon vacuum polarization. +C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions. +C...For hadrons use parametrization of H. Burkhardt et al. +C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131. + AEMPI=PARU(101)/(3.*PARU(1)) + IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN + RPIGG=0. + ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN + RPIGG=0. + ELSEIF(MSTU(101).EQ.2) THEN + RPIGG=1.-PARU(101)/PARU(103) + ELSEIF(Q2.LT.0.09) THEN + RPIGG=AEMPI*(13.4916+LOG(Q2))+0.00835*LOG(1.+Q2) + ELSEIF(Q2.LT.9.) THEN + RPIGG=AEMPI*(16.3200+2.*LOG(Q2))+0.00238*LOG(1.+3.927*Q2) + ELSEIF(Q2.LT.1E4) THEN + RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00165+0.00299*LOG(1.+Q2) + ELSE + RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00221+0.00293*LOG(1.+Q2) + ENDIF + +C...Calculate running alpha_em. + ULALEM=PARU(101)/(1.-RPIGG) + PARU(108)=ULALEM + + RETURN + END + +C********************************************************************* + +CDECK ID>, ULALPS + FUNCTION ULALPS(Q2) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to give the value of alpha_strong. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT1/,/LUDAT2/ + +C...Constant alpha_strong trivial. + IF(MSTU(111).LE.0) THEN + ULALPS=PARU(111) + MSTU(118)=MSTU(112) + PARU(117)=0. + PARU(118)=PARU(111) + RETURN + ENDIF + +C...Find effective Q2, number of flavours and Lambda. + Q2EFF=Q2 + IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114)) + NF=MSTU(112) + ALAM2=PARU(112)**2 + 100 IF(NF.GT.MAX(2,MSTU(113))) THEN + Q2THR=PARU(113)*PMAS(NF,1)**2 + IF(Q2EFF.LT.Q2THR) THEN + NF=NF-1 + ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF)) + GOTO 100 + ENDIF + ENDIF + 110 IF(NF.LT.MIN(8,MSTU(114))) THEN + Q2THR=PARU(113)*PMAS(NF+1,1)**2 + IF(Q2EFF.GT.Q2THR) THEN + NF=NF+1 + ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF)) + GOTO 110 + ENDIF + ENDIF + IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2 + PARU(117)=SQRT(ALAM2) + +C...Evaluate first or second order alpha_strong. + B0=(33.-2.*NF)/6. + ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2)) + IF(MSTU(111).EQ.1) THEN + ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)) + ELSE + B1=(153.-19.*NF)/6. + ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/ + & (B0**2*ALGQ))) + ENDIF + MSTU(118)=NF + PARU(118)=ULALPS + + RETURN + END + +C********************************************************************* + +CDECK ID>, ULANGL + FUNCTION ULANGL(X,Y) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to reconstruct an angle from given x and y coordinates. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUDAT1/ + + ULANGL=0. + R=SQRT(X**2+Y**2) + IF(R.LT.1D-20) RETURN + IF(ABS(X)/R.LT.0.8) THEN + ULANGL=SIGN(ACOS(X/R),Y) + ELSE + ULANGL=ASIN(Y/R) + IF(X.LT.0..AND.ULANGL.GE.0.) THEN + ULANGL=PARU(1)-ULANGL + ELSEIF(X.LT.0.) THEN + ULANGL=-PARU(1)-ULANGL + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, RLU + FUNCTION RLU(IDUMMY) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to generate random numbers uniformly distributed between +C...0 and 1, excluding the endpoints. + COMMON/LUDATR/MRLU(6),RRLU(100) + SAVE /LUDATR/ + EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)), + &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)), + &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100)) + +C...Initialize generation from given seed. + IF(MRLU2.EQ.0) THEN + IJ=MOD(MRLU1/30082,31329) + KL=MOD(MRLU1,30082) + I=MOD(IJ/177,177)+2 + J=MOD(IJ,177)+2 + K=MOD(KL/169,178)+1 + L=MOD(KL,169) + DO 110 II=1,97 + S=0. + T=0.5 + DO 100 JJ=1,24 + M=MOD(MOD(I*J,179)*K,179) + I=J + J=K + K=M + L=MOD(53*L+1,169) + IF(MOD(L*M,64).GE.32) S=S+T + T=0.5*T + 100 CONTINUE + RRLU(II)=S + 110 CONTINUE + TWOM24=1. + DO 120 I24=1,24 + TWOM24=0.5*TWOM24 + 120 CONTINUE + RRLU98=362436.*TWOM24 + RRLU99=7654321.*TWOM24 + RRLU00=16777213.*TWOM24 + MRLU2=1 + MRLU3=0 + MRLU4=97 + MRLU5=33 + ENDIF + +C...Generate next random number. + 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5) + IF(RUNI.LT.0.) RUNI=RUNI+1. + RRLU(MRLU4)=RUNI + MRLU4=MRLU4-1 + IF(MRLU4.EQ.0) MRLU4=97 + MRLU5=MRLU5-1 + IF(MRLU5.EQ.0) MRLU5=97 + RRLU98=RRLU98-RRLU99 + IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00 + RUNI=RUNI-RRLU98 + IF(RUNI.LT.0.) RUNI=RUNI+1. + IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130 + +C...Update counters. Random number to output. + MRLU3=MRLU3+1 + IF(MRLU3.EQ.1000000000) THEN + MRLU2=MRLU2+1 + MRLU3=0 + ENDIF + RLU=RUNI + + RETURN + END + +C********************************************************************* + +CDECK ID>, RLUGET + SUBROUTINE RLUGET(LFN,MOVE) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to dump the state of the random number generator on a file +C...for subsequent startup from this state onwards. + COMMON/LUDATR/MRLU(6),RRLU(100) + SAVE /LUDATR/ + CHARACTER CHERR*8 + +C...Backspace required number of records (or as many as there are). + IF(MOVE.LT.0) THEN + NBCK=MIN(MRLU(6),-MOVE) + DO 100 IBCK=1,NBCK + BACKSPACE(LFN,ERR=110,IOSTAT=IERR) + 100 CONTINUE + MRLU(6)=MRLU(6)-NBCK + ENDIF + +C...Unformatted write on unit LFN. + WRITE(LFN,ERR=110,IOSTAT=IERR) (MRLU(I1),I1=1,5), + &(RRLU(I2),I2=1,100) + MRLU(6)=MRLU(6)+1 + RETURN + +C...Write error. + 110 WRITE(CHERR,'(I8)') IERR + CALL LUERRM(18,'(RLUGET:) error when accessing file, IOSTAT ='// + &CHERR) + + RETURN + END + +C********************************************************************* + +CDECK ID>, RLUSET + SUBROUTINE RLUSET(LFN,MOVE) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to read a state of the random number generator from a file +C...for subsequent generation from this state onwards. + COMMON/LUDATR/MRLU(6),RRLU(100) + SAVE /LUDATR/ + CHARACTER CHERR*8 + +C...Backspace required number of records (or as many as there are). + IF(MOVE.LT.0) THEN + NBCK=MIN(MRLU(6),-MOVE) + DO 100 IBCK=1,NBCK + BACKSPACE(LFN,ERR=120,IOSTAT=IERR) + 100 CONTINUE + MRLU(6)=MRLU(6)-NBCK + ENDIF + +C...Unformatted read from unit LFN. + NFOR=1+MAX(0,MOVE) + DO 110 IFOR=1,NFOR + READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5), + &(RRLU(I2),I2=1,100) + 110 CONTINUE + MRLU(6)=MRLU(6)+NFOR + RETURN + +C...Write error. + 120 WRITE(CHERR,'(I8)') IERR + CALL LUERRM(18,'(RLUSET:) error when accessing file, IOSTAT ='// + &CHERR) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUROBO + SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to perform rotations and boosts. +C IMPLICIT DOUBLE PRECISION(D) + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUJETS/,/LUDAT1/ + DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4) + +C...Find range of rotation/boost. Convert boost to double precision. + IMIN=1 + IF(MSTU(1).GT.0) IMIN=MSTU(1) + IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + DBX=BEX + DBY=BEY + DBZ=BEZ + GOTO 120 + +C...Entry for specific range and double precision boost. + ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ) + IMIN=IMI + IF(IMIN.LE.0) IMIN=1 + IMAX=IMA + IF(IMAX.LE.0) IMAX=N + DBX=DBEX + DBY=DBEY + DBZ=DBEZ + +C...Optional resetting of V (when not set before.) + IF(MSTU(33).NE.0) THEN + DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4)) + DO 100 J=1,5 + V(I,J)=0. + 100 CONTINUE + 110 CONTINUE + MSTU(33)=0 + ENDIF + +C...Check range of rotation/boost. + 120 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN + CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory') + RETURN + ENDIF + +C...Rotate, typically from z axis to direction (theta,phi). + IF(THE**2+PHI**2.GT.1D-20) THEN + ROT(1,1)=COS(THE)*COS(PHI) + ROT(1,2)=-SIN(PHI) + ROT(1,3)=SIN(THE)*COS(PHI) + ROT(2,1)=COS(THE)*SIN(PHI) + ROT(2,2)=COS(PHI) + ROT(2,3)=SIN(THE)*SIN(PHI) + ROT(3,1)=-SIN(THE) + ROT(3,2)=0. + ROT(3,3)=COS(THE) + DO 150 I=IMIN,IMAX + IF(K(I,1).LE.0) GOTO 150 + DO 130 J=1,3 + PR(J)=P(I,J) + VR(J)=V(I,J) + 130 CONTINUE + DO 140 J=1,3 + P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) + V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3) + 140 CONTINUE + 150 CONTINUE + ENDIF + +C...Boost, typically from rest to momentum/energy=beta. + IF(DBX**2+DBY**2+DBZ**2.GT.1D-20) THEN + DB=SQRT(DBX**2+DBY**2+DBZ**2) + IF(DB.GT.0.99999999D0) THEN +C...Rescale boost vector if too close to unity. + CALL LUERRM(3,'(LUROBO:) boost vector too large') + DBX=DBX*(0.99999999D0/DB) + DBY=DBY*(0.99999999D0/DB) + DBZ=DBZ*(0.99999999D0/DB) + DB=0.99999999D0 + ENDIF + DGA=1D0/SQRT(1D0-DB**2) + DO 170 I=IMIN,IMAX + IF(K(I,1).LE.0) GOTO 170 + DO 160 J=1,4 + DP(J)=P(I,J) + DV(J)=V(I,J) + 160 CONTINUE + DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3) + DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) + P(I,1)=DP(1)+DGABP*DBX + P(I,2)=DP(2)+DGABP*DBY + P(I,3)=DP(3)+DGABP*DBZ + P(I,4)=DGA*(DP(4)+DBP) + DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3) + DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4)) + V(I,1)=DV(1)+DGABV*DBX + V(I,2)=DV(2)+DGABV*DBY + V(I,3)=DV(3)+DGABV*DBZ + V(I,4)=DGA*(DV(4)+DBV) + 170 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUEDIT + SUBROUTINE LUEDIT(MEDIT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to perform global manipulations on the event record, +C...in particular to exclude unstable or undetectable partons/particles. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION NS(2),PTS(2),PLS(2) + +C...Remove unwanted partons/particles. + IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN + IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + I1=MAX(1,MSTU(1))-1 + DO 110 I=MAX(1,MSTU(1)),IMAX + IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110 + IF(MEDIT.EQ.1) THEN + IF(K(I,1).GT.10) GOTO 110 + ELSEIF(MEDIT.EQ.2) THEN + IF(K(I,1).GT.10) GOTO 110 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18) + & GOTO 110 + ELSEIF(MEDIT.EQ.3) THEN + IF(K(I,1).GT.10) GOTO 110 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110 + ELSEIF(MEDIT.EQ.5) THEN + IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110 + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110 + ENDIF + +C...Pack remaining partons/particles. Origin no longer known. + I1=I1+1 + DO 100 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + V(I1,J)=V(I,J) + 100 CONTINUE + K(I1,3)=0 + 110 CONTINUE + IF(I1.LT.N) MSTU(3)=0 + IF(I1.LT.N) MSTU(70)=0 + N=I1 + +C...Selective removal of class of entries. New position of retained. + ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN + I1=0 + DO 120 I=1,N + K(I,3)=MOD(K(I,3),MSTU(5)) + IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120 + IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120 + IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR. + & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120 + IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR. + & K(I,2).EQ.94)) GOTO 120 + IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120 + I1=I1+1 + K(I,3)=K(I,3)+MSTU(5)*I1 + 120 CONTINUE + +C...Find new event history information and replace old. + DO 140 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140 + ID=I + 130 IM=MOD(K(ID,3),MSTU(5)) + IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN + IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND. + & K(IM,2).NE.94) THEN + ID=IM + GOTO 130 + ENDIF + ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN + IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN + ID=IM + GOTO 130 + ENDIF + ENDIF + K(I,3)=MSTU(5)*(K(I,3)/MSTU(5)) + IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5) + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN + IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)= + & K(K(I,4),3)/MSTU(5) + IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)= + & K(K(I,5),3)/MSTU(5) + ELSE + KCM=MOD(K(I,4)/MSTU(5),MSTU(5)) + IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5) + KCD=MOD(K(I,4),MSTU(5)) + IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) + K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD + KCM=MOD(K(I,5)/MSTU(5),MSTU(5)) + IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5) + KCD=MOD(K(I,5),MSTU(5)) + IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) + K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD + ENDIF + 140 CONTINUE + +C...Pack remaining entries. + I1=0 + MSTU90=MSTU(90) + MSTU(90)=0 + DO 170 I=1,N + IF(K(I,3)/MSTU(5).EQ.0) GOTO 170 + I1=I1+1 + DO 150 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + V(I1,J)=V(I,J) + 150 CONTINUE + K(I1,3)=MOD(K(I1,3),MSTU(5)) + DO 160 IZ=1,MSTU90 + IF(I.EQ.MSTU(90+IZ)) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU(90+IZ) + ENDIF + 160 CONTINUE + 170 CONTINUE + IF(I1.LT.N) MSTU(3)=0 + IF(I1.LT.N) MSTU(70)=0 + N=I1 + +C...Fill in some missing daughter pointers (lost in colour flow). + ELSEIF(MEDIT.EQ.16) THEN + DO 190 I=1,N + IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 190 + IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 190 +C...Find daughters who point to mother. + DO 180 I1=I+1,N + IF(K(I1,3).NE.I) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 180 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + IF(K(I,4).NE.0) GOTO 190 +C...Find daughters who point to documentation version of mother. + IM=K(I,3) + IF(IM.LE.0.OR.IM.GE.I) GOTO 190 + IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 190 + IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 190 + DO 182 I1=I+1,N + IF(K(I1,3).NE.IM) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 182 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + IF(K(I,4).NE.0) GOTO 190 +C...Find daughters who point to documentation daughters who, +C...in their turn, point to documentation mother. + ID1=IM + ID2=IM + DO 184 I1=IM+1,I-1 + IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN + ID2=I1 + IF(ID1.EQ.IM) ID1=I1 + ENDIF + 184 CONTINUE + DO 186 I1=I+1,N + IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 186 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + 190 CONTINUE + +C...Save top entries at bottom of LUJETS commonblock. + ELSEIF(MEDIT.EQ.21) THEN + IF(2*N.GE.MSTU(4)) THEN + CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS') + RETURN + ENDIF + DO 210 I=1,N + DO 200 J=1,5 + K(MSTU(4)-I,J)=K(I,J) + P(MSTU(4)-I,J)=P(I,J) + V(MSTU(4)-I,J)=V(I,J) + 200 CONTINUE + 210 CONTINUE + MSTU(32)=N + +C...Restore bottom entries of commonblock LUJETS to top. + ELSEIF(MEDIT.EQ.22) THEN + DO 230 I=1,MSTU(32) + DO 220 J=1,5 + K(I,J)=K(MSTU(4)-I,J) + P(I,J)=P(MSTU(4)-I,J) + V(I,J)=V(MSTU(4)-I,J) + 220 CONTINUE + 230 CONTINUE + N=MSTU(32) + +C...Mark primary entries at top of commonblock LUJETS as untreated. + ELSEIF(MEDIT.EQ.23) THEN + I1=0 + DO 240 I=1,N + KH=K(I,3) + IF(KH.GE.1) THEN + IF(K(KH,1).GT.20) KH=0 + ENDIF + IF(KH.NE.0) GOTO 250 + I1=I1+1 + IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10 + 240 CONTINUE + 250 N=I1 + +C...Place largest axis along z axis and second largest in xy plane. + ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN + CALL LUDBRB(1,N+MSTU(3),0.D0,-ULANGL(P(MSTU(61),1), + & P(MSTU(61),2)),0D0,0D0,0D0) + CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3), + & P(MSTU(61),1)),0.D0,0D0,0D0,0D0) + CALL LUDBRB(1,N+MSTU(3),0.D0,-ULANGL(P(MSTU(61)+1,1), + & P(MSTU(61)+1,2)),0D0,0D0,0D0) + IF(MEDIT.EQ.31) RETURN + +C...Rotate to put slim jet along +z axis. + DO 260 IS=1,2 + NS(IS)=0 + PTS(IS)=0. + PLS(IS)=0. + 260 CONTINUE + DO 270 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 270 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 270 + ENDIF + IS=2.-SIGN(0.5D0,P(I,3)) + NS(IS)=NS(IS)+1 + PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2) + 270 CONTINUE + IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2) + & CALL LUDBRB(1,N+MSTU(3),PARU(1),0.D0,0D0,0D0,0D0) + +C...Rotate to put second largest jet into -z,+x quadrant. + DO 280 I=1,N + IF(P(I,3).GE.0.) GOTO 280 + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 280 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 280 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 280 + ENDIF + IS=2.-SIGN(0.5D0,P(I,1)) + PLS(IS)=PLS(IS)-P(I,3) + 280 CONTINUE + IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.D0,PARU(1), + & 0D0,0D0,0D0) + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LULIST + SUBROUTINE LULIST(MLIST) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to give program heading, or list an event, or particle +C...data, or current parameter values. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/ + CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4 + DIMENSION PS(6) + DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/ + +C...Initialization printout: version number and date of last change. + IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN + CALL LULOGO + MSTU(12)=0 + IF(MLIST.EQ.0) RETURN + ENDIF + +C...List event data, including additional lines after N. + IF(MLIST.GE.1.AND.MLIST.LE.3) THEN + IF(MLIST.EQ.1) WRITE(MSTU(11),5100) + IF(MLIST.EQ.2) WRITE(MSTU(11),5200) + IF(MLIST.EQ.3) WRITE(MSTU(11),5300) + LMX=12 + IF(MLIST.GE.2) LMX=16 + ISTR=0 + IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3))) + IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120 + +C...Get particle name, pad it and check it is not too long. + CALL LUNAME(K(I,2),CHAP) + LEN=0 + DO 100 LEM=1,16 + IF(CHAP(LEM:LEM).NE.' ') LEN=LEM + 100 CONTINUE + MDL=(K(I,1)+19)/10 + LDL=0 + IF(MDL.EQ.2.OR.MDL.GE.8) THEN + CHAC=CHAP + IF(LEN.GT.LMX) CHAC(LMX:LMX)='?' + ELSE + LDL=1 + IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2 + IF(LEN.EQ.0) THEN + CHAC=CHDL(MDL)(1:2*LDL)//' ' + ELSE + CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))// + & CHDL(MDL)(LDL+1:2*LDL)//' ' + IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?' + ENDIF + ENDIF + +C...Add information on string connection. + IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12) + & THEN + KC=LUCOMP(K(I,2)) + KCC=0 + IF(KC.NE.0) KCC=KCHG(KC,2) + IF(IABS(K(I,2)).EQ.39) THEN + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X' + ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN + ISTR=1 + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A' + ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I' + ELSEIF(KCC.NE.0) THEN + ISTR=0 + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V' + ENDIF + ENDIF + +C...Write data for particle/jet. + IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN + WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN + WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MLIST.EQ.1) THEN + WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR. + & K(I,1).EQ.14)) THEN + WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3), + & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000), + & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000), + & (P(I,J2),J2=1,5) + ELSE + WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5) + ENDIF + IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5) + +C...Insert extra separator lines specified by user. + IF(MSTU(70).GE.1) THEN + ISEP=0 + DO 110 J=1,MIN(10,MSTU(70)) + IF(I.EQ.MSTU(70+J)) ISEP=1 + 110 CONTINUE + IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000) + IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100) + ENDIF + 120 CONTINUE + +C...Sum of charges and momenta. + DO 130 J=1,6 + PS(J)=PLU(0,J) + 130 CONTINUE + IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN + WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN + WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.EQ.1) THEN + WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5) + ELSE + WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5) + ENDIF + +C...Give simple list of KF codes defined in program. + ELSEIF(MLIST.EQ.11) THEN + WRITE(MSTU(11),6600) + DO 140 KF=1,40 + CALL LUNAME(KF,CHAP) + CALL LUNAME(-KF,CHAN) + IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP + IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN + 140 CONTINUE + DO 170 KFLS=1,3,2 + DO 160 KFLA=1,8 + DO 150 KFLB=1,KFLA-(3-KFLS)/2 + KF=1000*KFLA+100*KFLB+KFLS + CALL LUNAME(KF,CHAP) + CALL LUNAME(-KF,CHAN) + WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + KF=130 + CALL LUNAME(KF,CHAP) + WRITE(MSTU(11),6700) KF,CHAP + KF=310 + CALL LUNAME(KF,CHAP) + WRITE(MSTU(11),6700) KF,CHAP + DO 200 KMUL=0,5 + KFLS=3 + IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 + IF(KMUL.EQ.5) KFLS=5 + KFLR=0 + IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1 + IF(KMUL.EQ.4) KFLR=2 + DO 190 KFLB=1,8 + DO 180 KFLC=1,KFLB-1 + KF=10000*KFLR+100*KFLB+10*KFLC+KFLS + CALL LUNAME(KF,CHAP) + CALL LUNAME(-KF,CHAN) + WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN + 180 CONTINUE + KF=10000*KFLR+110*KFLB+KFLS + CALL LUNAME(KF,CHAP) + WRITE(MSTU(11),6700) KF,CHAP + 190 CONTINUE + 200 CONTINUE + KF=30443 + CALL LUNAME(KF,CHAP) + WRITE(MSTU(11),6700) KF,CHAP + KF=30553 + CALL LUNAME(KF,CHAP) + WRITE(MSTU(11),6700) KF,CHAP + DO 240 KFLSP=1,3 + KFLS=2+2*(KFLSP/3) + DO 230 KFLA=1,8 + DO 220 KFLB=1,KFLA + DO 210 KFLC=1,KFLB + IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 210 + IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210 + IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS + IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS + CALL LUNAME(KF,CHAP) + CALL LUNAME(-KF,CHAN) + WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN + 210 CONTINUE + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + +C...List parton/particle data table. Check whether to be listed. + ELSEIF(MLIST.EQ.12) THEN + WRITE(MSTU(11),6800) + MSTJ24=MSTJ(24) + MSTJ(24)=0 + KFMAX=30553 + IF(MSTU(2).NE.0) KFMAX=MSTU(2) + DO 270 KF=MAX(1,MSTU(1)),KFMAX + KC=LUCOMP(KF) + IF(KC.EQ.0) GOTO 270 + IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 270 + IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10), + & MOD(KF/100,10)).GT.MSTU(14)) GOTO 270 + IF(MSTU(14).GT.0.AND.KF.GT.100.AND.KC.EQ.90) GOTO 270 + +C...Find particle name and mass. Print information. + CALL LUNAME(KF,CHAP) + IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 270 + CALL LUNAME(-KF,CHAN) + PM=ULMASS(KF) + WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2), + & KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1) + +C...Particle decay: channel number, branching ration, matrix element, +C...decay products. + IF(KF.GT.100.AND.KC.LE.100) GOTO 270 + DO 260 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + DO 250 J=1,5 + CALL LUNAME(KFDP(IDC,J),CHAD(J)) + 250 CONTINUE + WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC), + & (CHAD(J),J=1,5) + 260 CONTINUE + 270 CONTINUE + MSTJ(24)=MSTJ24 + +C...List parameter value table. + ELSEIF(MLIST.EQ.13) THEN + WRITE(MSTU(11),7100) + DO 280 I=1,200 + WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I) + 280 CONTINUE + ENDIF + +C...Format statements for output on unit MSTU(11) (by default 6). + 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS', + &5X,'KF orig p_x p_y p_z E m'/) + 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet', + &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', + &' P(I,2) P(I,3) P(I,4) P(I,5)'/) + 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j', + &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', + &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X, + &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/) + 5400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3) + 5500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2) + 5600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1) + 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5) + 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5) + 5900 FORMAT(66X,5(1X,F12.3)) + 6000 FORMAT(1X,78('=')) + 6100 FORMAT(1X,130('=')) + 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3) + 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2) + 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1) + 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:', + &5F13.5) + 6600 FORMAT(///20X,'List of KF codes in program'/) + 6700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16) + 6800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X, + &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X, + &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off', + &1X,'ME',3X,'Br.rat.',4X,'decay products') + 6900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5), + &2X,F12.5,3X,I2) + 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16) + 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)', + &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)') + 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LULOGO + SUBROUTINE LULOGO + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to write logo for JETSET and PYTHIA programs. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /LUDAT1/ + SAVE /PYPARS/ + CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(22)*36, LINE*79, + &VERS*1, SUBV*3, DATE*2, YEAR*4 + +C...Data on months, logo, titles, and references. + DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', + &'Oct','Nov','Dec'/ + DATA (LOGO(J),J=1,10)/ + &'PPP Y Y TTTTT H H III A ', + &'P P Y Y T H H I A A ', + &'PPP Y T HHHHH I AAAAA', + &'P Y T H H I A A', + &'P Y T H H III A A', + &'JJJJ EEEE TTTTT SSS EEEE TTTTT', + &' J E T S E T ', + &' J EEE T SSS EEE T ', + &'J J E T S E T ', + &' JJ EEEE T SSS EEEE T '/ + DATA (LOGO(J),J=11,29)/ + &' *......* ', + &' *:::!!:::::::::::* ', + &' *::::::!!::::::::::::::* ', + &' *::::::::!!::::::::::::::::* ', + &' *:::::::::!!:::::::::::::::::* ', + &' *:::::::::!!:::::::::::::::::* ', + &' *::::::::!!::::::::::::::::*! ', + &' *::::::!!::::::::::::::* !! ', + &' !! *:::!!:::::::::::* !! ', + &' !! !* -><- * !! ', + &' !! !! !! ', + &' !! !! !! ', + &' !! !! ', + &' !! ep !! ', + &' !! !! ', + &' !! pp !! ', + &' !! e+e- !! ', + &' !! !! ', + &' !! '/ + DATA (LOGO(J),J=30,48)/ + &'Welcome to the Lund Monte Carlo!', + &' ', + &' This is PYTHIA version x.xxx ', + &'Last date of change: xx xxx 199x', + &' ', + &' This is JETSET version x.xxx ', + &'Last date of change: xx xxx 199x', + &' ', + &' Main author: ', + &' Torbjorn Sjostrand ', + &' Dept. of theoretical physics 2 ', + &' University of Lund ', + &' Solvegatan 14A ', + &' S-223 62 Lund, Sweden ', + &' phone: +46 - 46 - 222 48 16 ', + &' E-mail: torbjorn@thep.lu.se ', + &' ', + &' Copyright Torbjorn Sjostrand ', + &' and CERN, Geneva 1993 '/ + DATA (REFER(J),J=1,6)/ + &'The latest program versions and docu', + &'mentation is found on WWW address ', + &'http://thep.lu.se/tf2/staff/torbjorn', + &'/Welcome.html ', + &' ', + &' '/ + DATA (REFER(J),J=7,22)/ + &'When you cite these programs, priori', + &'ty should always be given to the ', + &'latest published description. Curren', + &'tly this is ', + &'T. Sjostrand, Computer Physics Commu', + &'n. 82 (1994) 74. ', + &'The most recent long description (un', + &'published) is ', + &'T. Sjostrand, LU TP 95-20 and CERN-T', + &'H.7112/93 (revised August 1995). ', + &'Also remember that the programs, to ', + &'a large extent, represent original ', + &'physics research. Other publications', + &' of special relevance to your ', + &'studies may therefore deserve separa', + &'te mention. '/ + +C...Check if PYTHIA linked. + IF(MSTP(183)/10.NE.199) THEN + LOGO(32)=' Warning: PYTHIA is not loaded! ' + LOGO(33)='Did you remember to link PYDATA?' + ELSE + WRITE(VERS,'(I1)') MSTP(181) + LOGO(32)(26:26)=VERS + WRITE(SUBV,'(I3)') MSTP(182) + LOGO(32)(28:30)=SUBV + WRITE(DATE,'(I2)') MSTP(185) + LOGO(33)(22:23)=DATE + LOGO(33)(25:27)=MONTH(MSTP(184)) + WRITE(YEAR,'(I4)') MSTP(183) + LOGO(33)(29:32)=YEAR + ENDIF + +C...Check if JETSET linked. + IF(MSTU(183)/10.NE.199) THEN + LOGO(35)=' Error: JETSET is not loaded! ' + LOGO(36)='Did you remember to link LUDATA?' + ELSE + WRITE(VERS,'(I1)') MSTU(181) + LOGO(35)(26:26)=VERS + WRITE(SUBV,'(I3)') MSTU(182) + LOGO(35)(28:30)=SUBV + WRITE(DATE,'(I2)') MSTU(185) + LOGO(36)(22:23)=DATE + LOGO(36)(25:27)=MONTH(MSTU(184)) + WRITE(YEAR,'(I4)') MSTU(183) + LOGO(36)(29:32)=YEAR + ENDIF + +C...Loop over lines in header. Define page feed and side borders. + DO 100 ILIN=1,48 + LINE=' ' + IF(ILIN.EQ.1) THEN + LINE(1:1)='1' + ELSE + LINE(2:3)='**' + LINE(78:79)='**' + ENDIF + +C...Separator lines and logos. + IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.EQ.47.OR.ILIN.EQ.48) THEN + LINE(4:77)='***********************************************'// + & '***************************' + ELSEIF(ILIN.GE.6.AND.ILIN.LE.10) THEN + LINE(6:37)=LOGO(ILIN-5) + LINE(44:75)=LOGO(ILIN) + ELSEIF(ILIN.GE.13.AND.ILIN.LE.31) THEN + LINE(6:37)=LOGO(ILIN-2) + LINE(44:75)=LOGO(ILIN+17) + ELSEIF(ILIN.GE.34.AND.ILIN.LE.44) THEN + LINE(5:40)=REFER(2*ILIN-67) + LINE(41:76)=REFER(2*ILIN-66) + ENDIF + +C...Write lines to appropriate unit. + IF(MSTU(183)/10.EQ.199) THEN + WRITE(MSTU(11),'(A79)') LINE + ELSE + WRITE(*,'(A79)') LINE + ENDIF + 100 CONTINUE + +C...Check that matching subversions are linked. + IF(MSTU(183)/10.EQ.199.AND.MSTP(183)/10.EQ.199) THEN + IF(MSTU(182).LT.MSTP(186)) WRITE(MSTU(11), + & '(/'' Warning: JETSET subversion too old for PYTHIA''/)') + IF(MSTP(182).LT.MSTU(186)) WRITE(MSTU(11), + & '(/'' Warning: PYTHIA subversion too old for JETSET''/)') + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUUPDA + SUBROUTINE LUUPDA(MUPDA,LFN) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to facilitate the updating of particle and decay data. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + COMMON/LUDAT4/CHAF(500) + CHARACTER CHAF*8 + SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/ + CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72, + &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12 + DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)', + &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)', + &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)', + &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/ + +C...Write information on file for editing. + IF(MSTU(12).GE.1) CALL LULIST(0) + IF(MUPDA.EQ.1) THEN + DO 110 KC=1,MSTU(6) + WRITE(LFN,5000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3), + & (PMAS(KC,J2),J2=1,4),MDCY(KC,1) + DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC), + & (KFDP(IDC,J),J=1,5) + 100 CONTINUE + 110 CONTINUE + +C...Reset variables and read information from edited file. + ELSEIF(MUPDA.EQ.2) THEN + DO 130 I=1,MSTU(7) + MDME(I,1)=1 + MDME(I,2)=0 + BRAT(I)=0. + DO 120 J=1,5 + KFDP(I,J)=0 + 120 CONTINUE + 130 CONTINUE + KC=0 + IDC=0 + NDC=0 + 140 READ(LFN,5200,END=150) CHINL + IF(CHINL(2:5).NE.' ') THEN + CHKC=CHINL(2:5) + IF(KC.NE.0) THEN + MDCY(KC,2)=0 + IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC + MDCY(KC,3)=NDC + ENDIF + READ(CHKC,5300) KC + IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27, + & '(LUUPDA:) Read KC code illegal, KC ='//CHKC) + READ(CHINL,5000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3), + & (PMAS(KC,J2),J2=1,4),MDCY(KC,1) + NDC=0 + ELSE + IDC=IDC+1 + NDC=NDC+1 + IF(IDC.GE.MSTU(7)) CALL LUERRM(27, + & '(LUUPDA:) Decay data arrays full by KC ='//CHKC) + READ(CHINL,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC), + & (KFDP(IDC,J),J=1,5) + ENDIF + GOTO 140 + 150 MDCY(KC,2)=0 + IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC + MDCY(KC,3)=NDC + +C...Perform possible tests that new information is consistent. + MSTJ24=MSTJ(24) + MSTJ(24)=0 + DO 180 KC=1,MSTU(6) + WRITE(CHKC,5300) KC + IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3), + & PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17, + & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC) + BRSUM=0. + DO 170 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + IF(MDME(IDC,2).GT.80) GOTO 170 + KQ=KCHG(KC,1) + PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) + MERR=0 + DO 160 J=1,5 + KP=KFDP(IDC,J) + IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN + ELSEIF(LUCOMP(KP).EQ.0) THEN + MERR=3 + ELSE + KQ=KQ-LUCHGE(KP) + PMS=PMS-ULMASS(KP) + ENDIF + 160 CONTINUE + IF(KQ.NE.0) MERR=MAX(2,MERR) + IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND. + & (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND. + & MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR) + IF(MERR.EQ.3) CALL LUERRM(17, + & '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC) + IF(MERR.EQ.2) CALL LUERRM(17, + & '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC) + IF(MERR.EQ.1) CALL LUERRM(7, + & '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC) + BRSUM=BRSUM+BRAT(IDC) + 170 CONTINUE + WRITE(CHTMP,5500) BRSUM + IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL + & LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)// + & ' for KC ='//CHKC) + 180 CONTINUE + MSTJ(24)=MSTJ24 + +C...Initialize writing of DATA statements for inclusion in program. + ELSEIF(MUPDA.EQ.3) THEN + DO 250 IVAR=1,19 + NDIM=MSTU(6) + IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7) + NLIN=1 + CHLIN=' ' + CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/' + LLIN=35 + CHOLD='START' + +C...Loop through variables for conversion to characters. + DO 230 IDIM=1,NDIM + IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1) + IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2) + IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3) + IF(IVAR.EQ.4) WRITE(CHTMP,5500) PMAS(IDIM,1) + IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,2) + IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,3) + IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,4) + IF(IVAR.EQ.8) WRITE(CHTMP,5400) MDCY(IDIM,1) + IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,2) + IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,3) + IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDME(IDIM,1) + IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,2) + IF(IVAR.EQ.13) WRITE(CHTMP,5500) BRAT(IDIM) + IF(IVAR.EQ.14) WRITE(CHTMP,5400) KFDP(IDIM,1) + IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,2) + IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,3) + IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,4) + IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,5) + IF(IVAR.EQ.19) CHTMP=CHAF(IDIM) + +C...Length of variable, trailing decimal zeros, quotation marks. + LLOW=1 + LHIG=1 + DO 190 LL=1,12 + IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL + IF(CHTMP(LL:LL).NE.' ') LHIG=LL + 190 CONTINUE + CHNEW=CHTMP(LLOW:LHIG)//' ' + LNEW=1+LHIG-LLOW + IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN + LNEW=LNEW+1 + 200 LNEW=LNEW-1 + IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 200 + IF(LNEW.EQ.1) CHNEW(1:2)='0.' + IF(LNEW.EQ.1) LNEW=2 + ELSEIF(IVAR.EQ.19) THEN + DO 210 LL=LNEW,1,-1 + IF(CHNEW(LL:LL).EQ.'''') THEN + CHTMP=CHNEW + CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11) + LNEW=LNEW+1 + ENDIF + 210 CONTINUE + CHTMP=CHNEW + CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//'''' + LNEW=LNEW+2 + ENDIF + +C...Form composite character string, often including repetition counter. + IF(CHNEW.NE.CHOLD) THEN + NRPT=1 + CHOLD=CHNEW + CHCOM=CHNEW + LCOM=LNEW + ELSE + LRPT=LNEW+1 + IF(NRPT.GE.2) LRPT=LNEW+3 + IF(NRPT.GE.10) LRPT=LNEW+4 + IF(NRPT.GE.100) LRPT=LNEW+5 + IF(NRPT.GE.1000) LRPT=LNEW+6 + LLIN=LLIN-LRPT + NRPT=NRPT+1 + WRITE(CHTMP,5400) NRPT + LRPT=1 + IF(NRPT.GE.10) LRPT=2 + IF(NRPT.GE.100) LRPT=3 + IF(NRPT.GE.1000) LRPT=4 + CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW) + LCOM=LRPT+1+LNEW + ENDIF + +C...Add characters to end of line, to new line (after storing old line), +C...or to new block of lines (after writing old block). + IF(LLIN+LCOM.LE.70) THEN + CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//',' + LLIN=LLIN+LCOM+1 + ELSEIF(NLIN.LE.19) THEN + CHLIN(LLIN+1:72)=' ' + CHBLK(NLIN)=CHLIN + NLIN=NLIN+1 + CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//',' + LLIN=6+LCOM+1 + ELSE + CHLIN(LLIN:72)='/'//' ' + CHBLK(NLIN)=CHLIN + WRITE(CHTMP,5400) IDIM-NRPT + CHBLK(1)(30:33)=CHTMP(9:12) + DO 220 ILIN=1,NLIN + WRITE(LFN,5600) CHBLK(ILIN) + 220 CONTINUE + NLIN=1 + CHLIN=' ' + CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I= , )/'// + & CHCOM(1:LCOM)//',' + WRITE(CHTMP,5400) IDIM-NRPT+1 + CHLIN(25:28)=CHTMP(9:12) + LLIN=35+LCOM+1 + ENDIF + 230 CONTINUE + +C...Write final block of lines. + CHLIN(LLIN:72)='/'//' ' + CHBLK(NLIN)=CHLIN + WRITE(CHTMP,5400) NDIM + CHBLK(1)(30:33)=CHTMP(9:12) + DO 240 ILIN=1,NLIN + WRITE(LFN,5600) CHBLK(ILIN) + 240 CONTINUE + 250 CONTINUE + ENDIF + +C...Formats for reading and writing particle data. + 5000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3) + 5100 FORMAT(5X,2I5,F12.5,5I8) + 5200 FORMAT(A80) + 5300 FORMAT(I4) + 5400 FORMAT(I12) + 5500 FORMAT(F12.5) + 5600 FORMAT(A72) + + RETURN + END + +C********************************************************************* + +CDECK ID>, KLU + FUNCTION KLU(I,J) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to provide various integer-valued event related data. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Default value. For I=0 number of entries, number of stable entries +C...or 3 times total charge. + KLU=0 + IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN + ELSEIF(I.EQ.0.AND.J.EQ.1) THEN + KLU=N + ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN + DO 100 I1=1,N + IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+1 + IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+ + & LUCHGE(K(I1,2)) + 100 CONTINUE + ELSEIF(I.EQ.0) THEN + +C...For I > 0 direct readout of K matrix or charge. + ELSEIF(J.LE.5) THEN + KLU=K(I,J) + ELSEIF(J.EQ.6) THEN + KLU=LUCHGE(K(I,2)) + +C...Status (existing/fragmented/decayed), parton/hadron separation. + ELSEIF(J.LE.8) THEN + IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLU=1 + IF(J.EQ.8) KLU=KLU*K(I,2) + ELSEIF(J.LE.12) THEN + KFA=IABS(K(I,2)) + KC=LUCOMP(KFA) + KQ=0 + IF(KC.NE.0) KQ=KCHG(KC,2) + IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLU=K(I,2) + IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLU=K(I,2) + IF(J.EQ.11) KLU=KC + IF(J.EQ.12) KLU=KQ*ISIGN(1,K(I,2)) + +C...Heaviest flavour in hadron/diquark. + ELSEIF(J.EQ.13) THEN + KFA=IABS(K(I,2)) + KLU=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10) + IF(KFA.LT.10) KLU=KFA + IF(MOD(KFA/1000,10).NE.0) KLU=MOD(KFA/1000,10) + KLU=KLU*ISIGN(1,K(I,2)) + +C...Particle history: generation, ancestor, rank. + ELSEIF(J.LE.15) THEN + I2=I + I1=I + 110 KLU=KLU+1 + I2=I1 + I1=K(I1,3) + IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110 + IF(J.EQ.15) KLU=I2 + ELSEIF(J.EQ.16) THEN + KFA=IABS(K(I,2)) + IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR. + & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN + I1=I + 120 I2=I1 + I1=K(I1,3) + IF(I1.GT.0) THEN + KFAM=IABS(K(I1,2)) + ILP=1 + IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0 + IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93) + & ILP=0 + IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0 + IF(ILP.EQ.1) GOTO 120 + ENDIF + IF(K(I1,1).EQ.12) THEN + DO 130 I3=I1+1,I2 + IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92 + & .AND.K(I3,2).NE.93) KLU=KLU+1 + 130 CONTINUE + ELSE + I3=I2 + 140 KLU=KLU+1 + I3=I3+1 + IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140 + ENDIF + ENDIF + +C...Particle coming from collapsing jet system or not. + ELSEIF(J.EQ.17) THEN + I1=I + 150 KLU=KLU+1 + I3=I1 + I1=K(I1,3) + I0=MAX(1,I1) + KC=LUCOMP(K(I0,2)) + IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN + IF(KLU.EQ.1) KLU=-1 + IF(KLU.GT.1) KLU=0 + RETURN + ENDIF + IF(KCHG(KC,2).EQ.0) GOTO 150 + IF(K(I1,1).NE.12) KLU=0 + IF(K(I1,1).NE.12) RETURN + I2=I1 + 160 I2=I2+1 + IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160 + K3M=K(I3-1,3) + IF(K3M.GE.I1.AND.K3M.LE.I2) KLU=0 + K3P=K(I3+1,3) + IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLU=0 + +C...Number of decay products. Colour flow. + ELSEIF(J.EQ.18) THEN + IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLU=MAX(0,K(I,5)-K(I,4)+1) + IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLU=0 + ELSEIF(J.LE.22) THEN + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN + IF(J.EQ.19) KLU=MOD(K(I,4)/MSTU(5),MSTU(5)) + IF(J.EQ.20) KLU=MOD(K(I,5)/MSTU(5),MSTU(5)) + IF(J.EQ.21) KLU=MOD(K(I,4),MSTU(5)) + IF(J.EQ.22) KLU=MOD(K(I,5),MSTU(5)) + ELSE + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, PLU + FUNCTION PLU(I,J) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to provide various real-valued event related data. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION PSUM(4) + +C...Set default value. For I = 0 sum of momenta or charges, +C...or invariant mass of system. + PLU=0. + IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN + ELSEIF(I.EQ.0.AND.J.LE.4) THEN + DO 100 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J) + 100 CONTINUE + ELSEIF(I.EQ.0.AND.J.EQ.5) THEN + DO 120 J1=1,4 + PSUM(J1)=0. + DO 110 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1) + 110 CONTINUE + 120 CONTINUE + PLU=SQRT(MAX(0.D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) + ELSEIF(I.EQ.0.AND.J.EQ.6) THEN + DO 130 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3. + 130 CONTINUE + ELSEIF(I.EQ.0) THEN + +C...Direct readout of P matrix. + ELSEIF(J.LE.5) THEN + PLU=P(I,J) + +C...Charge, total momentum, transverse momentum, transverse mass. + ELSEIF(J.LE.12) THEN + IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3. + IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2 + IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2 + IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2 + IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU) + +C...Theta and phi angle in radians or degrees. + ELSEIF(J.LE.16) THEN + IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) + IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2)) + IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1) + +C...True rapidity, rapidity with pion mass, pseudorapidity. + ELSEIF(J.LE.19) THEN + PMR=0. + IF(J.EQ.17) PMR=P(I,5) + IF(J.EQ.18) PMR=ULMASS(211) + PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) + PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), + & 1D20)),P(I,3)) + +C...Energy and momentum fractions (only to be used in CM frame). + ELSEIF(J.LE.25) THEN + IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) + IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21) + IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21) + IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21) + IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21) + IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21) + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUSPHE + SUBROUTINE LUSPHE(SPH,APL) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to perform sphericity tensor analysis to give sphericity, +C...aplanarity and the related event axes. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION SM(3,3),SV(3,3) + +C...Calculate matrix to be diagonalized. + NP=0 + DO 110 J1=1,3 + DO 100 J2=J1,3 + SM(J1,J2)=0. + 100 CONTINUE + 110 CONTINUE + PS=0. + DO 140 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 140 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 140 + ENDIF + NP=NP+1 + PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + PWT=1. + IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1D-10,PA)**(PARU(41)-2.) + DO 130 J1=1,3 + DO 120 J2=J1,3 + SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2) + 120 CONTINUE + 130 CONTINUE + PS=PS+PWT*PA**2 + 140 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL LUERRM(8,'(LUSPHE:) too few particles for analysis') + SPH=-1. + APL=-1. + RETURN + ENDIF + DO 160 J1=1,3 + DO 150 J2=J1,3 + SM(J1,J2)=SM(J1,J2)/PS + 150 CONTINUE + 160 CONTINUE + +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.D0),-1.D0))/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.1D-5) THEN + CALL LUERRM(8,'(LUSPHE:) all particles back-to-back') + SPH=-1. + APL=-1. + RETURN + ENDIF + +C...Find first and last eigenvector by solving equation system. + DO 240 I=1,3,2 + DO 180 J1=1,3 + SV(J1,J1)=SM(J1,J1)-P(N+I,4) + DO 170 J2=J1+1,3 + SV(J1,J2)=SM(J1,J2) + SV(J2,J1)=SM(J1,J2) + 170 CONTINUE + 180 CONTINUE + SMAX=0. + DO 200 J1=1,3 + DO 190 J2=1,3 + IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190 + JA=J1 + JB=J2 + SMAX=ABS(SV(J1,J2)) + 190 CONTINUE + 200 CONTINUE + SMAX=0. + DO 220 J3=JA+1,JA+2 + J1=J3-3*((J3-1)/3) + RL=SV(J1,JB)/SV(JA,JB) + DO 210 J2=1,3 + SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2) + IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210 + JC=J1 + SMAX=ABS(SV(J1,J2)) + 210 CONTINUE + 220 CONTINUE + JB1=JB+1-3*(JB/3) + JB2=JB+2-3*((JB+1)/3) + P(N+I,JB1)=-SV(JC,JB2) + P(N+I,JB2)=SV(JC,JB1) + P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/ + &SV(JA,JB) + PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) + SGN=(-1.)**INT(RLU(0)+0.5) + DO 230 J=1,3 + P(N+I,J)=SGN*P(N+I,J)/PA + 230 CONTINUE + 240 CONTINUE + +C...Middle axis orthogonal to other two. Fill other codes. + SGN=(-1.)**INT(RLU(0)+0.5) + P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2)) + P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3)) + P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1)) + DO 260 I=1,3 + K(N+I,1)=31 + K(N+I,2)=95 + K(N+I,3)=I + K(N+I,4)=0 + K(N+I,5)=0 + P(N+I,5)=0. + DO 250 J=1,5 + V(I,J)=0. + 250 CONTINUE + 260 CONTINUE + +C...Calculate sphericity and aplanarity. Select storing option. + SPH=1.5*(P(N+2,4)+P(N+3,4)) + APL=1.5*P(N+3,4) + MSTU(61)=N+1 + MSTU(62)=NP + IF(MSTU(43).LE.1) MSTU(3)=3 + IF(MSTU(43).GE.2) N=N+3 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUTHRU + SUBROUTINE LUTHRU(THR,OBL) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to perform thrust analysis to give thrust, oblateness +C...and the related event axes. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION TDI(3),TPR(3) + +C...Take copy of particles that are to be considered in thrust analysis. + NP=0 + PS=0. + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 100 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 100 + ENDIF + IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUTHRU:) no more memory left in LUJETS') + THR=-2. + OBL=-2. + RETURN + ENDIF + NP=NP+1 + K(N+NP,1)=23 + P(N+NP,1)=P(I,1) + P(N+NP,2)=P(I,2) + P(N+NP,3)=P(I,3) + P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(N+NP,5)=1. + IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.) + PS=PS+P(N+NP,4)*P(N+NP,5) + 100 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL LUERRM(8,'(LUTHRU:) too few particles for analysis') + THR=-1. + OBL=-1. + RETURN + ENDIF + +C...Loop over thrust and major. T axis along z direction in latter case. + DO 320 ILD=1,2 + IF(ILD.EQ.2) THEN + K(N+NP+1,1)=31 + PHI=ULANGL(P(N+NP+1,1),P(N+NP+1,2)) + MSTU(33)=1 + CALL LUDBRB(N+1,N+NP+1,0.D0,-PHI,0D0,0D0,0D0) + THE=ULANGL(P(N+NP+1,3),P(N+NP+1,1)) + CALL LUDBRB(N+1,N+NP+1,-THE,0.D0,0D0,0D0,0D0) + ENDIF + +C...Find and order particles with highest p (pT for major). + DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4 + P(ILF,4)=0. + 110 CONTINUE + DO 160 I=N+1,N+NP + IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2) + DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1 + IF(P(I,4).LE.P(ILF,4)) GOTO 140 + DO 120 J=1,5 + P(ILF+1,J)=P(ILF,J) + 120 CONTINUE + 130 CONTINUE + ILF=N+NP+3 + 140 DO 150 J=1,5 + P(ILF+1,J)=P(I,J) + 150 CONTINUE + 160 CONTINUE + +C...Find and order initial axes with highest thrust (major). + DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15 + P(ILG,4)=0. + 170 CONTINUE + NC=2**(MIN(MSTU(44),NP)-1) + DO 250 ILC=1,NC + DO 180 J=1,3 + TDI(J)=0. + 180 CONTINUE + DO 200 ILF=1,MIN(MSTU(44),NP) + SGN=P(N+NP+ILF+3,5) + IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN + DO 190 J=1,4-ILD + TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J) + 190 CONTINUE + 200 CONTINUE + TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2 + DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1 + IF(TDS.LE.P(ILG,4)) GOTO 230 + DO 210 J=1,4 + P(ILG+1,J)=P(ILG,J) + 210 CONTINUE + 220 CONTINUE + ILG=N+NP+MSTU(44)+4 + 230 DO 240 J=1,3 + P(ILG+1,J)=TDI(J) + 240 CONTINUE + P(ILG+1,4)=TDS + 250 CONTINUE + +C...Iterate direction of axis until stable maximum. + P(N+NP+ILD,4)=0. + ILG=0 + 260 ILG=ILG+1 + THP=0. + 270 THPS=THP + DO 280 J=1,3 + IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J) + IF(THP.GT.1D-10) TDI(J)=TPR(J) + TPR(J)=0. + 280 CONTINUE + DO 300 I=N+1,N+NP + SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3)) + DO 290 J=1,4-ILD + TPR(J)=TPR(J)+SGN*P(I,J) + 290 CONTINUE + 300 CONTINUE + THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS + IF(THP.GE.THPS+PARU(48)) GOTO 270 + +C...Save good axis. Try new initial axis until a number of tries agree. + IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260 + IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN + IAGR=0 + SGN=(-1.)**INT(RLU(0)+0.5) + DO 310 J=1,3 + P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP) + 310 CONTINUE + P(N+NP+ILD,4)=THP + P(N+NP+ILD,5)=0. + ENDIF + IAGR=IAGR+1 + IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260 + 320 CONTINUE + +C...Find minor axis and value by orthogonality. + SGN=(-1.)**INT(RLU(0)+0.5) + P(N+NP+3,1)=-SGN*P(N+NP+2,2) + P(N+NP+3,2)=SGN*P(N+NP+2,1) + P(N+NP+3,3)=0. + THP=0. + DO 330 I=N+1,N+NP + THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2)) + 330 CONTINUE + P(N+NP+3,4)=THP/PS + P(N+NP+3,5)=0. + +C...Fill axis information. Rotate back to original coordinate system. + DO 350 ILD=1,3 + K(N+ILD,1)=31 + K(N+ILD,2)=96 + K(N+ILD,3)=ILD + K(N+ILD,4)=0 + K(N+ILD,5)=0 + DO 340 J=1,5 + P(N+ILD,J)=P(N+NP+ILD,J) + V(N+ILD,J)=0. + 340 CONTINUE + 350 CONTINUE + CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0) + +C...Calculate thrust and oblateness. Select storing option. + THR=P(N+1,4) + OBL=P(N+2,4)-P(N+3,4) + MSTU(61)=N+1 + MSTU(62)=NP + IF(MSTU(43).LE.1) MSTU(3)=3 + IF(MSTU(43).GE.2) N=N+3 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUCLUS + SUBROUTINE LUCLUS(NJET) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to subdivide the particle content of an event into +C...jets/clusters. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION PS(5) + SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM + +C...Functions: distance measure in pT or (pseudo)mass. + R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)- + &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2 + R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)* + &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5))) + +C...If first time, reset. If reentering, skip preliminaries. + IF(MSTU(48).LE.0) THEN + NP=0 + DO 100 J=1,5 + PS(J)=0. + 100 CONTINUE + PSS=0. + ELSE + NJET=NSAV + IF(MSTU(43).GE.2) N=N-NJET + DO 110 I=N+1,N+NJET + P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + 110 CONTINUE + IF(MSTU(46).LE.3) R2ACC=PARU(44)**2 + IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2 + NLOOP=0 + GOTO 300 + ENDIF + +C...Find which particles are to be considered in cluster search. + DO 140 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 140 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 140 + ENDIF + IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUCLUS:) no more memory left in LUJETS') + NJET=-1 + RETURN + ENDIF + +C...Take copy of these particles, with space left for jets later on. + NP=NP+1 + K(N+NP,3)=I + DO 120 J=1,5 + P(N+NP,J)=P(I,J) + 120 CONTINUE + IF(MSTU(42).EQ.0) P(N+NP,5)=0. + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1) + P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + DO 130 J=1,4 + PS(J)=PS(J)+P(N+NP,J) + 130 CONTINUE + PSS=PSS+P(N+NP,5) + 140 CONTINUE + DO 160 I=N+1,N+NP + K(I+NP,3)=K(I,3) + DO 150 J=1,5 + P(I+NP,J)=P(I,J) + 150 CONTINUE + 160 CONTINUE + PS(5)=SQRT(MAX(0.D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) + +C...Very low multiplicities not considered. + IF(NP.LT.MSTU(47)) THEN + CALL LUERRM(8,'(LUCLUS:) too few particles for analysis') + NJET=-1 + RETURN + ENDIF + +C...Find precluster configuration. If too few jets, make harder cuts. + NLOOP=0 + IF(MSTU(46).LE.3) R2ACC=PARU(44)**2 + IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2 + RINIT=1.25*PARU(43) + IF(NP.LE.MSTU(47)+2) RINIT=0. + 170 RINIT=0.8*RINIT + NPRE=0 + NREM=NP + DO 180 I=N+NP+1,N+2*NP + K(I,4)=0 + 180 CONTINUE + +C...Sum up small momentum region. Jet if enough absolute momentum. + IF(MSTU(46).LE.2) THEN + DO 190 J=1,4 + P(N+1,J)=0. + 190 CONTINUE + DO 210 I=N+NP+1,N+2*NP + IF(P(I,5).GT.2.*RINIT) GOTO 210 + NREM=NREM-1 + K(I,4)=1 + DO 200 J=1,4 + P(N+1,J)=P(N+1,J)+P(I,J) + 200 CONTINUE + 210 CONTINUE + P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) + IF(P(N+1,5).GT.2.*RINIT) NPRE=1 + IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 + IF(NREM.EQ.0) GOTO 170 + ENDIF + +C...Find fastest remaining particle. + 220 NPRE=NPRE+1 + PMAX=0. + DO 230 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230 + IMAX=I + PMAX=P(I,5) + 230 CONTINUE + DO 240 J=1,5 + P(N+NPRE,J)=P(IMAX,J) + 240 CONTINUE + NREM=NREM-1 + K(IMAX,4)=NPRE + +C...Sum up precluster around it according to pT separation. + IF(MSTU(46).LE.2) THEN + DO 260 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0) GOTO 260 + R2=R2T(I,IMAX) + IF(R2.GT.RINIT**2) GOTO 260 + NREM=NREM-1 + K(I,4)=NPRE + DO 250 J=1,4 + P(N+NPRE,J)=P(N+NPRE,J)+P(I,J) + 250 CONTINUE + 260 CONTINUE + P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) + +C...Sum up precluster around it according to mass separation. + ELSE + 270 IMIN=0 + R2MIN=RINIT**2 + DO 280 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0) GOTO 280 + R2=R2M(I,N+NPRE) + IF(R2.GE.R2MIN) GOTO 280 + IMIN=I + R2MIN=R2 + 280 CONTINUE + IF(IMIN.NE.0) THEN + DO 290 J=1,4 + P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J) + 290 CONTINUE + P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) + NREM=NREM-1 + K(IMIN,4)=NPRE + GOTO 270 + ENDIF + ENDIF + +C...Check if more preclusters to be found. Start over if too few. + IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 + IF(NREM.GT.0) GOTO 220 + NJET=NPRE + +C...Reassign all particles to nearest jet. Sum up new jet momenta. + 300 TSAV=0. + PSJT=0. + 310 IF(MSTU(46).LE.1) THEN + DO 330 I=N+1,N+NJET + DO 320 J=1,4 + V(I,J)=0. + 320 CONTINUE + 330 CONTINUE + DO 360 I=N+NP+1,N+2*NP + R2MIN=PSS**2 + DO 340 IJET=N+1,N+NJET + IF(P(IJET,5).LT.RINIT) GOTO 340 + R2=R2T(I,IJET) + IF(R2.GE.R2MIN) GOTO 340 + IMIN=IJET + R2MIN=R2 + 340 CONTINUE + K(I,4)=IMIN-N + DO 350 J=1,4 + V(IMIN,J)=V(IMIN,J)+P(I,J) + 350 CONTINUE + 360 CONTINUE + PSJT=0. + DO 380 I=N+1,N+NJET + DO 370 J=1,4 + P(I,J)=V(I,J) + 370 CONTINUE + P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + PSJT=PSJT+P(I,5) + 380 CONTINUE + ENDIF + +C...Find two closest jets. + R2MIN=2.*MAX(R2ACC,PS(5)**2) + DO 400 ITRY1=N+1,N+NJET-1 + DO 390 ITRY2=ITRY1+1,N+NJET + IF(MSTU(46).LE.2) R2=R2T(ITRY1,ITRY2) + IF(MSTU(46).GE.3) R2=R2M(ITRY1,ITRY2) + IF(R2.GE.R2MIN) GOTO 390 + IMIN1=ITRY1 + IMIN2=ITRY2 + R2MIN=R2 + 390 CONTINUE + 400 CONTINUE + +C...If allowed, join two closest jets and start over. + IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN + IREC=MIN(IMIN1,IMIN2) + IDEL=MAX(IMIN1,IMIN2) + DO 410 J=1,4 + P(IREC,J)=P(IMIN1,J)+P(IMIN2,J) + 410 CONTINUE + P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2) + DO 430 I=IDEL+1,N+NJET + DO 420 J=1,5 + P(I-1,J)=P(I,J) + 420 CONTINUE + 430 CONTINUE + IF(MSTU(46).GE.2) THEN + DO 440 I=N+NP+1,N+2*NP + IORI=N+K(I,4) + IF(IORI.EQ.IDEL) K(I,4)=IREC-N + IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1 + 440 CONTINUE + ENDIF + NJET=NJET-1 + GOTO 300 + +C...Divide up broad jet if empty cluster in list of final ones. + ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN + DO 450 I=N+1,N+NJET + K(I,5)=0 + 450 CONTINUE + DO 460 I=N+NP+1,N+2*NP + K(N+K(I,4),5)=K(N+K(I,4),5)+1 + 460 CONTINUE + IEMP=0 + DO 470 I=N+1,N+NJET + IF(K(I,5).EQ.0) IEMP=I + 470 CONTINUE + IF(IEMP.NE.0) THEN + NLOOP=NLOOP+1 + ISPL=0 + R2MAX=0. + DO 480 I=N+NP+1,N+2*NP + IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480 + IJET=N+K(I,4) + R2=R2T(I,IJET) + IF(R2.LE.R2MAX) GOTO 480 + ISPL=I + R2MAX=R2 + 480 CONTINUE + IF(ISPL.NE.0) THEN + IJET=N+K(ISPL,4) + DO 490 J=1,4 + P(IEMP,J)=P(ISPL,J) + P(IJET,J)=P(IJET,J)-P(ISPL,J) + 490 CONTINUE + P(IEMP,5)=P(ISPL,5) + P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2) + IF(NLOOP.LE.2) GOTO 300 + ENDIF + ENDIF + ENDIF + +C...If generalized thrust has not yet converged, continue iteration. + IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48)) + &THEN + TSAV=PSJT/PSS + GOTO 310 + ENDIF + +C...Reorder jets according to energy. + DO 510 I=N+1,N+NJET + DO 500 J=1,5 + V(I,J)=P(I,J) + 500 CONTINUE + 510 CONTINUE + DO 540 INEW=N+1,N+NJET + PEMAX=0. + DO 520 ITRY=N+1,N+NJET + IF(V(ITRY,4).LE.PEMAX) GOTO 520 + IMAX=ITRY + PEMAX=V(ITRY,4) + 520 CONTINUE + K(INEW,1)=31 + K(INEW,2)=97 + K(INEW,3)=INEW-N + K(INEW,4)=0 + DO 530 J=1,5 + P(INEW,J)=V(IMAX,J) + 530 CONTINUE + V(IMAX,4)=-1. + K(IMAX,5)=INEW + 540 CONTINUE + +C...Clean up particle-jet assignments and jet information. + DO 550 I=N+NP+1,N+2*NP + IORI=K(N+K(I,4),5) + K(I,4)=IORI-N + IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N + K(IORI,4)=K(IORI,4)+1 + 550 CONTINUE + IEMP=0 + PSJT=0. + DO 570 I=N+1,N+NJET + K(I,5)=0 + PSJT=PSJT+P(I,5) + P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.D0)) + DO 560 J=1,5 + V(I,J)=0. + 560 CONTINUE + IF(K(I,4).EQ.0) IEMP=I + 570 CONTINUE + +C...Select storing option. Output variables. Check for failure. + MSTU(61)=N+1 + MSTU(62)=NP + MSTU(63)=NPRE + PARU(61)=PS(5) + PARU(62)=PSJT/PSS + PARU(63)=SQRT(R2MIN) + IF(NJET.LE.1) PARU(63)=0. + IF(IEMP.NE.0) THEN + CALL LUERRM(8,'(LUCLUS:) failed to reconstruct as requested') + NJET=-1 + ENDIF + IF(MSTU(43).LE.1) MSTU(3)=NJET + IF(MSTU(43).GE.2) N=N+NJET + NSAV=NJET + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUCELL + SUBROUTINE LUCELL(NJET) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to provide a simple way of jet finding in an eta-phi-ET +C...coordinate frame, as used for calorimeters at hadron colliders. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Loop over all particles. Find cell that was hit by given particle. + PTLRAT=1./SINH(PARU(51))**2 + NP=0 + NC=N + DO 110 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 + IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 110 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 110 + ENDIF + NP=NP+1 + PT=SQRT(P(I,1)**2+P(I,2)**2) + ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3)) + IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.)))) + PHI=ULANGL(P(I,1),P(I,2)) + IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.)))) + IETPH=MSTU(52)*IETA+IPHI + +C...Add to cell already hit, or book new cell. + DO 100 IC=N+1,NC + IF(IETPH.EQ.K(IC,3)) THEN + K(IC,4)=K(IC,4)+1 + P(IC,5)=P(IC,5)+PT + GOTO 110 + ENDIF + 100 CONTINUE + IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS') + NJET=-2 + RETURN + ENDIF + NC=NC+1 + K(NC,3)=IETPH + K(NC,4)=1 + K(NC,5)=2 + P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51)) + P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52)) + P(NC,5)=PT + 110 CONTINUE + +C...Smear true bin content by calorimeter resolution. + IF(MSTU(53).GE.1) THEN + DO 130 IC=N+1,NC + PEI=P(IC,5) + IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1)) + 120 PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1D-10,RLU(0)))*PEI)* + & COS(PARU(2)*RLU(0)) + IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120 + P(IC,5)=PEF + IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1)) + 130 CONTINUE + ENDIF + +C...Remove cells below threshold. + IF(PARU(58).GT.0.) THEN + NCC=NC + NC=N + DO 140 IC=N+1,NCC + IF(P(IC,5).GT.PARU(58)) THEN + NC=NC+1 + K(NC,3)=K(IC,3) + K(NC,4)=K(IC,4) + K(NC,5)=K(IC,5) + P(NC,1)=P(IC,1) + P(NC,2)=P(IC,2) + P(NC,5)=P(IC,5) + ENDIF + 140 CONTINUE + ENDIF + +C...Find initiator cell: the one with highest pT of not yet used ones. + NJ=NC + 150 ETMAX=0. + DO 160 IC=N+1,NC + IF(K(IC,5).NE.2) GOTO 160 + IF(P(IC,5).LE.ETMAX) GOTO 160 + ICMAX=IC + ETA=P(IC,1) + PHI=P(IC,2) + ETMAX=P(IC,5) + 160 CONTINUE + IF(ETMAX.LT.PARU(52)) GOTO 220 + IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS') + NJET=-2 + RETURN + ENDIF + K(ICMAX,5)=1 + NJ=NJ+1 + K(NJ,4)=0 + K(NJ,5)=1 + P(NJ,1)=ETA + P(NJ,2)=PHI + P(NJ,3)=0. + P(NJ,4)=0. + P(NJ,5)=0. + +C...Sum up unused cells within required distance of initiator. + DO 170 IC=N+1,NC + IF(K(IC,5).EQ.0) GOTO 170 + IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170 + DPHIA=ABS(P(IC,2)-PHI) + IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170 + PHIC=P(IC,2) + IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI) + IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170 + K(IC,5)=-K(IC,5) + K(NJ,4)=K(NJ,4)+K(IC,4) + P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1) + P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC + P(NJ,5)=P(NJ,5)+P(IC,5) + 170 CONTINUE + +C...Reject cluster below minimum ET, else accept. + IF(P(NJ,5).LT.PARU(53)) THEN + NJ=NJ-1 + DO 180 IC=N+1,NC + IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5) + 180 CONTINUE + ELSEIF(MSTU(54).LE.2) THEN + P(NJ,3)=P(NJ,3)/P(NJ,5) + P(NJ,4)=P(NJ,4)/P(NJ,5) + IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2), + & P(NJ,4)) + DO 190 IC=N+1,NC + IF(K(IC,5).LT.0) K(IC,5)=0 + 190 CONTINUE + ELSE + DO 200 J=1,4 + P(NJ,J)=0. + 200 CONTINUE + DO 210 IC=N+1,NC + IF(K(IC,5).GE.0) GOTO 210 + P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2)) + P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2)) + P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1)) + P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1)) + K(IC,5)=0 + 210 CONTINUE + ENDIF + GOTO 150 + +C...Arrange clusters in falling ET sequence. + 220 DO 250 I=1,NJ-NC + ETMAX=0. + DO 230 IJ=NC+1,NJ + IF(K(IJ,5).EQ.0) GOTO 230 + IF(P(IJ,5).LT.ETMAX) GOTO 230 + IJMAX=IJ + ETMAX=P(IJ,5) + 230 CONTINUE + K(IJMAX,5)=0 + K(N+I,1)=31 + K(N+I,2)=98 + K(N+I,3)=I + K(N+I,4)=K(IJMAX,4) + K(N+I,5)=0 + DO 240 J=1,5 + P(N+I,J)=P(IJMAX,J) + V(N+I,J)=0. + 240 CONTINUE + 250 CONTINUE + NJET=NJ-NC + +C...Convert to massless or massive four-vectors. + IF(MSTU(54).EQ.2) THEN + DO 260 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) + P(I,5)=0. + 260 CONTINUE + ELSEIF(MSTU(54).GE.3) THEN + DO 270 I=N+1,N+NJET + P(I,5)=SQRT(MAX(0.D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2)) + 270 CONTINUE + ENDIF + +C...Information about storage. + MSTU(61)=N+1 + MSTU(62)=NP + MSTU(63)=NC-N + IF(MSTU(43).LE.1) MSTU(3)=NJET + IF(MSTU(43).GE.2) N=N+NJET + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUJMAS + SUBROUTINE LUJMAS(PMH,PML) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to determine, approximately, the two jet masses that +C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + DIMENSION SM(3,3),SAX(3),PS(3,5) + +C...Reset. + NP=0 + DO 120 J1=1,3 + DO 100 J2=J1,3 + SM(J1,J2)=0. + 100 CONTINUE + DO 110 J2=1,4 + PS(J1,J2)=0. + 110 CONTINUE + 120 CONTINUE + PSS=0. + +C...Take copy of particles that are to be considered in mass analysis. + DO 170 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 170 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 170 + ENDIF + IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUJMAS:) no more memory left in LUJETS') + PMH=-2. + PML=-2. + RETURN + ENDIF + NP=NP+1 + DO 130 J=1,5 + P(N+NP,J)=P(I,J) + 130 CONTINUE + IF(MSTU(42).EQ.0) P(N+NP,5)=0. + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1) + P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + +C...Fill information in sphericity tensor and total momentum vector. + DO 150 J1=1,3 + DO 140 J2=J1,3 + SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2) + 140 CONTINUE + 150 CONTINUE + PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2) + DO 160 J=1,4 + PS(3,J)=PS(3,J)+P(N+NP,J) + 160 CONTINUE + 170 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL LUERRM(8,'(LUJMAS:) too few particles for analysis') + PMH=-1. + PML=-1. + RETURN + ENDIF + PARU(61)= + &SQRT(MAX(0.D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2)) + +C...Find largest eigenvalue to matrix (third degree equation). + DO 190 J1=1,3 + DO 180 J2=J1,3 + SM(J1,J2)=SM(J1,J2)/PSS + 180 CONTINUE + 190 CONTINUE + 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.D0),-1.D0))/3.) + SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP) + +C...Find largest eigenvector by solving equation system. + DO 210 J1=1,3 + SM(J1,J1)=SM(J1,J1)-SMA + DO 200 J2=J1+1,3 + SM(J2,J1)=SM(J1,J2) + 200 CONTINUE + 210 CONTINUE + SMAX=0. + DO 230 J1=1,3 + DO 220 J2=1,3 + IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220 + JA=J1 + JB=J2 + SMAX=ABS(SM(J1,J2)) + 220 CONTINUE + 230 CONTINUE + SMAX=0. + DO 250 J3=JA+1,JA+2 + J1=J3-3*((J3-1)/3) + RL=SM(J1,JB)/SM(JA,JB) + DO 240 J2=1,3 + SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2) + IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240 + JC=J1 + SMAX=ABS(SM(J1,J2)) + 240 CONTINUE + 250 CONTINUE + JB1=JB+1-3*(JB/3) + JB2=JB+2-3*((JB+1)/3) + SAX(JB1)=-SM(JC,JB2) + SAX(JB2)=SM(JC,JB1) + SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB) + +C...Divide particles into two initial clusters by hemisphere. + DO 270 I=N+1,N+NP + PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3) + IS=1 + IF(PSAX.LT.0.) IS=2 + K(I,3)=IS + DO 260 J=1,4 + PS(IS,J)=PS(IS,J)+P(I,J) + 260 CONTINUE + 270 CONTINUE + PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+ + &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2) + +C...Reassign one particle at a time; find maximum decrease of m^2 sum. + 280 PMD=0. + IM=0 + DO 290 J=1,4 + PS(3,J)=PS(1,J)-PS(2,J) + 290 CONTINUE + DO 300 I=N+1,N+NP + PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3) + IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS) + IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS) + IF(PMDI.LT.PMD) THEN + PMD=PMDI + IM=I + ENDIF + 300 CONTINUE + +C...Loop back if significant reduction in sum of m^2. + IF(PMD.LT.-PARU(48)*PMS) THEN + PMS=PMS+PMD + IS=K(IM,3) + DO 310 J=1,4 + PS(IS,J)=PS(IS,J)-P(IM,J) + PS(3-IS,J)=PS(3-IS,J)+P(IM,J) + 310 CONTINUE + K(IM,3)=3-IS + GOTO 280 + ENDIF + +C...Final masses and output. + MSTU(61)=N+1 + MSTU(62)=NP + PS(1,5)= + &SQRT(MAX(0.D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)) + PS(2,5)= + &SQRT(MAX(0.D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)) + PMH=MAX(PS(1,5),PS(2,5)) + PML=MIN(PS(1,5),PS(2,5)) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUFOWO + SUBROUTINE LUFOWO(H10,H20,H30,H40) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to calculate the first few Fox-Wolfram moments. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Copy momenta for particles and calculate H0. + NP=0 + H0=0. + HD=0. + DO 110 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 110 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 110 + ENDIF + IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN + CALL LUERRM(11,'(LUFOWO:) no more memory left in LUJETS') + H10=-1. + H20=-1. + H30=-1. + H40=-1. + RETURN + ENDIF + NP=NP+1 + DO 100 J=1,3 + P(N+NP,J)=P(I,J) + 100 CONTINUE + P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + H0=H0+P(N+NP,4) + HD=HD+P(N+NP,4)**2 + 110 CONTINUE + H0=H0**2 + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL LUERRM(8,'(LUFOWO:) too few particles for analysis') + H10=-1. + H20=-1. + H30=-1. + H40=-1. + RETURN + ENDIF + +C...Calculate H1 - H4. + H10=0. + H20=0. + H30=0. + H40=0. + DO 130 I1=N+1,N+NP + DO 120 I2=I1+1,N+NP + CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ + &(P(I1,4)*P(I2,4)) + H10=H10+P(I1,4)*P(I2,4)*CTHE + H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5) + H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE) + H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375) + 120 CONTINUE + 130 CONTINUE + +C...Calculate H1/H0 - H4/H0. Output. + MSTU(61)=N+1 + MSTU(62)=NP + H10=(HD+2.*H10)/H0 + H20=(HD+2.*H20)/H0 + H30=(HD+2.*H30)/H0 + H40=(HD+2.*H40)/H0 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUTABU + SUBROUTINE LUTABU(MTABU) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to evaluate various properties of an event, with +C...statistics accumulated during the course of the run and +C...printed at the end. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/ + DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4), + &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4), + &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25), + &KFDM(8),KFDC(200,0:8),NPDC(200) + SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS, + &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA, + &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC + CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12 + DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/, + &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./, + &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./, + &NEVDC/0/,NKFDC/0/,NREDC/0/ + +C...Reset statistics on initial parton state. + IF(MTABU.EQ.10) THEN + NEVIS=0 + NKFIS=0 + +C...Identify and order flavour content of initial state. + ELSEIF(MTABU.EQ.11) THEN + NEVIS=NEVIS+1 + KFM1=2*IABS(MSTU(161)) + IF(MSTU(161).GT.0) KFM1=KFM1-1 + KFM2=2*IABS(MSTU(162)) + IF(MSTU(162).GT.0) KFM2=KFM2-1 + KFMN=MIN(KFM1,KFM2) + KFMX=MAX(KFM1,KFM2) + DO 100 I=1,NKFIS + IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN + IKFIS=-I + GOTO 110 + ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND. + & KFMX.LT.KFIS(I,2))) THEN + IKFIS=I + GOTO 110 + ENDIF + 100 CONTINUE + IKFIS=NKFIS+1 + 110 IF(IKFIS.LT.0) THEN + IKFIS=-IKFIS + ELSE + IF(NKFIS.GE.100) RETURN + DO 130 I=NKFIS,IKFIS,-1 + KFIS(I+1,1)=KFIS(I,1) + KFIS(I+1,2)=KFIS(I,2) + DO 120 J=0,10 + NPIS(I+1,J)=NPIS(I,J) + 120 CONTINUE + 130 CONTINUE + NKFIS=NKFIS+1 + KFIS(IKFIS,1)=KFMN + KFIS(IKFIS,2)=KFMX + DO 140 J=0,10 + NPIS(IKFIS,J)=0 + 140 CONTINUE + ENDIF + NPIS(IKFIS,0)=NPIS(IKFIS,0)+1 + +C...Count number of partons in initial state. + NP=0 + DO 160 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN + ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN + ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0) + & THEN + ELSE + IM=I + 150 IM=K(IM,3) + IF(IM.LE.0.OR.IM.GT.N) THEN + NP=NP+1 + ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN + NP=NP+1 + ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN + ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0) + & THEN + ELSE + GOTO 150 + ENDIF + ENDIF + 160 CONTINUE + NPCO=MAX(NP,1) + IF(NP.GE.6) NPCO=6 + IF(NP.GE.8) NPCO=7 + IF(NP.GE.11) NPCO=8 + IF(NP.GE.16) NPCO=9 + IF(NP.GE.26) NPCO=10 + NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1 + MSTU(62)=NP + +C...Write statistics on initial parton state. + ELSEIF(MTABU.EQ.12) THEN + FAC=1./MAX(1,NEVIS) + WRITE(MSTU(11),5000) NEVIS + DO 170 I=1,NKFIS + KFMN=KFIS(I,1) + IF(KFMN.EQ.0) KFMN=KFIS(I,2) + KFM1=(KFMN+1)/2 + IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 + CALL LUNAME(KFM1,CHAU) + CHIS(1)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?' + KFMX=KFIS(I,2) + IF(KFIS(I,1).EQ.0) KFMX=0 + KFM2=(KFMX+1)/2 + IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 + CALL LUNAME(KFM2,CHAU) + CHIS(2)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?' + WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0), + & (NPIS(I,J)/ DBLE(NPIS(I,0)),J=1,10) + 170 CONTINUE + +C...Copy statistics on initial parton state into /LUJETS/. + ELSEIF(MTABU.EQ.13) THEN + FAC=1./MAX(1,NEVIS) + DO 190 I=1,NKFIS + KFMN=KFIS(I,1) + IF(KFMN.EQ.0) KFMN=KFIS(I,2) + KFM1=(KFMN+1)/2 + IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 + KFMX=KFIS(I,2) + IF(KFIS(I,1).EQ.0) KFMX=0 + KFM2=(KFMX+1)/2 + IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 + K(I,1)=32 + K(I,2)=99 + K(I,3)=KFM1 + K(I,4)=KFM2 + K(I,5)=NPIS(I,0) + DO 180 J=1,5 + P(I,J)=FAC*NPIS(I,J) + V(I,J)=FAC*NPIS(I,J+5) + 180 CONTINUE + 190 CONTINUE + N=NKFIS + DO 200 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0. + V(N+1,J)=0. + 200 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVIS + MSTU(3)=1 + +C...Reset statistics on number of particles/partons. + ELSEIF(MTABU.EQ.20) THEN + NEVFS=0 + NPRFS=0 + NFIFS=0 + NCHFS=0 + NKFFS=0 + +C...Identify whether particle/parton is primary or not. + ELSEIF(MTABU.EQ.21) THEN + NEVFS=NEVFS+1 + MSTU(62)=0 + DO 260 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260 + MSTU(62)=MSTU(62)+1 + KC=LUCOMP(K(I,2)) + MPRI=0 + IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN + MPRI=1 + ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN + MPRI=1 + ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN + MPRI=1 + ELSEIF(KC.EQ.0) THEN + ELSEIF(K(K(I,3),1).EQ.13) THEN + IM=K(K(I,3),3) + IF(IM.LE.0.OR.IM.GT.N) THEN + MPRI=1 + ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN + MPRI=1 + ENDIF + ELSEIF(KCHG(KC,2).EQ.0) THEN + KCM=LUCOMP(K(K(I,3),2)) + IF(KCM.NE.0) THEN + IF(KCHG(KCM,2).NE.0) MPRI=1 + ENDIF + ENDIF + IF(KC.NE.0.AND.MPRI.EQ.1) THEN + IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1 + ENDIF + IF(K(I,1).LE.10) THEN + NFIFS=NFIFS+1 + IF(LUCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1 + ENDIF + +C...Fill statistics on number of particles/partons in event. + KFA=IABS(K(I,2)) + KFS=3-ISIGN(1,K(I,2))-MPRI + DO 210 IP=1,NKFFS + IF(KFA.EQ.KFFS(IP)) THEN + IKFFS=-IP + GOTO 220 + ELSEIF(KFA.LT.KFFS(IP)) THEN + IKFFS=IP + GOTO 220 + ENDIF + 210 CONTINUE + IKFFS=NKFFS+1 + 220 IF(IKFFS.LT.0) THEN + IKFFS=-IKFFS + ELSE + IF(NKFFS.GE.400) RETURN + DO 240 IP=NKFFS,IKFFS,-1 + KFFS(IP+1)=KFFS(IP) + DO 230 J=1,4 + NPFS(IP+1,J)=NPFS(IP,J) + 230 CONTINUE + 240 CONTINUE + NKFFS=NKFFS+1 + KFFS(IKFFS)=KFA + DO 250 J=1,4 + NPFS(IKFFS,J)=0 + 250 CONTINUE + ENDIF + NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1 + 260 CONTINUE + +C...Write statistics on particle/parton composition of events. + ELSEIF(MTABU.EQ.22) THEN + FAC=1./MAX(1,NEVFS) + WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS + DO 270 I=1,NKFFS + CALL LUNAME(KFFS(I),CHAU) + KC=LUCOMP(KFFS(I)) + MDCYF=0 + IF(KC.NE.0) MDCYF=MDCY(KC,1) + WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4), + & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)) + 270 CONTINUE + +C...Copy particle/parton composition information into /LUJETS/. + ELSEIF(MTABU.EQ.23) THEN + FAC=1./MAX(1,NEVFS) + DO 290 I=1,NKFFS + K(I,1)=32 + K(I,2)=99 + K(I,3)=KFFS(I) + K(I,4)=0 + K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4) + DO 280 J=1,4 + P(I,J)=FAC*NPFS(I,J) + V(I,J)=0. + 280 CONTINUE + P(I,5)=FAC*K(I,5) + V(I,5)=0. + 290 CONTINUE + N=NKFFS + DO 300 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0. + V(N+1,J)=0. + 300 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVFS + P(N+1,1)=FAC*NPRFS + P(N+1,2)=FAC*NFIFS + P(N+1,3)=FAC*NCHFS + MSTU(3)=1 + +C...Reset factorial moments statistics. + ELSEIF(MTABU.EQ.30) THEN + NEVFM=0 + NMUFM=0 + DO 330 IM=1,3 + DO 320 IB=1,10 + DO 310 IP=1,4 + FM1FM(IM,IB,IP)=0. + FM2FM(IM,IB,IP)=0. + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + +C...Find particles to include, with (pion,pseudo)rapidity and azimuth. + ELSEIF(MTABU.EQ.31) THEN + NEVFM=NEVFM+1 + NLOW=N+MSTU(3) + NUPP=NLOW + DO 410 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 410 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 410 + ENDIF + PMR=0. + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211) + IF(MSTU(42).GE.2) PMR=P(I,5) + PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) + YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), + & 1D20)),P(I,3)) + IF(ABS(YETA).GT.PARU(57)) GOTO 410 + PHI=ULANGL(P(I,1),P(I,2)) + IYETA=512.*(YETA+PARU(57))/(2.*PARU(57)) + IYETA=MAX(0,MIN(511,IYETA)) + IPHI=512.*(PHI+PARU(1))/PARU(2) + IPHI=MAX(0,MIN(511,IPHI)) + IYEP=0 + DO 340 IB=0,9 + IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2)) + 340 CONTINUE + +C...Order particles in (pseudo)rapidity and/or azimuth. + IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN + CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS') + RETURN + ENDIF + NUPP=NUPP+1 + IF(NUPP.EQ.NLOW+1) THEN + K(NUPP,1)=IYETA + K(NUPP,2)=IPHI + K(NUPP,3)=IYEP + ELSE + DO 350 I1=NUPP-1,NLOW+1,-1 + IF(IYETA.GE.K(I1,1)) GOTO 360 + K(I1+1,1)=K(I1,1) + 350 CONTINUE + 360 K(I1+1,1)=IYETA + DO 370 I1=NUPP-1,NLOW+1,-1 + IF(IPHI.GE.K(I1,2)) GOTO 380 + K(I1+1,2)=K(I1,2) + 370 CONTINUE + 380 K(I1+1,2)=IPHI + DO 390 I1=NUPP-1,NLOW+1,-1 + IF(IYEP.GE.K(I1,3)) GOTO 400 + K(I1+1,3)=K(I1,3) + 390 CONTINUE + 400 K(I1+1,3)=IYEP + ENDIF + 410 CONTINUE + K(NUPP+1,1)=2**10 + K(NUPP+1,2)=2**10 + K(NUPP+1,3)=4**10 + +C...Calculate sum of factorial moments in event. + DO 480 IM=1,3 + DO 430 IB=1,10 + DO 420 IP=1,4 + FEVFM(IB,IP)=0. + 420 CONTINUE + 430 CONTINUE + DO 450 IB=1,10 + IF(IM.LE.2) IBIN=2**(10-IB) + IF(IM.EQ.3) IBIN=4**(10-IB) + IAGR=K(NLOW+1,IM)/IBIN + NAGR=1 + DO 440 I=NLOW+2,NUPP+1 + ICUT=K(I,IM)/IBIN + IF(ICUT.EQ.IAGR) THEN + NAGR=NAGR+1 + ELSE + IF(NAGR.EQ.1) THEN + ELSEIF(NAGR.EQ.2) THEN + FEVFM(IB,1)=FEVFM(IB,1)+2. + ELSEIF(NAGR.EQ.3) THEN + FEVFM(IB,1)=FEVFM(IB,1)+6. + FEVFM(IB,2)=FEVFM(IB,2)+6. + ELSEIF(NAGR.EQ.4) THEN + FEVFM(IB,1)=FEVFM(IB,1)+12. + FEVFM(IB,2)=FEVFM(IB,2)+24. + FEVFM(IB,3)=FEVFM(IB,3)+24. + ELSE + FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.) + FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.) + FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.) + FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)* + & (NAGR-4.) + ENDIF + IAGR=ICUT + NAGR=1 + ENDIF + 440 CONTINUE + 450 CONTINUE + +C...Add results to total statistics. + DO 470 IB=10,1,-1 + DO 460 IP=1,4 + IF(FEVFM(1,IP).LT.0.5) THEN + FEVFM(IB,IP)=0. + ELSEIF(IM.LE.2) THEN + FEVFM(IB,IP)=2.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) + ELSE + FEVFM(IB,IP)=4.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) + ENDIF + FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP) + FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2 + 460 CONTINUE + 470 CONTINUE + 480 CONTINUE + NMUFM=NMUFM+(NUPP-NLOW) + MSTU(62)=NUPP-NLOW + +C...Write accumulated statistics on factorial moments. + ELSEIF(MTABU.EQ.32) THEN + FAC=1./MAX(1,NEVFM) + IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta' + IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi' + IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y ' + DO 510 IM=1,3 + WRITE(MSTU(11),5500) + DO 500 IB=1,10 + BYETA=2.*PARU(57) + IF(IM.NE.2) BYETA=BYETA/2**(IB-1) + BPHI=PARU(2) + IF(IM.NE.1) BPHI=BPHI/2**(IB-1) + IF(IM.LE.2) BNAVE=FAC*NMUFM/ DBLE(2**(IB-1)) + IF(IM.EQ.3) BNAVE=FAC*NMUFM/ DBLE(4**(IB-1)) + DO 490 IP=1,4 + FMOMA(IP)=FAC*FM1FM(IM,IB,IP) + FMOMS(IP)=SQRT(MAX(0.D0,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2))) + 490 CONTINUE + WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP), + & IP=1,4) + 500 CONTINUE + 510 CONTINUE + +C...Copy statistics on factorial moments into /LUJETS/. + ELSEIF(MTABU.EQ.33) THEN + FAC=1./MAX(1,NEVFM) + DO 540 IM=1,3 + DO 530 IB=1,10 + I=10*(IM-1)+IB + K(I,1)=32 + K(I,2)=99 + K(I,3)=1 + IF(IM.NE.2) K(I,3)=2**(IB-1) + K(I,4)=1 + IF(IM.NE.1) K(I,4)=2**(IB-1) + K(I,5)=0 + P(I,1)=2.*PARU(57)/K(I,3) + V(I,1)=PARU(2)/K(I,4) + DO 520 IP=1,4 + P(I,IP+1)=FAC*FM1FM(IM,IB,IP) + V(I,IP+1)=SQRT(MAX(0.D0,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2))) + 520 CONTINUE + 530 CONTINUE + 540 CONTINUE + N=30 + DO 550 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0. + V(N+1,J)=0. + 550 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVFM + MSTU(3)=1 + +C...Reset statistics on Energy-Energy Correlation. + ELSEIF(MTABU.EQ.40) THEN + NEVEE=0 + DO 560 J=1,25 + FE1EC(J)=0. + FE2EC(J)=0. + FE1EC(51-J)=0. + FE2EC(51-J)=0. + FE1EA(J)=0. + FE2EA(J)=0. + 560 CONTINUE + +C...Find particles to include, with proper assumed mass. + ELSEIF(MTABU.EQ.41) THEN + NEVEE=NEVEE+1 + NLOW=N+MSTU(3) + NUPP=NLOW + ECM=0. + DO 570 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570 + IF(MSTU(41).GE.2) THEN + KC=LUCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18) GOTO 570 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) + & GOTO 570 + ENDIF + PMR=0. + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211) + IF(MSTU(42).GE.2) PMR=P(I,5) + IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN + CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS') + RETURN + ENDIF + NUPP=NUPP+1 + P(NUPP,1)=P(I,1) + P(NUPP,2)=P(I,2) + P(NUPP,3)=P(I,3) + P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)) + ECM=ECM+P(NUPP,4) + 570 CONTINUE + IF(NUPP.EQ.NLOW) RETURN + +C...Analyze Energy-Energy Correlation in event. + FAC=(2./ECM**2)*50./PARU(1) + DO 580 J=1,50 + FEVEE(J)=0. + 580 CONTINUE + DO 600 I1=NLOW+2,NUPP + DO 590 I2=NLOW+1,I1-1 + CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ + & (P(I1,5)*P(I2,5)) + THE=ACOS(MAX(-1.D0,MIN(1.D0,CTHE))) + ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1)))) + FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4) + 590 CONTINUE + 600 CONTINUE + DO 610 J=1,25 + FE1EC(J)=FE1EC(J)+FEVEE(J) + FE2EC(J)=FE2EC(J)+FEVEE(J)**2 + FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J) + FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2 + FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J)) + FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2 + 610 CONTINUE + MSTU(62)=NUPP-NLOW + +C...Write statistics on Energy-Energy Correlation. + ELSEIF(MTABU.EQ.42) THEN + FAC=1./MAX(1,NEVEE) + WRITE(MSTU(11),5700) NEVEE + DO 620 J=1,25 + FEEC1=FAC*FE1EC(J) + FEES1=SQRT(MAX(0.D0,FAC*(FAC*FE2EC(J)-FEEC1**2))) + FEEC2=FAC*FE1EC(51-J) + FEES2=SQRT(MAX(0.D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2))) + FEECA=FAC*FE1EA(J) + FEESA=SQRT(MAX(0.D0,FAC*(FAC*FE2EA(J)-FEECA**2))) + WRITE(MSTU(11),5800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2, + & FEECA,FEESA + 620 CONTINUE + +C...Copy statistics on Energy-Energy Correlation into /LUJETS/. + ELSEIF(MTABU.EQ.43) THEN + FAC=1./MAX(1,NEVEE) + DO 630 I=1,25 + K(I,1)=32 + K(I,2)=99 + K(I,3)=0 + K(I,4)=0 + K(I,5)=0 + P(I,1)=FAC*FE1EC(I) + V(I,1)=SQRT(MAX(0.D0,FAC*(FAC*FE2EC(I)-P(I,1)**2))) + P(I,2)=FAC*FE1EC(51-I) + V(I,2)=SQRT(MAX(0.D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2))) + P(I,3)=FAC*FE1EA(I) + V(I,3)=SQRT(MAX(0.D0,FAC*(FAC*FE2EA(I)-P(I,3)**2))) + P(I,4)=PARU(1)*(I-1)/50. + P(I,5)=PARU(1)*I/50. + V(I,4)=3.6*(I-1) + V(I,5)=3.6*I + 630 CONTINUE + N=25 + DO 640 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0. + V(N+1,J)=0. + 640 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVEE + MSTU(3)=1 + +C...Reset statistics on decay channels. + ELSEIF(MTABU.EQ.50) THEN + NEVDC=0 + NKFDC=0 + NREDC=0 + +C...Identify and order flavour content of final state. + ELSEIF(MTABU.EQ.51) THEN + NEVDC=NEVDC+1 + NDS=0 + DO 670 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670 + NDS=NDS+1 + IF(NDS.GT.8) THEN + NREDC=NREDC+1 + RETURN + ENDIF + KFM=2*IABS(K(I,2)) + IF(K(I,2).LT.0) KFM=KFM-1 + DO 650 IDS=NDS-1,1,-1 + IIN=IDS+1 + IF(KFM.LT.KFDM(IDS)) GOTO 660 + KFDM(IDS+1)=KFDM(IDS) + 650 CONTINUE + IIN=1 + 660 KFDM(IIN)=KFM + 670 CONTINUE + +C...Find whether old or new final state. + DO 690 IDC=1,NKFDC + IF(NDS.LT.KFDC(IDC,0)) THEN + IKFDC=IDC + GOTO 700 + ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN + DO 680 I=1,NDS + IF(KFDM(I).LT.KFDC(IDC,I)) THEN + IKFDC=IDC + GOTO 700 + ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN + GOTO 690 + ENDIF + 680 CONTINUE + IKFDC=-IDC + GOTO 700 + ENDIF + 690 CONTINUE + IKFDC=NKFDC+1 + 700 IF(IKFDC.LT.0) THEN + IKFDC=-IKFDC + ELSEIF(NKFDC.GE.200) THEN + NREDC=NREDC+1 + RETURN + ELSE + DO 720 IDC=NKFDC,IKFDC,-1 + NPDC(IDC+1)=NPDC(IDC) + DO 710 I=0,8 + KFDC(IDC+1,I)=KFDC(IDC,I) + 710 CONTINUE + 720 CONTINUE + NKFDC=NKFDC+1 + KFDC(IKFDC,0)=NDS + DO 730 I=1,NDS + KFDC(IKFDC,I)=KFDM(I) + 730 CONTINUE + NPDC(IKFDC)=0 + ENDIF + NPDC(IKFDC)=NPDC(IKFDC)+1 + +C...Write statistics on decay channels. + ELSEIF(MTABU.EQ.52) THEN + FAC=1./MAX(1,NEVDC) + WRITE(MSTU(11),5900) NEVDC + DO 750 IDC=1,NKFDC + DO 740 I=1,KFDC(IDC,0) + KFM=KFDC(IDC,I) + KF=(KFM+1)/2 + IF(2*KF.NE.KFM) KF=-KF + CALL LUNAME(KF,CHAU) + CHDC(I)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?' + 740 CONTINUE + WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0)) + 750 CONTINUE + IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC + +C...Copy statistics on decay channels into /LUJETS/. + ELSEIF(MTABU.EQ.53) THEN + FAC=1./MAX(1,NEVDC) + DO 780 IDC=1,NKFDC + K(IDC,1)=32 + K(IDC,2)=99 + K(IDC,3)=0 + K(IDC,4)=0 + K(IDC,5)=KFDC(IDC,0) + DO 760 J=1,5 + P(IDC,J)=0. + V(IDC,J)=0. + 760 CONTINUE + DO 770 I=1,KFDC(IDC,0) + KFM=KFDC(IDC,I) + KF=(KFM+1)/2 + IF(2*KF.NE.KFM) KF=-KF + IF(I.LE.5) P(IDC,I)=KF + IF(I.GE.6) V(IDC,I-5)=KF + 770 CONTINUE + V(IDC,5)=FAC*NPDC(IDC) + 780 CONTINUE + N=NKFDC + DO 790 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0. + V(N+1,J)=0. + 790 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVDC + V(N+1,5)=FAC*NREDC + MSTU(3)=1 + ENDIF + +C...Format statements for output on unit MSTU(11) (default 6). + 5000 FORMAT(///20X,'Event statistics - initial state'/ + &20X,'based on an analysis of ',I6,' events'// + &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ', + &'according to fragmenting system multiplicity'/ + &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5', + &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/) + 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4) + 5200 FORMAT(///20X,'Event statistics - final state'/ + &20X,'based on an analysis of ',I7,' events'// + &5X,'Mean primary multiplicity =',F10.4/ + &5X,'Mean final multiplicity =',F10.4/ + &5X,'Mean charged multiplicity =',F10.4// + &5X,'Number of particles produced per event (directly and via ', + &'decays/branchings)'/ + &5X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles', + &8X,'Total'/35X,'prim seco prim seco'/) + 5300 FORMAT(1X,I6,4X,A16,I2,5(1X,F11.6)) + 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/ + &20X,'based on an analysis of ',I6,' events'// + &3X,'delta-',A3,' delta-phi /bin',10X,'',18X,'', + &18X,'',18X,''/35X,4(' value error ')) + 5500 FORMAT(10X) + 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4)) + 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/ + &20X,'based on an analysis of ',I6,' events'// + &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X, + &'EECA(theta)'/2X,'in degrees ',3(' value error')/) + 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4)) + 5900 FORMAT(///20X,'Decay channel analysis - final state'/ + &20X,'based on an analysis of ',I6,' events'// + &2X,'Probability',10X,'Complete final state'/) + 6000 FORMAT(2X,F9.5,5X,8(A12,1X)) + 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ', + &'or table overflow)') + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUEEVT + SUBROUTINE LUEEVT(KFL,ECM) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to handle the generation of an e+e- annihilation jet event. +C IMPLICIT DOUBLE PRECISION(D) + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Check input parameters. + IF(MSTU(12).GE.1) CALL LULIST(0) + IF(KFL.LT.0.OR.KFL.GT.8) THEN + CALL LUERRM(16,'(LUEEVT:) called with unknown flavour code') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL)) + IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1) + IF(ECM.LT.ECMMIN) THEN + CALL LUERRM(16,'(LUEEVT:) called with too small CM energy') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Check consistency of MSTJ options set. + IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN + CALL LUERRM(6, + & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1') + MSTJ(110)=1 + ENDIF + IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN + CALL LUERRM(6, + & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0') + MSTJ(111)=0 + ENDIF + +C...Initialize alpha_strong and total cross-section. + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + &MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE. + &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LUXTOT(KFL,ECM, + &XTOT) + IF(MSTJ(116).GE.3) MSTJ(116)=1 + PARJ(171)=0. + +C...Add initial e+e- to event record (documentation only). + NTRY=0 + 100 NTRY=NTRY+1 + IF(NTRY.GT.100) THEN + CALL LUERRM(14,'(LUEEVT:) caught in an infinite loop') + RETURN + ENDIF + MSTU(24)=0 + NC=0 + IF(MSTJ(115).GE.2) THEN + NC=NC+2 + CALL LU1ENT(NC-1,11,0.5*ECM,0.D0,0.D0) + K(NC-1,1)=21 + CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.D0) + K(NC,1)=21 + ENDIF + +C...Radiative photon (in initial state). + MK=0 + ECMC=ECM + IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LURADK(ECM,MK,PAK, + &THEK,PHIK,ALPK) + IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK)) + IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN + NC=NC+1 + CALL LU1ENT(NC,22,PAK,THEK,PHIK) + K(NC,3)=MIN(MSTJ(115)/2,1) + ENDIF + +C...Virtual exchange boson (gamma or Z0). + IF(MSTJ(115).GE.3) THEN + NC=NC+1 + KF=22 + IF(MSTJ(102).EQ.2) KF=23 + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC,5)=ECMC + CALL LU1ENT(NC,KF,ECMC,0.D0,0.D0) + K(NC,1)=21 + K(NC,3)=1 + MSTU(10)=MSTU10 + ENDIF + +C...Choice of flavour and jet configuration. + CALL LUXKFL(KFL,ECM,ECMC,KFLC) + IF(KFLC.EQ.0) GOTO 100 + CALL LUXJET(ECMC,NJET,CUT) + KFLN=21 + IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4, + &X12,X14) + IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,KFLC,ECMC,X1,X3) + IF(NJET.EQ.2) MSTJ(120)=1 + +C...Fill jet configuration and origin. + IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LU2ENT(NC+1,KFLC,-KFLC,ECMC) + IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LU2ENT(-(NC+1),KFLC,-KFLC, + &ECMC) + IF(NJET.EQ.3) CALL LU3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3) + IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LU4ENT(NC+1,KFLC,KFLN,KFLN, + &-KFLC,ECMC,X1,X2,X4,X12,X14) + IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LU4ENT(NC+1,KFLC,-KFLN,KFLN, + &-KFLC,ECMC,X1,X2,X4,X12,X14) + IF(MSTU(24).NE.0) GOTO 100 + DO 110 IP=NC+1,N + K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1) + 110 CONTINUE + +C...Angular orientation according to matrix element. + IF(MSTJ(106).EQ.1) THEN + CALL LUXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI) + CALL LUDBRB(NC+1,N,0.D0,CHI,0D0,0D0,0D0) + CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0) + ENDIF + +C...Rotation and boost from radiative photon. + IF(MK.EQ.1) THEN + DBEK=-PAK/(ECM-PAK) + NMIN=NC+1-MSTJ(115)/3 + CALL LUDBRB(NMIN,N,0.D0,-PHIK,0D0,0D0,0D0) + CALL LUDBRB(NMIN,N,ALPK,0.D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK)) + CALL LUDBRB(NMIN,N,0.D0,PHIK,0D0,0D0,0D0) + ENDIF + +C...Generate parton shower. Rearrange along strings and check. + IF(MSTJ(101).EQ.5) THEN + CALL LUSHOW(N-1,N,ECMC) + MSTJ14=MSTJ(14) + IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 + IF(MSTJ(105).GE.0) MSTU(28)=0 + CALL LUPREP(0) + MSTJ(14)=MSTJ14 + IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 + ENDIF + +C...Fragmentation/decay generation. Information for LUTABU. + IF(MSTJ(105).EQ.1) CALL LUEXEC + MSTU(161)=KFLC + MSTU(162)=-KFLC + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUXTOT + SUBROUTINE LUXTOT(KFL,ECM,XTOT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to calculate total cross-section, including initial +C...state radiation effects. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT1/,/LUDAT2/ + +C...Status, (optimized) Q^2 scale, alpha_strong. + PARJ(151)=ECM + MSTJ(119)=10*MSTJ(102)+KFL + IF(MSTJ(111).EQ.0) THEN + Q2R=ECM**2 + ELSEIF(MSTU(111).EQ.0) THEN + PARJ(168)=MIN(1.D0,MAX(PARJ(128),EXP(-12.*PARU(1)/ + & ((33.-2.*MSTU(112))*PARU(111))))) + Q2R=PARJ(168)*ECM**2 + ELSE + PARJ(168)=MIN(1.D0,MAX(PARJ(128),PARU(112)/ECM, + & (2.*PARU(112)/ECM)**2)) + Q2R=PARJ(168)*ECM**2 + ENDIF + ALSPI=ULALPS(Q2R)/PARU(1) + +C...QCD corrections factor in R. + IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN + RQCD=1. + ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN + RQCD=1.+ALSPI + ELSEIF(MSTJ(109).EQ.0) THEN + RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2 + IF(MSTJ(111).EQ.1) RQCD=MAX(1.D0,RQCD+(33.-2.*MSTU(112))/12.* + & LOG(PARJ(168))*ALSPI**2) + ELSEIF(IABS(MSTJ(101)).EQ.1) THEN + RQCD=1.+(3./4.)*ALSPI + ELSE + RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2 + ENDIF + +C...Calculate Z0 width if default value not acceptable. + IF(MSTJ(102).GE.3) THEN + RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/ + & 3.)**2+(4.*PARU(102)/3.-1.)**2) + DO 100 KFLC=5,6 + VQ=1. + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.D0,1.-(2.*ULMASS(KFLC)/ + & ECM)**2)) + IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1. + IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3. + RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3) + 100 CONTINUE + PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102))) + ENDIF + +C...Calculate propagator and related constants for QFD case. + POLL=1.-PARJ(131)*PARJ(132) + IF(MSTJ(102).GE.2) THEN + SFF=1./(16.*PARU(102)*(1.-PARU(102))) + SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1.-(PARJ(123)/ECM)**2) + VE=4.*PARU(102)-1. + SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131)) + SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131))) + HF1I=SFI*SF1I + HF1W=SFW*SF1W + ENDIF + +C...Loop over different flavours: charge, velocity. + RTOT=0. + RQQ=0. + RQV=0. + RVA=0. + DO 110 KFLC=1,MAX(MSTJ(104),KFL) + IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110 + MSTJ(93)=1 + PMQ=ULMASS(KFLC) + IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110 + QF=KCHG(KFLC,1)/3. + VQ=1. + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2) + +C...Calculate R and sum of charges for QED or QFD case. + RQQ=RQQ+3.*QF**2*POLL + IF(MSTJ(102).LE.1) THEN + RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL + ELSE + VF=SIGN(1.D0,QF)-4.*QF*PARU(102) + RQV=RQV-6.*QF*VF*SF1I + RVA=RVA+3.*(VF**2+1.)*SF1W + RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+ + & VF**2*HF1W)+VQ**3*HF1W) + ENDIF + 110 CONTINUE + RSUM=RQQ + IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA + +C...Calculate cross-section, including QCD corrections. + PARJ(141)=RQQ + PARJ(142)=RTOT + PARJ(143)=RTOT*RQCD + PARJ(144)=PARJ(143) + PARJ(145)=PARJ(141)*86.8/ECM**2 + PARJ(146)=PARJ(142)*86.8/ECM**2 + PARJ(147)=PARJ(143)*86.8/ECM**2 + PARJ(148)=PARJ(147) + PARJ(157)=RSUM*RQCD + PARJ(158)=0. + PARJ(159)=0. + XTOT=PARJ(147) + IF(MSTJ(107).LE.0) RETURN + +C...Virtual cross-section. + XKL=PARJ(135) + XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2) + ALE=2.*LOG(ECM/ULMASS(11))-1. + SIGV=ALE/3.+2.*LOG(ECM**2/(ULMASS(13)*ULMASS(15)))/3.-4./3.+ + &1.526*LOG(ECM**2/0.932) + +C...Soft and hard radiative cross-section in QED case. + IF(MSTJ(102).LE.1) THEN + SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV + SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL) + SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL)) + +C...Soft and hard radiative cross-section in QFD case. + ELSE + SZM=1.-(PARJ(123)/ECM)**2 + SZW=PARJ(123)*PARJ(124)/ECM**2 + PARJ(161)=-RQQ/RSUM + PARJ(162)=-(RQQ+RQV+RVA)/RSUM + PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM + PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM- + & SZM**2))/(SZW*RSUM) + SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+ + & (SZW*SFW*RQV/RSUM)*PARU(1)*20./9. + SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+ + & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+ + & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW))) + SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+ + & PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/ + & ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)- + & ATAN((XKL-SZM)/SZW))) + ENDIF + +C...Total cross-section and fraction of hard photon events. + PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH) + PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD + PARJ(144)=PARJ(157) + PARJ(148)=PARJ(144)*86.8/ECM**2 + XTOT=PARJ(148) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LURADK + SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to generate initial state photon radiation. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUDAT1/ + +C...Function: cumulative hard photon spectrum in QFD case. + FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+ + &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW) + +C...Determine whether radiative photon or not. + MK=0 + PAK=0. + IF(PARJ(160).LT.RLU(0)) RETURN + MK=1 + +C...Photon energy range. Find photon momentum in QED case. + XKL=PARJ(135) + XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2) + IF(MSTJ(102).LE.1) THEN + 100 XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLU(0)) + IF(1.+(1.-XK)**2.LT.2.*RLU(0)) GOTO 100 + +C...Ditto in QFD case, by numerical inversion of integrated spectrum. + ELSE + SZM=1.-(PARJ(123)/ECM)**2 + SZW=PARJ(123)*PARJ(124)/ECM**2 + FXKL=FXK(XKL) + FXKU=FXK(XKU) + FXKD=1D-4*(FXKU-FXKL) + FXKR=FXKL+RLU(0)*(FXKU-FXKL) + NXK=0 + 110 NXK=NXK+1 + XK=0.5*(XKL+XKU) + FXKV=FXK(XK) + IF(FXKV.GT.FXKR) THEN + XKU=XK + FXKU=FXKV + ELSE + XKL=XK + FXKL=FXKV + ENDIF + IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110 + XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL) + ENDIF + PAK=0.5*ECM*XK + +C...Photon polar and azimuthal angle. + PME=2.*(ULMASS(11)/ECM)**2 + 120 CTHM=PME*(2./PME)**RLU(0) + IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME, + &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLU(0)) GOTO 120 + CTHE=1.-CTHM + IF(RLU(0).GT.0.5) CTHE=-CTHE + STHE=SQRT(MAX(0.D0,(CTHM-PME)*(2.-CTHM))) + THEK=ULANGL(CTHE,STHE) + PHIK=PARU(2)*RLU(0) + +C...Rotation angle for hadronic system. + SGN=1. + IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT. + &RLU(0)) SGN=-1. + ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/ + &(2.-XK*(1.-SGN*CTHE))) + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUXKFL + SUBROUTINE LUXKFL(KFL,ECM,ECMC,KFLC) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to select flavour for produced qqbar pair. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUDAT1/,/LUDAT2/ + +C...Calculate maximum weight in QED or QFD case. + IF(MSTJ(102).LE.1) THEN + RFMAX=4./9. + ELSE + POLL=1.-PARJ(131)*PARJ(132) + SFF=1./(16.*PARU(102)*(1.-PARU(102))) + SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1.-(PARJ(123)/ECMC)**2) + VE=4.*PARU(102)-1. + HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) + HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131))) + RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+ + & ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.* + & (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W) + ENDIF + +C...Choose flavour. Gives charge and velocity. + NTRY=0 + 100 NTRY=NTRY+1 + IF(NTRY.GT.100) THEN + CALL LUERRM(14,'(LUXKFL:) caught in an infinite loop') + KFLC=0 + RETURN + ENDIF + KFLC=KFL + IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLU(0)) + MSTJ(93)=1 + PMQ=ULMASS(KFLC) + IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100 + QF=KCHG(KFLC,1)/3. + VQ=1. + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.D0,1.-(2.*PMQ/ECMC)**2)) + +C...Calculate weight in QED or QFD case. + IF(MSTJ(102).LE.1) THEN + RF=QF**2 + RFV=0.5*VQ*(3.-VQ**2)*QF**2 + ELSE + VF=SIGN(1.D0,QF)-4.*QF*PARU(102) + RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W + RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+ + & VQ**3*HF1W + IF(RFV.GT.0.) PARJ(171)=MIN(1.D0,VQ**3*HF1W/RFV) + ENDIF + +C...Weighting or new event (radiative photon). Cross-section update. + IF(KFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100 + PARJ(158)=PARJ(158)+1. + IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLU(0)*RF) KFLC=0 + IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100 + IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1. + PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158) + PARJ(148)=PARJ(144)*86.8/ECM**2 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUXJET + SUBROUTINE LUXJET(ECM,NJET,CUT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to select number of jets in matrix element approach. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUDAT1/ + DIMENSION ZHUT(5) + +C...Relative three-jet rate in Zhu second order parametrization. + DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/ + +C...Trivial result for two-jets only, including parton shower. + IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN + CUT=0. + +C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R. + ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN + CF=4./3. + IF(MSTJ(109).EQ.2) CF=1. + IF(MSTJ(111).EQ.0) THEN + Q2=ECM**2 + Q2R=ECM**2 + ELSEIF(MSTU(111).EQ.0) THEN + PARJ(169)=MIN(1.D0,PARJ(129)) + Q2=PARJ(169)*ECM**2 + PARJ(168)=MIN(1.D0,MAX(PARJ(128),EXP(-12.*PARU(1)/ + & ((33.-2.*MSTU(112))*PARU(111))))) + Q2R=PARJ(168)*ECM**2 + ELSE + PARJ(169)=MIN(1.D0,MAX(PARJ(129),(2.*PARU(112)/ECM)**2)) + Q2=PARJ(169)*ECM**2 + PARJ(168)=MIN(1.D0,MAX(PARJ(128),PARU(112)/ECM, + & (2.*PARU(112)/ECM)**2)) + Q2R=PARJ(168)*ECM**2 + ENDIF + +C...alpha_strong for R and R itself. + ALSPI=(3./4.)*CF*ULALPS(Q2R)/PARU(1) + IF(IABS(MSTJ(101)).EQ.1) THEN + RQCD=1.+ALSPI + ELSEIF(MSTJ(109).EQ.0) THEN + RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2 + IF(MSTJ(111).EQ.1) RQCD=MAX(1.D0,RQCD+(33.-2.*MSTU(112))/12.* + & LOG(PARJ(168))*ALSPI**2) + ELSE + RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2 + ENDIF + +C...alpha_strong for jet rate. Initial value for y cut. + ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1) + CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2) + IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0)) + & CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.) + IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) + +C...Parametrization of first order three-jet cross-section. + 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN + PARJ(152)=0. + ELSE + PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))* + & LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+ + & 5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+ + & 1.342*(1.-3.*CUT)**4)/RQCD + IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2)) + & PARJ(152)=0. + ENDIF + +C...Parametrization of second order three-jet cross-section. + IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR. + & CUT.GE.0.25) THEN + PARJ(153)=0. + ELSEIF(MSTJ(110).LE.1) THEN + CT=LOG(1./CUT-2.) + PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2- + & 0.2661*CT**3+0.01159*CT**4)/RQCD + +C...Interpolation in second/first order ratio for Zhu parametrization. + ELSEIF(MSTJ(110).EQ.2) THEN + IZA=0 + DO 110 IY=1,5 + IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY + 110 CONTINUE + IF(IZA.NE.0) THEN + ZHURAT=ZHUT(IZA) + ELSE + IZ=100.*CUT + ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ)) + ENDIF + PARJ(153)=ALSPI*PARJ(152)*ZHURAT + ENDIF + +C...Shift in second order three-jet cross-section with optimized Q^2. + IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3. + & AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.* + & LOG(PARJ(169))*ALSPI*PARJ(152) + +C...Parametrization of second order four-jet cross-section. + IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN + PARJ(154)=0. + ELSE + CT=LOG(1./CUT-5.) + IF(CUT.LE.0.018) THEN + XQQGG=6.349-4.330*CT+0.8304*CT**2 + IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+ + & 0.4059*CT**2) + XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2) + IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ + ELSE + XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3 + IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT- + & 0.1326*CT**2+0.04365*CT**3) + XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093* + & CT**3) + IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ + ENDIF + PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD + PARJ(155)=XQQQQ/(XQQGG+XQQQQ) + ENDIF + +C...If negative three-jet rate, change y' optimization parameter. + IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND. + & PARJ(169).LT.0.99) THEN + PARJ(169)=MIN(1.D0,1.2*PARJ(169)) + Q2=PARJ(169)*ECM**2 + ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1) + GOTO 100 + ENDIF + +C...If too high cross-section, use harder cuts, or fail. + IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN + IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND. + & PARJ(169).LT.0.99) THEN + PARJ(169)=MIN(1.D0,1.2*PARJ(169)) + Q2=PARJ(169)*ECM**2 + ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1) + GOTO 100 + ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN + CALL LUERRM(26, + & '(LUXJET:) no allowed y cut value for Zhu parametrization') + ENDIF + CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.) + IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) + GOTO 100 + ENDIF + +C...Scalar gluon (first order only). + ELSE + ALSPI=ULALPS(ECM**2)/PARU(1) + CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI)) + PARJ(152)=0. + IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)* + & LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.)) + PARJ(153)=0. + PARJ(154)=0. + ENDIF + +C...Select number of jets. + PARJ(150)=CUT + IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN + NJET=2 + ELSEIF(MSTJ(101).LE.0) THEN + NJET=MIN(4,2-MSTJ(101)) + ELSE + RNJ=RLU(0) + NJET=2 + IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3 + IF(PARJ(154).GT.RNJ) NJET=4 + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUX3JT + SUBROUTINE LUX3JT(NJET,CUT,KFL,ECM,X1,X2) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to select the kinematical variables of three-jet events. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUDAT1/ + DIMENSION ZHUP(5,12) + +C...Coefficients of Zhu second order parametrization. + DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/ + & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90, + & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537, + & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855, + & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095, + & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806, + & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062, + & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19, + & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439, + & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99, + & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/ + +C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick). + DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49. + +C...Event type. Mass effect factors and other common constants. + MSTJ(120)=2 + MSTJ(121)=0 + PMQ=ULMASS(KFL) + QME=(2.*PMQ/ECM)**2 + IF(MSTJ(109).NE.1) THEN + CUTL=LOG(CUT) + CUTD=LOG(1./CUT-2.) + IF(MSTJ(109).EQ.0) THEN + CF=4./3. + CN=3. + TR=2. + WTMX=MIN(20.D0,37.-6.*CUTD) + IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT) + ELSE + CF=1. + CN=0. + TR=12. + WTMX=0. + ENDIF + +C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight. + ALS2PI=PARU(118)/PARU(2) + WTOPT=0. + IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))* + & ALS2PI + WTMAX=MAX(0.D0,1.+WTOPT+ALS2PI*WTMX) + +C...Choose three-jet events in allowed region. + 100 NJET=3 + 110 Y13L=CUTL+CUTD*RLU(0) + Y23L=CUTL+CUTD*RLU(0) + Y13=EXP(Y13L) + Y23=EXP(Y23L) + Y12=1.-Y13-Y23 + IF(Y12.LE.CUT) GOTO 110 + IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLU(0)) GOTO 110 + +C...Second order corrections. + IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN + Y12L=LOG(Y12) + Y13M=LOG(1.-Y13) + Y23M=LOG(1.-Y23) + Y12M=LOG(1.-Y12) + IF(Y13.LE.0.5) Y13I=DILOG(Y13) + IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13) + IF(Y23.LE.0.5) Y23I=DILOG(Y23) + IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23) + IF(Y12.LE.0.5) Y12I=DILOG(Y12) + IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12) + WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23) + WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+ + & 2.*(2.*CUTL-Y12L)*CUT/Y12)+ + & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+ + & 67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)* + & CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+ + & TR*(2.*CUTL/3.-10./9.)+ + & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+ + & Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+ + & Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/ + & WT1+ + & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+ + & (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L* + & Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)* + & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/ + & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))- + & 2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1- + & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I) + IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1 + IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110 + PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2) + + ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN +C...Second order corrections; Zhu parametrization of ERT. + ZX=(Y23-Y13)**2 + ZY=1.-Y12 + IZA=0 + DO 120 IY=1,5 + IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY + 120 CONTINUE + IF(IZA.NE.0) THEN + IZ=IZA + WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY + ELSE + IZ=100.*CUT + WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY + IZ=IZ+1 + WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY + WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ) + ENDIF + IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1 + IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110 + PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2) + ENDIF + +C...Impose mass cuts (gives two jets). For fixed jet number new try. + X1=1.-Y23 + X2=1.-Y13 + X3=1.-Y12 + IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2 + IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+ + & 0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+ + & (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLU(0)) NJET=2 + IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100 + +C...Scalar gluon model (first order only, no mass effects). + ELSE + 130 NJET=3 + 140 X3=SQRT(4.*CUT**2+RLU(0)*((1.-CUT)**2-4.*CUT**2)) + IF(LOG((X3-CUT)/CUT).LE.RLU(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140 + YD=SIGN(2.*CUT*((X3-CUT)/CUT)**RLU(0)-X3,RLU(0)-0.5) + X1=1.-0.5*(X3+YD) + X2=1.-0.5*(X3-YD) + IF(4.*(1.-X1)*(1.-X2)*(1.-X3)/X3**2.LE.QME) NJET=2 + IF(MSTJ(102).GE.2) THEN + IF(X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*PARJ(171).LT. + & X3**2*RLU(0)) NJET=2 + ENDIF + IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130 + ENDIF + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUX4JT + SUBROUTINE LUX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to select the kinematical variables of four-jet events. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUDAT1/ + DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4) + +C...Common constants. Colour factors for QCD and Abelian gluon theory. + PMQ=ULMASS(KFL) + QME=(2.*PMQ/ECM)**2 + CT=LOG(1./CUT-5.) + IF(MSTJ(109).EQ.0) THEN + CF=4./3. + CN=3. + TR=2.5 + ELSE + CF=1. + CN=0. + TR=15. + ENDIF + +C...Choice of process (qqbargg or qqbarqqbar). + 100 NJET=4 + IT=1 + IF(PARJ(155).GT.RLU(0)) IT=2 + IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2 + IF(IT.EQ.1) WTMX=0.7/CUT**2 + IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2 + IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2 + ID=1 + +C...Sample the five kinematical variables (for qqgg preweighted in y34). + 110 Y134=3.*CUT+(1.-6.*CUT)*RLU(0) + Y234=3.*CUT+(1.-6.*CUT)*RLU(0) + IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLU(0)) + IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLU(0) + IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110 + VT=RLU(0) + CP=COS(PARU(1)*RLU(0)) + Y14=(Y134-Y34)*VT + Y13=Y134-Y14-Y34 + VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34)) + Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.D0,VT*(1.-VT)*VB*(1.-VB)))* + &CP-(1.-2.*VT)*(1.-2.*VB)) + Y23=Y234-Y34-Y24 + Y12=1.-Y134-Y23-Y24 + IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110 + Y123=Y12+Y13+Y23 + Y124=Y12+Y14+Y24 + +C...Calculate matrix elements for qqgg or qqqq process. + IC=0 + WTTOT=0. + 120 IC=IC+1 + IF(IT.EQ.1) THEN + WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+ + & 3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24- + & Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12* + & Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+ + & 2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13* + & Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13* + & Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24) + WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12* + & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14* + & Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+ + & Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24) + WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12* + & Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+ + & Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24- + & Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/ + & (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24* + & Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12* + & Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14* + & Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+ + & 2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2- + & 2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34) + WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+ + & 4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34- + & Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+ + & 4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+ + & 2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.* + & Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)- + & (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23* + & Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24- + & 4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/ + & (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34- + & 2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34- + & 2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23- + & Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2) + WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/ + & 8. + ELSE + WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12* + & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2* + & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12* + & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14* + & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+ + & Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+ + & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24* + & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24- + & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123) + WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13* + & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23* + & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13* + & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+ + & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+ + & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134* + & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14* + & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124) + WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16. + ENDIF + +C...Permutations of momenta in matrix element. Weighting. + 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN + YSAV=Y13 + Y13=Y14 + Y14=YSAV + YSAV=Y23 + Y23=Y24 + Y24=YSAV + YSAV=Y123 + Y123=Y124 + Y124=YSAV + ENDIF + IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN + YSAV=Y13 + Y13=Y23 + Y23=YSAV + YSAV=Y14 + Y14=Y24 + Y24=YSAV + YSAV=Y134 + Y134=Y234 + Y234=YSAV + ENDIF + IF(IC.LE.3) GOTO 120 + IF(ID.EQ.1.AND.WTTOT.LT.RLU(0)*WTMX) GOTO 110 + IC=5 + +C...qqgg events: string configuration and event type. + IF(IT.EQ.1) THEN + IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN + PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+ + & WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT) + IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLU(0)*(WTA(1)+WTA(2)+ + & WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2 + IF(ID.EQ.2) GOTO 130 + ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN + PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT) + IF(WTA(2)+WTA(4).GT.RLU(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2 + IF(ID.EQ.2) GOTO 130 + ENDIF + MSTJ(120)=3 + IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT. + & RLU(0)*WTTOT) MSTJ(120)=4 + KFLN=21 + +C...Mass cuts. Kinematical variables out. + IF(Y12.LE.CUT+QME) NJET=2 + IF(NJET.EQ.2) GOTO 150 + Q12=0.5*(1.-SQRT(1.-QME/Y12)) + X1=1.-(1.-Q12)*Y234-Q12*Y134 + X4=1.-(1.-Q12)*Y134-Q12*Y234 + X2=1.-Y124 + X12=(1.-Q12)*Y13+Q12*Y23 + X14=Y12-0.5*QME + IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2 + +C...qqbarqqbar events: string configuration, choose new flavour. + ELSE + IF(ID.EQ.1) THEN + WTR=RLU(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4)) + IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2 + IF(WTR.LT.WTD(3)+WTD(4)) ID=3 + IF(WTR.LT.WTD(4)) ID=4 + IF(ID.GE.2) GOTO 130 + ENDIF + MSTJ(120)=5 + PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT) + 140 KFLN=1+INT(5.*RLU(0)) + IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLU(0)) GOTO 140 + IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLU(0)) GOTO 140 + IF(KFLN.GT.MSTJ(104)) NJET=2 + PMQN=ULMASS(KFLN) + QMEN=(2.*PMQN/ECM)**2 + +C...Mass cuts. Kinematical variables out. + IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2 + IF(NJET.EQ.2) GOTO 150 + Q24=0.5*(1.-SQRT(1.-QME/Y24)) + Q13=0.5*(1.-SQRT(1.-QMEN/Y13)) + X1=1.-(1.-Q24)*Y123-Q24*Y134 + X4=1.-(1.-Q24)*Y134-Q24*Y123 + X2=1.-(1.-Q13)*Y234-Q13*Y124 + X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23) + X14=Y24-0.5*QME + X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14) + IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE. + & (PARJ(127)+PMQ+PMQN)**2) NJET=2 + IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2 + ENDIF + 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUXDIF + SUBROUTINE LUXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to give the angular orientation of events. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Charge. Factors depending on polarization for QED case. + QF=KCHG(KFL,1)/3. + POLL=1.-PARJ(131)*PARJ(132) + POLD=PARJ(132)-PARJ(131) + IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN + HF1=POLL + HF2=0. + HF3=PARJ(133)**2 + HF4=0. + +C...Factors depending on flavour, energy and polarization for QFD case. + ELSE + SFF=1./(16.*PARU(102)*(1.-PARU(102))) + SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1.-(PARJ(123)/ECM)**2) + AE=-1. + VE=4.*PARU(102)-1. + AF=SIGN(1.D0,QF) + VF=AF-4.*QF*PARU(102) + HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+ + & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD) + HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2* + & (2.*VE*AE*POLL-(VE**2+AE**2)*POLD) + HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)* + & SFW*SFF**2*(VE**2-AE**2)) + HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)* + & SFF*AE + ENDIF + +C...Mass factor. Differential cross-sections for two-jet events. + SQ2=SQRT(2.) + QME=0. + IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND. + &MSTJ(109).NE.1) QME=(2.*ULMASS(KFL)/ECM)**2 + IF(NJET.EQ.2) THEN + SIGU=4.*SQRT(1.-QME) + SIGL=2.*QME*SQRT(1.-QME) + SIGT=0. + SIGI=0. + SIGA=0. + SIGP=4. + +C...Kinematical variables. Reduce four-jet event to three-jet one. + ELSE + IF(NJET.EQ.3) THEN + X1=2.*P(NC+1,4)/ECM + X2=2.*P(NC+3,4)/ECM + ELSE + ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+ + & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2) + X1=2.*P(NC+1,4)/ECMR + X2=2.*P(NC+4,4)/ECMR + ENDIF + +C...Differential cross-sections for three-jet (or reduced four-jet). + XQ=(1.-X1)/(1.-X2) + CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME)) + ST12=SQRT(1.-CT12**2) + IF(MSTJ(109).NE.1) THEN + SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)- + & QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ + SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+ + & 0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ + SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2 + SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+ + & 0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2 + SIGA=X2**2*ST12/SQ2 + SIGP=2.*(X1**2-X2**2*CT12) + +C...Differential cross-sect for scalar gluons (no mass effects). + ELSE + X3=2.-X1-X2 + XT=X2*ST12 + CT13=SQRT(MAX(0.D0,1.-(XT/X3)**2)) + SIGU=(1.-PARJ(171))*(X3**2-0.5*XT**2)+ + & PARJ(171)*(X3**2-0.5*XT**2-4.*(1.-X1)*(1.-X2)**2/X1) + SIGL=(1.-PARJ(171))*0.5*XT**2+ + & PARJ(171)*0.5*(1.-X1)**2*XT**2 + SIGT=(1.-PARJ(171))*0.25*XT**2+ + & PARJ(171)*0.25*XT**2*(1.-2.*X1) + SIGI=-(0.5/SQ2)*((1.-PARJ(171))*XT*X3*CT13+ + & PARJ(171)*XT*((1.-2.*X1)*X3*CT13-X1*(X1-X2))) + SIGA=(0.25/SQ2)*XT*(2.*(1.-X1)-X1*X3) + SIGP=X3**2-2.*(1.-X1)*(1.-X2)/X1 + ENDIF + ENDIF + +C...Upper bounds for differential cross-section. + HF1A=ABS(HF1) + HF2A=ABS(HF2) + HF3A=ABS(HF3) + HF4A=ABS(HF4) + SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)* + &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2* + &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+ + &2.*HF2A*ABS(SIGP) + +C...Generate angular orientation according to differential cross-sect. + 100 CHI=PARU(2)*RLU(0) + CTHE=2.*RLU(0)-1. + PHI=PARU(2)*RLU(0) + CCHI=COS(CHI) + SCHI=SIN(CHI) + C2CHI=COS(2.*CHI) + S2CHI=SIN(2.*CHI) + THE=ACOS(CTHE) + STHE=SIN(THE) + C2PHI=COS(2.*(PHI-PARJ(134))) + S2PHI=SIN(2.*(PHI-PARJ(134))) + SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+ + &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+ + &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI* + &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)* + &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI- + &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+ + &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP + IF(SIG.LT.SIGMAX*RLU(0)) GOTO 100 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUONIA + SUBROUTINE LUONIA(KFL,ECM) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to generate Upsilon and toponium decays into three +C...gluons or two gluons and a photon. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Printout. Check input parameters. + IF(MSTU(12).GE.1) CALL LULIST(0) + IF(KFL.LT.0.OR.KFL.GT.8) THEN + CALL LUERRM(16,'(LUONIA:) called with unknown flavour code') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN + CALL LUERRM(16,'(LUONIA:) called with too small CM energy') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Initial e+e- and onium state (optional). + NC=0 + IF(MSTJ(115).GE.2) THEN + NC=NC+2 + CALL LU1ENT(NC-1,11,0.5*ECM,0.D0,0.D0) + K(NC-1,1)=21 + CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.D0) + K(NC,1)=21 + ENDIF + KFLC=IABS(KFL) + IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN + NC=NC+1 + KF=110*KFLC+3 + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC,5)=ECM + CALL LU1ENT(NC,KF,ECM,0.D0,0.D0) + K(NC,1)=21 + K(NC,3)=1 + MSTU(10)=MSTU10 + ENDIF + +C...Choose x1 and x2 according to matrix element. + NTRY=0 + 100 X1=RLU(0) + X2=RLU(0) + X3=2.-X1-X2 + IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+ + &((1.-X3)/(X1*X2))**2.LE.2.*RLU(0)) GOTO 100 + NTRY=NTRY+1 + NJET=3 + IF(MSTJ(101).LE.4) CALL LU3ENT(NC+1,21,21,21,ECM,X1,X3) + IF(MSTJ(101).GE.5) CALL LU3ENT(-(NC+1),21,21,21,ECM,X1,X3) + +C...Photon-gluon-gluon events. Small system modifications. Jet origin. + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + &MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + QF=0. + IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3. + RGAM=7.2*QF**2*PARU(101)/ULALPS(ECM**2) + MK=0 + ECMC=ECM + IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN + IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125))) + & NJET=2 + IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LU2ENT(NC+1,21,21,ECM) + IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LU2ENT(-(NC+1),21,21,ECM) + ELSE + MK=1 + ECMC=SQRT(1.-X1)*ECM + IF(ECMC.LT.2.*PARJ(127)) GOTO 100 + K(NC+1,1)=1 + K(NC+1,2)=22 + K(NC+1,4)=0 + K(NC+1,5)=0 + IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3) + IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3) + IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2) + IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2) + NJET=2 + IF(ECMC.LT.4.*PARJ(127)) THEN + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC+2,5)=ECMC + CALL LU1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.D0) + MSTU(10)=MSTU10 + NJET=0 + ENDIF + ENDIF + DO 110 IP=NC+1,N + K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1) + 110 CONTINUE + +C...Differential cross-sections. Upper limit for cross-section. + IF(MSTJ(106).EQ.1) THEN + SQ2=SQRT(2.) + HF1=1.-PARJ(131)*PARJ(132) + HF3=PARJ(133)**2 + CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3) + ST13=SQRT(1.-CT13**2) + SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2 + SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL + SIGT=0.5*SIGL + SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2 + SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+ + & 2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI) + +C...Angular orientation of event. + 120 CHI=PARU(2)*RLU(0) + CTHE=2.*RLU(0)-1. + PHI=PARU(2)*RLU(0) + CCHI=COS(CHI) + SCHI=SIN(CHI) + C2CHI=COS(2.*CHI) + S2CHI=SIN(2.*CHI) + THE=ACOS(CTHE) + STHE=SIN(THE) + C2PHI=COS(2.*(PHI-PARJ(134))) + S2PHI=SIN(2.*(PHI-PARJ(134))) + SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1- + & STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)* + & C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE* + & CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI + IF(SIG.LT.SIGMAX*RLU(0)) GOTO 120 + CALL LUDBRB(NC+1,N,0.D0,CHI,0D0,0D0,0D0) + CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0) + ENDIF + +C...Generate parton shower. Rearrange along strings and check. + IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN + CALL LUSHOW(NC+MK+1,-NJET,ECMC) + MSTJ14=MSTJ(14) + IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 + IF(MSTJ(105).GE.0) MSTU(28)=0 + CALL LUPREP(0) + MSTJ(14)=MSTJ14 + IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 + ENDIF + +C...Generate fragmentation. Information for LUTABU: + IF(MSTJ(105).EQ.1) CALL LUEXEC + MSTU(161)=110*KFLC+3 + MSTU(162)=0 + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUHEPC + SUBROUTINE LUHEPC(MCONV) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to convert JETSET event record contents to or from +C...the standard event record commonblock. +C...Note that HEPEVT is in double precision according to LEP 2 standard. + PARAMETER (NMXHEP=2000) + COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), + &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) +C DOUBLE PRECISION PHEP,VHEP + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /HEPEVT/ + SAVE /LUJETS/,/LUDAT1/,/LUDAT2/ + +C...Conversion from JETSET to standard, the easy part. + IF(MCONV.EQ.1) THEN + NEVHEP=0 + IF(N.GT.NMXHEP) CALL LUERRM(8, + & '(LUHEPC:) no more space in /HEPEVT/') + NHEP=MIN(N,NMXHEP) + DO 140 I=1,NHEP + ISTHEP(I)=0 + IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1 + IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2 + IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3 + IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1) + IDHEP(I)=K(I,2) + JMOHEP(1,I)=K(I,3) + JMOHEP(2,I)=0 + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN + JDAHEP(1,I)=K(I,4) + JDAHEP(2,I)=K(I,5) + ELSE + JDAHEP(1,I)=0 + JDAHEP(2,I)=0 + ENDIF + DO 100 J=1,5 + PHEP(J,I)=P(I,J) + 100 CONTINUE + DO 110 J=1,4 + VHEP(J,I)=V(I,J) + 110 CONTINUE + +C...Check if new event (from pileup). + IF(I.EQ.1) THEN + INEW=1 + ELSE + IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I + ENDIF + +C...Fill in missing mother information. + IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN + IMO1=I-2 + IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0) + & IMO1=IMO1-1 + JMOHEP(1,I)=IMO1 + JMOHEP(2,I)=IMO1+1 + ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN + I1=K(I,3)-1 + 120 I1=I1+1 + IF(I1.GE.I) CALL LUERRM(8, + & '(LUHEPC:) translation of inconsistent event history') + IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120 + KC=LUCOMP(K(I1,2)) + IF(I1.LT.I.AND.KC.EQ.0) GOTO 120 + IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120 + JMOHEP(2,I)=I1 + ELSEIF(K(I,2).EQ.94) THEN + NJET=2 + IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3 + IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4 + JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5)) + IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)= + & MOD(K(I+1,4)/MSTU(5),MSTU(5)) + ENDIF + +C...Fill in missing daughter information. + IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN + DO 130 I1=JDAHEP(1,I),JDAHEP(2,I) + I2=MOD(K(I1,4)/MSTU(5),MSTU(5)) + JDAHEP(1,I2)=I + 130 CONTINUE + ENDIF + IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140 + I1=JMOHEP(1,I) + IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140 + IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140 + IF(JDAHEP(1,I1).EQ.0) THEN + JDAHEP(1,I1)=I + ELSE + JDAHEP(2,I1)=I + ENDIF + 140 CONTINUE + DO 150 I=1,NHEP + IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150 + IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I) + 150 CONTINUE + +C...Conversion from standard to JETSET, the easy part. + ELSE + IF(NHEP.GT.MSTU(4)) CALL LUERRM(8, + & '(LUHEPC:) no more space in /LUJETS/') + N=MIN(NHEP,MSTU(4)) + NKQ=0 + KQSUM=0 + DO 180 I=1,N + K(I,1)=0 + IF(ISTHEP(I).EQ.1) K(I,1)=1 + IF(ISTHEP(I).EQ.2) K(I,1)=11 + IF(ISTHEP(I).EQ.3) K(I,1)=21 + K(I,2)=IDHEP(I) + K(I,3)=JMOHEP(1,I) + K(I,4)=JDAHEP(1,I) + K(I,5)=JDAHEP(2,I) + DO 160 J=1,5 + P(I,J)=PHEP(J,I) + 160 CONTINUE + DO 170 J=1,4 + V(I,J)=VHEP(J,I) + 170 CONTINUE + V(I,5)=0. + IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN + I1=JDAHEP(1,I) + IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))* + & PHEP(5,I)/PHEP(4,I) + ENDIF + +C...Fill in missing information on colour connection in jet systems. + IF(ISTHEP(I).EQ.1) THEN + KC=LUCOMP(K(I,2)) + KQ=0 + IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.NE.0) NKQ=NKQ+1 + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(KQ.NE.0.AND.KQSUM.NE.0) THEN + K(I,1)=2 + ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN + IF(K(I+1,2).EQ.21) K(I,1)=2 + ENDIF + ENDIF + 180 CONTINUE + IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LUERRM(8, + & '(LUHEPC:) input parton configuration not colour singlet') + ENDIF + + END + +C********************************************************************* + +CDECK ID>, LUTEST + SUBROUTINE LUTEST(MTEST) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to provide a simple program (disguised as subroutine) to +C...run at installation as a check that the program works as intended. + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUJETS/,/LUDAT1/ + DIMENSION PSUM(5),PINI(6),PFIN(6) + +C...Loop over events to be generated. + IF(MTEST.GE.1) CALL LUTABU(20) + NERR=0 + DO 180 IEV=1,600 + +C...Reset parameter values. Switch on some nonstandard features. + MSTJ(1)=1 + MSTJ(3)=0 + MSTJ(11)=1 + MSTJ(42)=2 + MSTJ(43)=4 + MSTJ(44)=2 + PARJ(17)=0.1 + PARJ(22)=1.5 + PARJ(43)=1. + PARJ(54)=-0.05 + MSTJ(101)=5 + MSTJ(104)=5 + MSTJ(105)=0 + MSTJ(107)=1 + IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3 + +C...Ten events each for some single jets configurations. + IF(IEV.LE.50) THEN + ITY=(IEV+9)/10 + MSTJ(3)=-1 + IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2 + IF(ITY.EQ.1) CALL LU1ENT(1,1,15.D0,0.D0,0.D0) + IF(ITY.EQ.2) CALL LU1ENT(1,3101,15.D0,0.D0,0.D0) + IF(ITY.EQ.3) CALL LU1ENT(1,-2203,15.D0,0.D0,0.D0) + IF(ITY.EQ.4) CALL LU1ENT(1,-4,30.D0,0.D0,0.D0) + IF(ITY.EQ.5) CALL LU1ENT(1,21,15.D0,0.D0,0.D0) + +C...Ten events each for some simple jet systems; string fragmentation. + ELSEIF(IEV.LE.130) THEN + ITY=(IEV-41)/10 + IF(ITY.EQ.1) CALL LU2ENT(1,1,-1,40.D0) + IF(ITY.EQ.2) CALL LU2ENT(1,4,-4,30.D0) + IF(ITY.EQ.3) CALL LU2ENT(1,2,2103,100.D0) + IF(ITY.EQ.4) CALL LU2ENT(1,21,21,40.D0) + IF(ITY.EQ.5) CALL LU3ENT(1,2101,21,-3203,30.D0,0.6D0,0.8D0) + IF(ITY.EQ.6) CALL LU3ENT(1,5,21,-5,40.D0,0.9D0,0.8D0) + IF(ITY.EQ.7) CALL LU3ENT(1,21,21,21,60.D0,0.7D0,0.5D0) + IF(ITY.EQ.8) + & CALL LU4ENT(1,2,21,21,-2,40.D0,0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + +C...Seventy events with independent fragmentation and momentum cons. + ELSEIF(IEV.LE.200) THEN + ITY=1+(IEV-131)/16 + MSTJ(2)=1+MOD(IEV-131,4) + MSTJ(3)=1+MOD((IEV-131)/4,4) + IF(ITY.EQ.1) CALL LU2ENT(1,4,-5,40.D0) + IF(ITY.EQ.2) CALL LU3ENT(1,3,21,-3,40.D0,0.9D0,0.4D0) + IF(ITY.EQ.3) + & CALL LU4ENT(1,2,21,21,-2,40.D0,0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + IF(ITY.GE.4) + & CALL LU4ENT(1,2,-3,3,-2,40.D0,0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + +C...A hundred events with random jets (check invariant mass). + ELSEIF(IEV.LE.300) THEN + 100 DO 110 J=1,5 + PSUM(J)=0. + 110 CONTINUE + NJET=2.+6.*RLU(0) + DO 130 I=1,NJET + KFL=21 + IF(I.EQ.1) KFL=INT(1.+4.*RLU(0)) + IF(I.EQ.NJET) KFL=-INT(1.+4.*RLU(0)) + EJET=5.+20.*RLU(0) + THETA=ACOS(2.*RLU(0)-1.) + PHI=6.2832*RLU(0) + IF(I.LT.NJET) CALL LU1ENT(-I,KFL,EJET,THETA,PHI) + IF(I.EQ.NJET) CALL LU1ENT(I,KFL,EJET,THETA,PHI) + IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1 + IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+ULMASS(KFL) + DO 120 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 120 CONTINUE + 130 CONTINUE + IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT. + & (PSUM(5)+PARJ(32))**2) GOTO 100 + +C...Fifty e+e- continuum events with matrix elements. + ELSEIF(IEV.LE.350) THEN + MSTJ(101)=2 + CALL LUEEVT(0,40.D0) + +C...Fifty e+e- continuum event with varying shower options. + ELSEIF(IEV.LE.400) THEN + MSTJ(42)=1+MOD(IEV,2) + MSTJ(43)=1+MOD(IEV/2,4) + MSTJ(44)=MOD(IEV/8,3) + CALL LUEEVT(0,90.D0) + +C...Fifty e+e- continuum events with coherent shower, including top. + ELSEIF(IEV.LE.450) THEN + MSTJ(104)=6 + CALL LUEEVT(0,500.D0) + +C...Fifty Upsilon decays to ggg or gammagg with coherent shower. + ELSEIF(IEV.LE.500) THEN + CALL LUONIA(5,9.46D0) + +C...One decay each for some heavy mesons. + ELSEIF(IEV.LE.560) THEN + ITY=IEV-501 + KFLS=2*(ITY/20)+1 + KFLB=8-MOD(ITY/5,4) + KFLC=KFLB-MOD(ITY,5) + CALL LU1ENT(1,100*KFLB+10*KFLC+KFLS,0.D0,0.D0,0.D0) + +C...One decay each for some heavy baryons. + ELSEIF(IEV.LE.600) THEN + ITY=IEV-561 + KFLS=2*(ITY/20)+2 + KFLA=8-MOD(ITY/5,4) + KFLB=KFLA-MOD(ITY,5) + KFLC=MAX(1,KFLB-1) + CALL LU1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.D0,0.D0,0.D0) + ENDIF + +C...Generate event. Find total momentum, energy and charge. + DO 140 J=1,4 + PINI(J)=PLU(0,J) + 140 CONTINUE + PINI(6)=PLU(0,6) + CALL LUEXEC + DO 150 J=1,4 + PFIN(J)=PLU(0,J) + 150 CONTINUE + PFIN(6)=PLU(0,6) + +C...Check conservation of energy, momentum and charge; +C...usually exact, but only approximate for single jets. + MERR=0 + IF(IEV.LE.50) THEN + IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1 + EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3) + IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1 + IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1 + ELSE + DO 160 J=1,4 + IF(ABS(PFIN(J)-PINI(J)).GT.0.0001*PINI(4)) MERR=MERR+1 + 160 CONTINUE + IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1 + ENDIF + IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), + &(PFIN(J),J=1,4),PFIN(6) + +C...Check that all KF codes are known ones, and that partons/particles +C...satisfy energy-momentum-mass relation. Store particle statistics. + DO 170 I=1,N + IF(K(I,1).GT.20) GOTO 170 + IF(LUCOMP(K(I,2)).EQ.0) THEN + WRITE(MSTU(11),5100) I + MERR=MERR+1 + ENDIF + PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 + IF(ABS(PD).GT.MAX(0.1D0,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN + WRITE(MSTU(11),5200) I + MERR=MERR+1 + ENDIF + 170 CONTINUE + IF(MTEST.GE.1) CALL LUTABU(21) + +C...List all erroneous events and some normal ones. + IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN + CALL LULIST(2) + ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN + CALL LULIST(1) + ENDIF + +C...Stop execution if too many errors. + IF(MERR.NE.0) NERR=NERR+1 + IF(NERR.GE.10) THEN + WRITE(MSTU(11),5300) IEV + STOP + ENDIF + 180 CONTINUE + +C...Summarize result of run. + IF(MTEST.GE.1) CALL LUTABU(22) + IF(NERR.EQ.0) WRITE(MSTU(11),5400) + IF(NERR.GT.0) WRITE(MSTU(11),5500) NERR + +C...Reset commonblock variables changed during run. + MSTJ(2)=3 + PARJ(17)=0. + PARJ(22)=1. + PARJ(43)=0.5 + PARJ(54)=0. + MSTJ(105)=1 + MSTJ(107)=0 + +C...Format statements for output. + 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ', + &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X, + &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X, + &4(1X,F12.5),1X,F8.2) + 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code') + 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ', + &'kinematics') + 5300 FORMAT(/5X,'Ten errors experienced by event ',I3/ + &5X,'Something is seriously wrong! Execution stopped now!') + 5400 FORMAT(//5X,'End result of LUTEST: no errors detected.') + 5500 FORMAT(//5X,'End result of LUTEST:',I2,' errors detected.'/ + &5X,'This should not have happened!') + + RETURN + END + +C********************************************************************* + +CDECK ID>, LUDATA + BLOCK DATA LUDATA + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Purpose: to give default values to parameters and particle and +C...decay data. + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5) + COMMON/LUDAT4/CHAF(500) + CHARACTER CHAF*8 + COMMON/LUDATR/MRLU(6),RRLU(100) + SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/ + +C...LUDAT1, containing status codes and most parameters. + DATA MSTU/ + & 0, 0, 0, 4000,10000, 500, 2000, 0, 0, 2, + 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0, + 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0, + 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 7 30*0, + & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0, + 2 60*0, + 8 7, 408, 1995, 08, 23, 700, 0, 0, 0, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + DATA PARU/ + & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0., + 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0., + 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0., + 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0., + 6 40*0., + & 0.00729735, 0.232, 0.007764, 1.0, 1.16639D-5, 0., 0., 0., + & 0., 0., + 1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0., + 2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0., + 3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0., + 4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0., + 5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0., + 6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0., + 7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., + 8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0., + 9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./ + DATA MSTJ/ + & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0, + 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 0, + 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 6 40*0, + & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2, + 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, + 2 80*0/ + DATA PARJ/ + & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0., + 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0., + 2 0.36, 1.0, 0.01, 2.0, 1.0, 0.4, 0., 0., 0., 0., + 3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0., + 4 0.3, 0.58, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0., + 5 0.77,0.77,0.77,-0.05,-0.005,-0.00001,-0.00001,-0.00001,1.0,0., + 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0., + 7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0., + 8 0.29, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0., + 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0., + & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 2 1.0, 0.25,91.187,2.489, 0.01, 2.0, 1.0, 0.25,0.002, 0., + 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0., + 4 60*0./ + +C...LUDAT2, with particle data and flavour treatment parameters. + DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0, + &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,44*0,2,-1,2,-1,2,3,11*0,3,0,2*3,0, + &3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0, + &3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0, + &3,0,3,70*0,3,0,3,28*0,3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0, + &3,5*0,-3,0,3,-3,0,-3,4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0, + &-3,0,3,-3,0,-3,114*0/ + DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,50*0,-1,410*0/ + DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1, + &41*0,1,0,7*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1, + &10*0,10*1,70*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1, + &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/ + DATA (PMAS(I,1),I= 1, 500)/0.0099,0.0056,0.199,1.35,5.,160., + &2*250.,2*0.,0.00051,0.,0.1057,0.,1.777,0.,250.,5*0.,91.187,80.25, + &80.,6*0.,500.,900.,500.,3*300.,350.,200.,5000.,60*0.,0.1396, + &0.4977,0.4936,1.8693,1.8645,1.9688,5.2787,5.2786,5.47972,6.594, + &0.135,0.5475,0.9578,2.9788,9.4,320.,2*500.,2*0.,0.7669,0.8961, + &0.8916,2.0101,2.0071,2.11,2*5.325,5.5068,6.602,0.7683,0.782, + &1.0194,3.0969,9.4603,320.,2*500.,2*0.,1.232,2*1.29,2*2.424,2.536, + &2*5.73,5.97,7.3,1.232,1.17,1.4,3.46,9.875,320.,2*500.,2*0.,0.983, + &2*1.429,2*2.272,2.5,2*5.68,5.92,7.25,0.9827,1.,1.4,3.4151,9.8598, + &320.,2*500.,2*0.,1.26,2*1.402,2*2.372,2.56,2*5.78,6.02,7.3,1.26, + &1.282,1.42,3.5106,9.8919,320.,2*500.,2*0.,1.318,1.432,1.425, + &2*2.46,2.61,2*5.83,6.07,7.35,1.318,1.275,1.525,3.5562,9.9132, + &320.,2*500.,2*0.,2*0.4977,8*0.,3.686,3*0.,10.0233,70*0.,1.1156, + &5*0.,2.2849,0.,2.473,2.466,6*0.,5.641,0.,2*5.84,6*0.,0.9396, + &0.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.4525,2.4529, + &2.4527,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232, + &1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8, + &4*0.,3*5.81,2*5.97,6.13,114*0./ + DATA (PMAS(I,2),I= 1, 500)/22*0.,2.489,2.066,88*0.,0.0002, + &0.001,6*0.,0.149,0.0505,0.0498,7*0.,0.151,0.00843,0.0044,7*0., + &0.155,2*0.09,2*0.02,0.,4*0.05,0.155,0.36,0.08,2*0.01,5*0.,0.057, + &2*0.287,7*0.05,0.057,0.,0.25,0.014,6*0.,0.4,2*0.174,7*0.05,0.4, + &0.024,0.06,0.0009,6*0.,0.11,0.109,0.098,2*0.019,5*0.02,0.11, + &0.185,0.076,0.002,146*0.,4*0.12,0.0394,0.036,0.0358,0.0099, + &0.0091,131*0./ + DATA (PMAS(I,3),I= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0., + &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,0.005,0.01,2*0.08,0., + &4*0.1,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,6*0.1,2*0.05,0.,0.35, + &0.05,6*0.,3*0.3,2*0.1,0.03,4*0.1,0.3,0.05,0.02,0.001,6*0.,0.25, + &4*0.12,5*0.05,0.25,0.17,0.2,0.01,146*0.,4*0.14,0.04,2*0.035, + &2*0.05,131*0./ + DATA (PMAS(I,4),I= 1, 500)/12*0.,658650.,0.,0.0914,68*0.,0.1, + &0.387,15*0.,7804.,0.,3709.,0.32,0.1259,0.135,3*0.387,0.15,110*0., + &15500.,26.75,83*0.,78.88,5*0.,0.057,0.,0.025,0.09,6*0.,0.387,0., + &2*0.387,9*0.,44.3,0.,23.95,49.1,86.9,6*0.,0.13,9*0.,0.387,13*0., + &24.60001,130*0./ + DATA PARF/ + & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0., + 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0., + 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0., + 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0., + 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0., + 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0., + 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0., + 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0., + 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0., + 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0., + 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0., + 3 1870*0./ + DATA ((VCKM(I,J),J=1,4),I=1,4)/ + 1 0.95113, 0.04884, 0.00003, 0.00000, + 2 0.04884, 0.94940, 0.00176, 0.00000, + 3 0.00003, 0.00176, 0.99821, 0.00000, + 4 0.00000, 0.00000, 0.00000, 1.00000/ + +C...LUDAT3, with particle decay parameters and data. + DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,1, + &2*0,4*1,42*0,7*1,12*0,1,0,15*1,2*0,18*1,2*0,18*1,2*0,18*1,2*0, + &18*1,2*0,18*1,3*0,1,8*0,1,3*0,1,70*0,1,5*0,1,0,2*1,6*0,1,0,2*1, + &9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/ + DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,50,60,2*0,70,74,76, + &81,83,124,126,132,2*0,135,144,156,172,192,6*0,209,0,231,254,274, + &292,301,304,305,42*0,314,315,319,328,331,336,338,11*0,358,359, + &361,367,430,491,524,560,596,635,666,668,675,681,682,683,684,685, + &2*0,686,688,691,694,697,699,700,701,702,703,704,708,713,721,724, + &733,734,735,2*0,736,737,742,747,749,751,753,755,757,759,761,762, + &765,769,770,771,772,773,2*0,774,775,777,779,781,783,785,787,789, + &791,793,794,799,804,806,808,809,810,2*0,811,813,815,817,819,821, + &823,825,827,829,831,833,846,850,852,854,855,856,2*0,857,863,873, + &884,892,900,904,912,920,924,928,936,945,951,953,955,956,957,2*0, + &958,966,8*0,968,3*0,979,70*0,993,5*0,997,0,1073,1074,6*0,1075,0, + &1092,1093,9*0,1094,1096,1097,1100,1101,0,1103,1104,1105,1106, + &1107,1108,4*0,1109,1110,1111,1112,1113,1114,4*0,1115,1116,1119, + &1122,1123,1126,1129,1132,1134,1136,1140,1141,1142,1143,1145,1147, + &4*0,1148,1149,1150,1151,1152,1153,114*0/ + DATA (MDCY(I,3),I= 1, 500)/5*8,9,2*10,2*0,4,2,5,2,41,2,6,3,2*0, + &9,12,16,20,17,6*0,22,0,23,20,18,9,3,1,9,42*0,1,4,9,3,5,2,20,11*0, + &1,2,6,63,61,33,2*36,39,31,2,7,6,5*1,2*0,2,3*3,2,5*1,4,5,8,3,9, + &3*1,2*0,1,2*5,7*2,1,3,4,5*1,2*0,1,9*2,1,2*5,2*2,3*1,2*0,11*2,13, + &4,2*2,3*1,2*0,6,10,11,2*8,4,2*8,2*4,8,9,6,2*2,3*1,2*0,8,2,8*0,11, + &3*0,14,70*0,4,5*0,76,0,2*1,6*0,17,0,2*1,9*0,2,1,3,1,2,0,6*1,4*0, + &6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/ + DATA (MDME(I,1),I= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1, + &7*1,-1,1,-1,8*1,2*-1,8*1,2*-1,61*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1, + &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,2*-1, + &3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,6*1, + &2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,3*1,-1,9*1,2*-1,2*1,-1, + &16*1,-1,2*1,3*-1,1665*1/ + DATA (MDME(I,2),I= 1,2000)/75*102,42,6*102,2*42,2*0,7*41,2*0, + &24*41,6*102,45,29*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32, + &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,5*0,3*32,0, + &6*32,3*0,12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0, + &24*42,41*0,16*42,46*0,10*42,20*0,2*13,14*42,16*0,48,3*13,16*42, + &16*0,48,3*13,16*42,19*0,48,3*13,2*42,0,2*11,28*42,0,2,4*0,2,8*0, + &12,32,86,87,88,3,0,2*3,0,2*3,0,2*3,0,3,6*0,3,3*0,1,0,3,2*0,2*3, + &3*0,1,4*0,12,3*0,4*32,2*4,86,87,88,33*0,12,32,86,87,88,31*0,12,0, + &32,86,87,88,40*0,12,0,32,86,87,88,95*0,12,0,32,86,87,88,2*0,4*42, + &6*0,12,11*0,4*32,2*4,9*0,14*42,52*0,10*13,2*84,3*42,8*0,48,3*13, + &2*42,2*85,14*0,84,5*0,85,886*0/ + DATA (BRAT(I) ,I= 1, 439)/75*0.,1.,6*0.,0.179,0.178,0.116, + &0.235,0.005,0.056,0.018,0.023,0.011,2*0.004,0.0067,0.014,2*0.002, + &2*0.001,0.0022,0.054,0.002,0.016,0.005,0.011,0.0101,5*0.006, + &0.002,2*0.001,5*0.002,6*0.,1.,29*0.,0.15394,0.11936,0.15394, + &0.11926,0.15254,3*0.,0.03368,0.06664,0.03368,0.06664,0.03368, + &0.06664,2*0.,0.3214,0.0165,2*0.,0.0165,0.3207,2*0.,0.00001, + &0.00059,6*0.,3*0.1081,3*0.,0.0003,0.048,0.8705,4*0.,0.0002, + &0.0603,0.,0.0199,0.0008,3*0.,0.143,0.111,0.143,0.111,0.143,0.085, + &2*0.,0.03,0.058,0.03,0.058,0.03,0.058,8*0.,0.25,0.01,2*0.,0.01, + &0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,0.08,0.82,5*0.,0.09,11*0., + &0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,0.01,0.98,0.01,1.,4*0.215, + &2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.105,0.04,0.5,0.08,0.14, + &0.01,0.015,0.005,1.,3*0.,1.,4*0.,1.,0.25,0.01,2*0.,0.01,0.25, + &4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,0.017,0.048, + &0.032,0.07,0.065,2*0.005,2*0.011,5*0.001,0.07,0.065,2*0.005, + &2*0.011,5*0.001,0.026,0.019,0.066,0.041,0.045,0.076,0.0073, + &2*0.0047,0.026,0.001,0.0006,0.0066,0.005,2*0.003,2*0.0006, + &2*0.001,0.006,0.005,0.012,0.0057,0.067,0.008,0.0022,0.027,0.004, + &0.019,0.012,0.002,0.009,0.0218,0.001,0.022,0.087,0.001,0.0019, + &0.0015,0.0028,0.034,0.027,2*0.002,2*0.004,2*0.002,0.034,0.027/ + DATA (BRAT(I) ,I= 440, 655)/2*0.002,2*0.004,2*0.002,0.0365, + &0.045,0.073,0.062,3*0.021,0.0061,0.015,0.025,0.0088,0.074,0.0109, + &0.0041,0.002,0.0035,0.0011,0.001,0.0027,2*0.0016,0.0018,0.011, + &0.0063,0.0052,0.018,0.016,0.0034,0.0036,0.0009,0.0006,0.015, + &0.0923,0.018,0.022,0.0077,0.009,0.0075,0.024,0.0085,0.067,0.0511, + &0.017,0.0004,0.0028,0.01,2*0.02,0.03,2*0.005,2*0.02,0.03,2*0.005, + &0.015,0.037,0.028,0.079,0.095,0.052,0.0078,4*0.001,0.028,0.033, + &0.026,0.05,0.01,4*0.005,0.25,0.0952,0.02,0.055,2*0.005,0.008, + &0.012,0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011, + &0.0055,0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,0.0004, + &0.0007,0.0008,0.0014,0.0019,0.0025,0.4291,0.08,0.07,0.02,0.015, + &0.005,0.02,0.055,2*0.005,0.008,0.012,0.02,0.055,2*0.005,0.008, + &0.012,0.01,0.03,0.0035,0.011,0.0055,0.0042,0.009,0.018,0.015, + &0.0185,0.0135,0.025,0.0004,0.0007,0.0008,0.0014,0.0019,0.0025, + &0.4291,0.08,0.07,0.02,0.015,0.005,0.02,0.055,2*0.005,0.008,0.012, + &0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,0.0055, + &0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,2*0.0002,0.0007, + &2*0.0004,0.0014,0.001,0.0009,0.0025,0.4291,0.08,0.07,0.02,0.015, + &0.005,0.047,0.122,0.006,0.012,0.035,0.012,0.035,0.003,0.007,0.15, + &0.037,0.008,0.002,0.05,0.015,0.003,0.001,0.014,0.042,0.014,0.042/ + DATA (BRAT(I) ,I= 656, 931)/0.24,0.065,0.012,0.003,0.001,0.002, + &0.001,0.002,0.014,0.003,0.988,0.012,0.389,0.319,0.2367,0.049, + &0.005,0.001,0.0003,0.441,0.206,0.3,0.03,0.022,0.001,5*1.,0.99955, + &0.00045,0.665,0.333,0.002,0.666,0.333,0.001,0.65,0.3,0.05,0.56, + &0.44,5*1.,0.99912,0.00079,0.00005,0.00004,0.888,0.085,0.021, + &2*0.003,0.49,0.344,3*0.043,0.023,0.013,0.001,0.0627,0.0597, + &0.8776,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,4*1.,0.28,0.14, + &0.313,0.157,0.11,0.28,0.14,0.313,0.157,0.11,0.667,0.333,0.667, + &0.333,2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.333,0.334,0.333, + &4*0.25,6*1.,0.667,0.333,0.667,0.333,0.667,0.333,0.667,0.333, + &2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.52,0.26,0.11,2*0.055, + &0.62,0.31,0.035,2*0.0175,0.007,0.993,0.02,0.98,3*1.,2*0.5,0.667, + &0.333,0.667,0.333,0.667,0.333,0.667,0.333,2*0.5,0.667,0.333, + &0.667,0.333,6*0.5,3*0.12,0.097,0.043,4*0.095,4*0.03,4*0.25,0.273, + &0.727,0.35,0.65,3*1.,2*0.35,0.144,0.105,0.048,0.003,0.333,0.166, + &0.168,0.084,0.087,0.043,0.059,2*0.029,0.002,0.332,0.166,0.168, + &0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,0.15,0.16,0.08,0.13, + &0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.3, + &2*0.2,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08, + &0.13,0.06,0.08,0.04,2*0.3,2*0.2,2*0.3,2*0.2,2*0.35,0.144,0.105/ + DATA (BRAT(I) ,I= 932,2000)/0.024,2*0.012,0.003,0.566,0.283, + &0.069,0.028,0.023,2*0.0115,0.005,0.003,0.356,2*0.178,0.28, + &2*0.004,0.135,0.865,0.22,0.78,3*1.,0.217,0.124,2*0.193,2*0.135, + &0.002,0.001,0.686,0.314,2*0.0083,0.1866,0.324,0.184,0.027,0.001, + &0.093,0.087,0.078,0.0028,3*0.014,0.008,0.024,0.008,0.024,0.425, + &0.02,0.185,0.088,0.043,0.067,0.066,0.641,0.357,2*0.001,0.018, + &2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,2*0.006, + &0.0066,0.025,0.016,0.0088,2*0.005,0.0058,0.005,0.0055,4*0.004, + &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002, + &2*0.001,2*0.002,0.0013,0.0018,5*0.001,4*0.003,2*0.005,2*0.002, + &2*0.001,2*0.002,2*0.001,0.2432,0.057,2*0.035,0.15,2*0.075,0.03, + &2*0.015,2*1.,2*0.105,0.04,0.0077,0.02,0.0235,0.0285,0.0435, + &0.0011,0.0022,0.0044,0.4291,0.08,0.07,0.02,0.015,0.005,2*1., + &0.999,0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331, + &0.663,0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88, + &2*0.06,0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5, + &7*1.,847*0./ + DATA (KFDP(I,1),I= 1, 507)/21,22,23,4*-24,25,21,22,23,4*24,25, + &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23, + &4*24,25,37,21,22,23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23, + &-24,25,23,24,-12,22,23,-24,25,23,24,-12,-14,35*16,22,23,-24,25, + &23,24,-89,22,23,-24,25,-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5, + &6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1, + &4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21, + &2*22,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25, + &35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11, + &13,15,17,21,2*22,23,24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21, + &2*22,23,24,23,-1,-3,-5,-7,-11,-13,-15,-17,24,5,6,21,2,1,2,3,4,5, + &6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37, + &2*-89,2*5,-37,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130, + &310,-13,3*211,12,14,11*-11,11*-13,-311,-313,-311,-313,-20313, + &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311, + &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311, + &-321,211,113,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311, + &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333, + &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211, + &-321,3*-311,211,113,321,-15,5*-11,5*-13,221,331,333,221,331,333/ + DATA (KFDP(I,1),I= 508, 924)/10221,211,213,211,213,321,323,321, + &323,2212,221,331,333,221,2*2,6*12,6*14,2*16,3*-411,3*-413,2*-411, + &2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,2*16,3*-421, + &3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14, + &2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4, + &16,2*4,2*12,2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13, + &2*-1,3*22,111,211,2*22,211,22,211,111,3*22,111,82,21,3*0,2*211, + &321,3*311,2*321,421,2*411,2*421,431,511,521,531,541,211,111,13, + &11,211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,82,11, + &13,15,1,2,3,4,21,22,3*0,223,321,311,323,313,2*311,321,313,323, + &321,423,2*413,2*423,413,523,2*513,2*523,2*513,523,223,213,113, + &-213,313,-313,323,-323,82,21,3*0,221,321,2*311,321,421,2*411,421, + &411,421,521,2*511,2*521,2*511,521,221,211,111,321,130,310,211, + &111,321,130,310,443,82,553,21,3*0,113,213,323,2*313,323,423, + &2*413,2*423,413,523,2*513,2*523,2*513,523,213,-213,10211,10111, + &-10211,2*221,213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82, + &553,21,3*0,213,113,221,223,321,211,321,311,323,313,323,313,321, + &4*311,321,313,323,313,323,311,4*321,421,411,423,413,423,413,421, + &2*411,421,413,423,413,423,411,2*421,411,423,413,521,511,523,513, + &523,513,521,2*511,521,513,523,513,523,511,2*521,511,523,513,511/ + DATA (KFDP(I,1),I= 925,2000)/521,513,523,213,-213,221,223,321, + &130,310,111,211,111,2*211,321,130,310,221,111,321,130,310,221, + &211,111,443,82,553,21,3*0,111,211,-12,12,-14,14,211,111,211,111, + &11,13,82,4*443,10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553, + &10551,20553,555,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214, + &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,7*2212, + &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3, + &2*2,1,2*2,2*0,-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4, + &2*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,4232,0, + &3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,3212, + &3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,3322, + &3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,847*0/ + DATA (KFDP(I,2),I= 1, 476)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4, + &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,3*7,2,4,6,8,7, + &4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13, + &-211,-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,3*-321, + &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15, + &16,15,16,15,18,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21, + &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8, + &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8, + &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23, + &-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24, + &-37,22,25,2*36,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22, + &25,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25, + &36,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4, + &6,8,12,14,16,18,25,-5,-6,21,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82, + &12,14,-1,-3,11,13,15,1,4,3,4,1,3,5,3,5,6,4,21,22,4,7,5,2,4,6,8,2, + &4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13, + &11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,213,211,213, + &211,213,211,213,211,213,211,213,3*211,213,211,2*321,8*211,2*113, + &2*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,211, + &2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,211/ + DATA (KFDP(I,2),I= 477, 857)/-211,4*211,321,4*211,113,2*211,-321, + &16,5*12,5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112, + &3*321,323,2*-1,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431, + &433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,6*-11, + &6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,321,323, + &321,323,321,323,-1,-4,-3,-4,-1,-3,6*-11,6*-13,2*-15,211,213, + &20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,221, + &331,333,-1,-4,-3,-4,-1,-3,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3, + &-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,11,22,111,-211, + &211,11,-211,13,-211,111,113,223,22,111,-82,21,3*0,111,22,-211, + &111,22,211,111,22,211,111,22,111,6*22,-211,22,-13,-11,-211,111, + &-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,-11,-13, + &-15,-1,-2,-3,-4,2*21,3*0,211,-213,113,-211,111,223,213,113,211, + &111,223,211,111,-211,111,321,311,-211,111,211,111,-321,-311,411, + &421,111,-211,111,211,-311,311,-321,321,-82,21,3*0,211,-211,111, + &211,111,211,111,-211,111,311,321,-211,111,211,111,-321,-311,411, + &421,111,-211,111,-321,130,310,-211,111,-321,130,310,22,-82,22,21, + &3*0,211,111,-211,111,211,111,211,111,-211,111,321,311,-211,111, + &211,111,-321,-311,411,421,-211,211,-211,111,2*211,111,-211,211, + &111,211,-321,2*-311,-321,-311,311,-321,321,22,-82,22,21,3*0,111/ + DATA (KFDP(I,2),I= 858,2000)/3*211,-311,22,-211,111,-211,111, + &-211,211,-213,113,223,221,211,111,211,111,2*211,213,113,223,221, + &22,211,111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321, + &311,321,311,-211,111,-211,111,-211,211,-211,2*211,111,211,111, + &4*211,-321,-311,-321,-311,411,421,411,421,-211,211,111,211,-321, + &130,310,22,-211,111,2*-211,-321,130,310,221,111,-321,130,310,221, + &-211,111,22,-82,22,21,3*0,111,-211,11,-11,13,-13,-211,111,-211, + &111,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4, + &2*21,211,111,3*22,-211,111,22,11,7*12,7*14,-321,-323,-311,-313, + &-311,-313,211,213,211,213,211,213,111,221,331,113,223,111,221, + &113,223,321,323,321,-211,-213,111,221,331,113,223,333,10221,111, + &221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,313, + &311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,2*0,11,13,15, + &-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,2*0,-211,11,22,111, + &211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,0, + &2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211, + &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22, + &-211,111,211,3*22,847*0/ + DATA (KFDP(I,3),I= 1, 944)/75*0,14,6*0,2*16,2*0,5*111,310,130, + &2*0,2*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221, + &2*113,221,113,2*213,-213,195*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211, + &3*111,-311,-313,-311,-321,-313,-323,111,221,331,113,223,-311, + &-313,-311,-321,-313,-323,111,221,331,113,223,22*0,111,113,2*211, + &-211,-311,211,111,3*211,-211,7*211,-321,-323,-311,-321,-313,-323, + &-211,-213,-321,-323,-311,-321,-313,-323,-211,-213,22*0,111,113, + &-311,2*-211,211,-211,310,-211,2*111,211,2*-211,-321,-211,2*211, + &-211,111,-211,2*211,0,221,331,333,321,311,221,331,333,321,311, + &20*0,3,0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413, + &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,-421,-423, + &-10423,-10421,-20423,-425,-421,-423,-10423,-10421,-20423,-425, + &-421,-423,16*0,-4,-1,-4,-3,2*-2,-431,-433,-10433,-10431,-20433, + &-435,-431,-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4, + &-3,2*-2,3*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531, + &533,531,533,3,2,3,2,511,513,511,513,1,2,0,-11,0,2*111,-211,-11, + &11,-13,2*221,3*0,111,27*0,111,2*0,22,111,5*0,111,12*0,2*21,103*0, + &-211,2*111,-211,3*111,-211,111,211,14*0,111,6*0,111,-211,8*0,111, + &-211,9*0,111,-211,111,-211,4*0,111,-211,111,-211,8*0,111,-211, + &111,-211,4*0,111,-211,111,-211,11*0,-211,6*0,111,211,4*0,111/ + DATA (KFDP(I,3),I= 945,2000)/13*0,2*111,211,-211,211,-211,7*0, + &-211,111,13*0,2*21,-211,111,6*0,2212,3122,3212,3214,2112,2114, + &2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,8*0, + &3*4122,8*0,4,1,4,3,2*2,3*0,2112,43*0,3322,861*0/ + DATA (KFDP(I,4),I= 1,2000)/88*0,3*111,8*0,-211,0,-211,3*0,111, + &2*-211,0,111,0,2*111,113,221,111,-213,-211,211,195*0,13*81,41*0, + &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111, + &-211,2*211,2*-211,2*0,-211,111,-211,111,4*0,-211,111,-211,111, + &34*0,111,-211,3*111,3*-211,2*111,3*-211,4*0,-321,-311,3*0,-321, + &-311,20*0,-3,31*0,6*1,30*0,6*2,33*0,6*3,9*0,8*4,4*0,4*-5,4*0, + &2*-5,7*0,-11,264*0,111,-211,4*0,111,57*0,-211,111,5*0,-211,111, + &52*0,2101,2103,2*2101,19*0,6*2101,909*0/ + DATA (KFDP(I,5),I= 1,2000)/90*0,111,16*0,111,7*0,111,0,2*111, + &303*0,-211,2*111,-211,111,-211,111,54*0,111,-211,3*111,-211,111, + &1510*0/ + +C...LUDAT4, with character strings. + DATA (CHAF(I) ,I= 1, 281)/'d','u','s','c','b','t','l','h', + &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi', + &2*' ','g','gamma','Z','W','H',2*' ','reggeon','pomeron',2*' ', + &'Z''','Z"','W''','H''','A','H','eta_tech','LQ_ue','R',40*' ', + &'specflav','rndmflav','phasespa','c-hadron','b-hadron', + &'t-hadron','l-hadron','h-hadron','Wvirt','diquark','cluster', + &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet', + &'CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B','B_s','B_c', + &'pi','eta','eta''','eta_c','eta_b','eta_t','eta_l','eta_h',2*' ', + &'rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s','B*_c','rho','omega', + &'phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',2*' ','b_1', + &2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s','B_1c','b_1','h_1','h''_1', + &'h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',2*'K*_0',2*'D*_0', + &'D*_0s',2*'B*_0','B*_0s','B*_0c','a_0','f_0','f''_0','chi_0c', + &'chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',2*'K*_1', + &2*'D*_1','D*_1s',2*'B*_1','B*_1s','B*_1c','a_1','f_1','f''_1', + &'chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2', + &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s','B*_2c','a_2','f_2', + &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L', + &'K_S',8*' ','psi''',3*' ','Upsilon''',45*' ','pi_diffr'/ + DATA (CHAF(I) ,I= 282, 500)/'n_diffr','p_diffr','rho_diff', + &'omega_di','phi_diff','J/psi_di',18*' ','Lambda',5*' ', + &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' ','n', + &'p',' ',3*'Sigma',2*'Xi',' ',3*'Sigma_c',2*'Xi''_c','Omega_c', + &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta', + &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c', + &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/ + +C...LUDATR, with initial values for the random number generator. + DATA MRLU/19780503,0,0,97,33,0/ + + END + +C********************************************************************* + +CDECK ID>, LUTAUD + SUBROUTINE LUTAUD(ITAU,IORIG,KFORIG,NDECAY) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + +C...Dummy routine, to be replaced by user, to handle the decay of a +C...polarized tau lepton. +C...Input: +C...ITAU is the position where the decaying tau is stored in /LUJETS/. +C...IORIG is the position where the mother of the tau is stored; +C... is 0 when the mother is not stored. +C...KFORIG is the flavour of the mother of the tau; +C... is 0 when the mother is not known. +C...Note that IORIG=0 does not necessarily imply KFORIG=0; +C... e.g. in B hadron semileptonic decays the W propagator +C... is not explicitly stored but the W code is still unambiguous. +C...Output: +C...NDECAY is the number of decay products in the current tau decay. +C...These decay products should be added to the /LUJETS/ common block, +C...in positions N+1 through N+NDECAY. For each product I you must +C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2), +C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically. + + COMMON/LUJETS/K(4000,5),P(4000,5),V(4000,5),N + COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /LUJETS/,/LUDAT1/ + +C...Stop program if this routine is ever called. +C...You should not copy these lines to your own routine. + NDECAY=ITAU+IORIG+KFORIG + WRITE(MSTU(11),5000) + IF(RLU(0).LT.10.) STOP + +C...Format for error printout. + 5000 FORMAT(1X,'Error: you did not link your LUTAUD routine ', + &'correctly.'/1X,'Dummy routine in JETSET file called instead.'/ + &1X,'Execution stopped!') + + + RETURN + END diff --git a/src/external/SOPHIA/rndm.f b/src/external/SOPHIA/rndm.f new file mode 100644 index 0000000..8095451 --- /dev/null +++ b/src/external/SOPHIA/rndm.f @@ -0,0 +1,73 @@ + + DOUBLE PRECISION FUNCTION RNDM(IDUMMY) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) +C...Generator from the LUND montecarlo +C...Purpose: to generate random numbers uniformly distributed between +C...0 and 1, excluding the endpoints. + COMMON/LUDATR/MRLU(6),RRLU(100) + EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)), + &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)), + &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100)) + SAVE + +C...Initialize generation from given seed. + IF(MRLU2.EQ.0) THEN + IF (MRLU1 .EQ. 0) MRLU1 = 19780503 ! initial seed + IJ=MOD(MRLU1/30082,31329) + KL=MOD(MRLU1,30082) + I=MOD(IJ/177,177)+2 + J=MOD(IJ,177)+2 + K=MOD(KL/169,178)+1 + L=MOD(KL,169) + DO 110 II=1,97 + S=0. + T=0.5 + DO 100 JJ=1,24 + M=MOD(MOD(I*J,179)*K,179) + I=J + J=K + K=M + L=MOD(53*L+1,169) + IF(MOD(L*M,64).GE.32) S=S+T + T=0.5*T + 100 CONTINUE + RRLU(II)=S + 110 CONTINUE + TWOM24=1. + DO 120 I24=1,24 + TWOM24=0.5*TWOM24 + 120 CONTINUE + RRLU98=362436.*TWOM24 + RRLU99=7654321.*TWOM24 + RRLU00=16777213.*TWOM24 + MRLU2=1 + MRLU3=0 + MRLU4=97 + MRLU5=33 + ENDIF + +C...Generate next random number. + 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5) + IF(RUNI.LT.0.) RUNI=RUNI+1. + RRLU(MRLU4)=RUNI + MRLU4=MRLU4-1 + IF(MRLU4.EQ.0) MRLU4=97 + MRLU5=MRLU5-1 + IF(MRLU5.EQ.0) MRLU5=97 + RRLU98=RRLU98-RRLU99 + IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00 + RUNI=RUNI-RRLU98 + IF(RUNI.LT.0.) RUNI=RUNI+1. + IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130 + +C...Update counters. Random number to output. + MRLU3=MRLU3+1 + IF(MRLU3.EQ.1000000000) THEN + MRLU2=MRLU2+1 + MRLU3=0 + ENDIF +C RLU=RUNI + RNDM=RUNI + RETURN + END diff --git a/src/external/SOPHIA/sampling.f b/src/external/SOPHIA/sampling.f new file mode 100644 index 0000000..85c4ae4 --- /dev/null +++ b/src/external/SOPHIA/sampling.f @@ -0,0 +1,592 @@ +c***************************************************************************** +c**!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*** +c**!! IF YOU USE THIS PROGRAM, PLEASE CITE: !!*** +c**!! A.M"ucke, Ralph Engel, J.P.Rachen, R.J.Protheroe and Todor Stanev, !!*** +c**!! 1999, astro-ph/9903478, to appear in Comp.Phys.Commun. !!*** +c**!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*** +c***************************************************************************** +c** Further SOPHIA related papers: *** +c** (1) M"ucke A., et al 1999, astro-ph/9808279, to appear in PASA. *** +c** (2) M"ucke A., et al 1999, to appear in: Proc. of the *** +c** 19th Texas Symposium on Relativistic Astrophysics, Paris, France, *** +c** Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg (CEA Saclay) *** +c** (3) M"ucke A., et al 1999, astro-ph/9905153, to appear in: Proc. of *** +c** 19th Texas Symposium on Relativistic Astrophysics, Paris, France, *** +c** Dec. 1998. Eds.: J.~Paul, T.~Montmerle \& E.~Aubourg (CEA Saclay) *** +c** (4) M"ucke A., et al 1999, to appear in: Proc. of 26th Int.Cosmic Ray *** +c** Conf. (Salt Lake City, Utah) *** +c***************************************************************************** + + +c********************************************** +c** Routines/functions related to sampling *** +c** photon energy and squared CMF energy: *** +c********************************************** + + + + subroutine sample_s(s,eps) + +c*********************************************************************** +c samples distribution of s: p(s) = (s-mp^2)sigma_Ngamma +c rejection for s=[sth,s0], analyt.inversion for s=[s0,smax] +c*********************************************************************** +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + common/input/ tbb,E0,alpha1,alpha2, + & epsm1,epsm2,epsb,L0 + COMMON /S_MASS1/ AM(49), AM2(49) + + external functs,gauss,rndm + double precision functs,gauss,rndm + +c*** calculate smin,smax : ************************ + xmpi = AM(7) + xmp = AM(L0) + Pp = sqrt(E0*E0-xmp*xmp) + smin = 1.1646D0 + smax = max(smin,xmp*xmp+2.D0*eps*(E0+Pp)) + if ((smax-smin).le.1.D-8) then + s = smin+rndm(0)*1.d-6 + RETURN + endif + s0 = 10.D0 +c*** determine which method applies: rejection or analyt.inversion: ** + sintegr1 = gauss(functs,smin,s0) + sintegr2 = gauss(functs,s0,smax) + if (smax.le.s0) then +c rejection method: + nmethod=1 + goto 41 + endif + r1 = rndm(0) + quo = sintegr1/(sintegr1+sintegr2) + if (r1.le.quo) then +c rejection method: + nmethod=1 + else +c analyt. inversion: + nmethod=2 + endif + + 41 continue + + +c*** rejection method: ************************ + if (nmethod.eq.1) then + 10 continue +c*** sample s random between smin ... s0 ** + r2 = rndm(0) + s = smin+r2*(smax-smin) +c*** calculate p(s) = pes ********************** + ps = functs(s) +c*** rejection method to sample s ********************* + r3 = rndm(0) +c pmax is roughly p(s) at s=s0 + pmax = 1300.D0/sintegr1 + if (r3*pmax.le.ps/sintegr1) then + RETURN + else + goto 10 + endif + endif + +c*** analyt. inversion method: ******************* + if (nmethod.eq.2) then + r4 = rndm(0) + beta = 2.04D0 + betai = 1.D0/beta + term1 = r4*(smax**beta) + term2 = (r4-1.D0)*(s0**beta) + s = (term1-term2)**betai + RETURN + endif + + RETURN + END + + subroutine sample_eps(eps,epsmin,epsmax) + +c**************************************************************************** +c samples distribution of epsilon p(epsilon) for blackbody spectrum if tbb>0 +c and power law \sim eps^-alpha, epsm1 [eV] < eps [eV] < epsm2 [eV], +c eps in LAB frame if tbb \leq 0 +c**************************************************************************** +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + common/input/ tbb,E0,alpha1,alpha2, + & epsm1,epsm2,epsb,L0 + common/PLindex/ alphaxx + COMMON /S_MASS1/ AM(49), AM2(49) + + external prob_epskt,prob_epspl,rndm,gauss,functs,probint_pl + double precision prob_epskt,prob_epspl,rndm,gauss + double precision functs,probint_pl + + xmpi = AM(7) + xmp = AM(L0) + gammap = E0/xmp + betap = sqrt(1.-1./gammap/gammap) + Pp = sqrt(E0*E0-xmp*xmp) + 1 continue + facpmax = 1.6D0 +c*** for tbb<=0: power law photon spectrum n(eps) ~ eps^-alpha ********* + if (tbb.gt.0.D0) then + epsm1 = (1.1646D0-xmp*xmp)/2.D0/(E0+Pp) + epsm1 = epsm1*1.D9 + epsm2 = 0.007D0*tbb + epskt = 8.619D-5*tbb + epspmax = (3.D-3*((E0*epskt*1.D-9)**(-0.97D0)) + & +0.047D0)/3.9D2*tbb + if (epsm1.gt.epsm2) then + print*, + & 'CMF energy is below threshold for nucleon energy ' + & ,E0,' GeV !' + eps = 0.D0 + RETURN + endif + cnorm = gauss(prob_epskt,epsm1,epsm2) + pmaxc = prob_epskt(epspmax)/cnorm + pmax = facpmax*pmaxc + + else +c*** determine distribution: + epsth = (1.1646D0-xmp*xmp)/2.D0/(E0+Pp) + epsth = epsth*1.D9 + epsm1 = max(epsmin,epsth) + epsm2 = epsmax + if (epsm1.ge.epsm2) then + eps = 0. + RETURN + endif + endif + + epsmx1 = epsm1 + epsmx2 = epsm2 + epsbx = epsb + epsdelta = 0.159368/E0*1.d9 + epsxx = 126.D0/E0*1.d9 + alpha12 = alpha2-alpha1 + a1 = 1.D0 + 10 continue +c*** sample eps randomly between epsmin ... epsmax ** + r1 = rndm(0) +c*** calculate p(eps) = peps *************************************** + if (tbb.le.0.D0) then + rn = rndm(0) +c******************************************************************* +c... sample from straight power law (alpha = alpha2, epsb < epsm1): + if (alpha12.eq.0.D0.or.epsm1.ge.epsb) then + if (epsxx.ge.epsm2) then + alphaxx = alpha2 + else if (epsxx.le.epsm1) then + alphaxx = (alpha2+2.D0) + else if (epsm1.lt.epsxx.and.epsxx.lt.epsm2) then + a2 = epxx*epsxx + alphaxx = alpha2 + pintegr1 = a1*probint_pl(epsm1,epsxx,alphaxx) + alphaxx = (alpha2+2.D0) + pintegr2 = a2*probint_pl(epsxx,epsm2,alphaxx) + pintegr1 = pintegr1/(pintegr1+pintegr2) + if (rn.lt.pintegr1) then + alphaxx = alpha2 + epsm2 = epsxx + ampl = a1 + else if (pintegr1.le.rn.and.rn.lt.1.D0) then + alphaxx = alpha2+2.D0 + epsm1 = epsxx + ampl = a2 + endif + endif + endif +c... sample from broken power law: input always epsm1 < epsb < epsm2 + if (epsm1.lt.epsb) then +c... determine where epsb,epsxx lies: + if (epsm1.lt.epsxx.and.epsxx.lt.epsb) then + a2 = epxx*epsxx + a3 = a2*(epsb**(alpha2-alpha1)) + alphaxx = alpha1 + pintegr1 = a1*probint_pl(epsm1,epsxx,alphaxx) + alphaxx = (alpha1+2.D0) + pintegr2 = a2*probint_pl(epsxx,epsb,alphaxx) + alphaxx = (alpha2+2.D0) + pintegr3 = a3*probint_pl(epsb,epsm2,alphaxx) + pintegr1 = pintegr1/(pintegr1+pintegr2+pintegr3) + pintegr2 = (pintegr1+pintegr2)/(pintegr1+pintegr2+pintegr3) + pintegr3 = 1.D0 + if (rn.lt.pintegr1) then + alphaxx = alpha1 + epsm2 = epsxx + ampl = a1 + else if (pintegr1.le.rn.and.rn.lt.pintegr2) then + alphaxx = alpha1+2.D0 + epsm1 = epsxx + epsm2 = epsb + ampl = a2 + else if (pintegr2.le.rn.and.rn.le.pintegr3) then + alphaxx = alpha2+2.D0 + epsm1 = epsb + ampl = a3 + else + print*,'error in sampling broken power law: SAMPLE_EPS (1)!' + STOP + endif + + else if (epsb.le.epsxx.and.epsxx.lt.epsm2) then + a2 = epsb**(alpha2-alpha1) + a3 = a2*epsxx*epsxx + alphaxx = alpha1 + pintegr1 = a1*probint_pl(epsm1,epsb,alphaxx) + alphaxx = alpha2 + pintegr2 = a2*probint_pl(epsb,epsxx,alphaxx) + alphaxx = (alpha2+2.D0) + pintegr3 = a3*probint_pl(epsxx,epsm2,alphaxx) + pintegr1 = pintegr1/(pintegr1+pintegr2+pintegr3) + pintegr2 = (pintegr1+pintegr2)/(pintegr1+pintegr2+pintegr3) + pintegr3 = 1.D0 + if (rn.lt.pintegr1) then + alphaxx = alpha1 + epsm2 = epsb + ampl = a1 + else if (pintegr1.le.rn.and.rn.lt.pintegr2) then + alphaxx = alpha2 + epsm1 = epsb + epsm2 = epsxx + ampl = a2 + else if (pintegr2.le.rn.and.rn.le.pintegr3) then + alphaxx = alpha2+2.D0 + epsm1 = epsxx + ampl = a3 + else + print*,'error in sampling broken power law: SAMPLE_EPS (2)!' + STOP + endif + + else if (epsxx.ge.epsm2) then + a2 = epsb**(alpha2-alpha1) + a3 = 0.D0 + alphaxx = alpha1 + pintegr1 = a1*probint_pl(epsm1,epsb,alphaxx) + alphaxx = alpha2 + pintegr2 = a2*probint_pl(epsb,epsm2,alphaxx) + pintegr1 = pintegr1/(pintegr1+pintegr2) + pintegr2 = 1.D0 + if (rn.lt.pintegr1) then + alphaxx = alpha1 + epsm2 = epsb + ampl = a1 + else if (pintegr1.le.rn.and.rn.le.pintegr2) then + alphaxx = alpha2 + epsm1 = epsb + ampl = a2 + else + print*,'error in sampling broken power law: SAMPLE_EPS (3)!' + STOP + endif + + else if (epsxx.le.epsm1) then + a2 = epsb**(alpha2-alpha1) + a3 = 0.D0 + alphaxx = (alpha1+2.D0) + pintegr1 = a1*probint_pl(epsm1,epsb,alphaxx) + alphaxx = (alpha2+2.D0) + pintegr2 = a2*probint_pl(epsb,epsm2,alphaxx) + pintegr1 = pintegr1/(pintegr1+pintegr2) + pintegr2 = 1.D0 + if (rn.lt.pintegr1) then + alphaxx = alpha1+2.D0 + epsm2 = epsb + ampl = a1 + else if (pintegr1.le.rn.and.rn.le.pintegr2) then + alphaxx = alpha2+2.D0 + epsm1 = epsb + ampl = a2 + else + print*,'error in sampling broken power law: SAMPLE_EPS (4)!' + STOP + endif + + endif +cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +c... END: sample from broken power law: + endif +c***************************************************** + if (alphaxx.eq.1.D0) then + term1 = r1*log(epsm2/epsm1) + eps = epsm1*exp(term1) + else + beta = 1.D0-alphaxx + betai = 1.D0/beta + term1 = r1*(epsm2**beta) + term2 = (r1-1.D0)*(epsm1**beta) + eps = (term1-term2)**betai + endif + + +c****************************************************** +c*** for thermal spectrum: *** + else + eps = epsm1+r1*(epsm2-epsm1) + peps = prob_epskt(eps)/cnorm +c endif +c*** rejection method to sample eps ********************* + r2 = rndm(0) + if (r2*pmax.gt.peps) then + goto 10 + endif + + endif + + epsm1 = epsmx1 + epsm2 = epsmx2 + epsb = epsbx + +c... check maximum of epsilon distribution: + if (pmax.lt.peps) then + facpmax = facpmax + 0.1D0 + goto 1 + endif + + RETURN + END + + + DOUBLE PRECISION function prob_epskt(eps) + +c*** calculates probability distribution for thermal photon field *** +c*** with temerature tbb (in K), eps (in eV) ************* +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + common/input/ tbb,E0,alpha1,alpha2, + & epsm1,epsm2,epsb,L0 + + external functs,photd,gauss + double precision functs,photd,gauss + + xmpi = 0.135D0 + xmp = 0.93827D0 + Pp = sqrt(E0*E0-xmp*xmp) + gammap = E0/xmp + betap = sqrt(1.D0-1.D0/gammap/gammap) + deps = photd(eps,tbb) + if (deps.eq.0.D0) then + prob_epskt = 0.D0 + RETURN + else +c*** calculate \int_sth^smax ds (s-mp^2) sigma_pg ******* +c*** smin is for head-on collision ********************** + smin = 1.1646D0 + smax = max(smin,xmp*xmp+2.D0*eps/1.D9*E0*(1.D0+betap)) + sintegr = gauss(functs,smin,smax) + + prob_epskt = deps/eps/eps*sintegr/ + & 8.D0/betap/E0/E0*1.D18*1.D6 + endif + + RETURN + + END + + DOUBLE PRECISION function prob_epspl(eps) + +c*** calculates probability distribution for power law photon field *** +c*** n = anorm*eps^-alpha, eps=[epsm1,epsm2], eps in eV ************* +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + common/input/ tbb,E0,alpha1,alpha2, + & epsm1,epsm2,epsb,L0 + + external functs,gauss + double precision functs,gauss + + xmpi = 0.135D0 + xmp = 0.93827D0 + Pp = sqrt(E0*E0-xmp*xmp) + gammap = E0/xmp + betap = sqrt(1.D0-1.D0/gammap/gammap) + alpha12 = alpha2-alpha1 + ampl = epsb**alpha12 + if (eps.lt.epsb) then + deps = eps**(-alpha1) + else + deps = ampl*(eps**(-alpha2)) + endif + +c*** calculate \int_sth^smax ds (s-mp^2) sigma_pg ******* +c*** smin is for head-on collision ********************** + smin = 1.1646D0 + smax = max(smin,xmp*xmp+2.D0*eps/1.D9*(E0+Pp)) + + sintegr = gauss(functs,smin,smax) + + prob_epspl = deps/eps/eps*sintegr/ + & 8.D0/betap/E0/E0*1.D18*1.D6 + + RETURN + + END + + DOUBLE PRECISION function probint_pl(epsi,epsf,p) + +c*** returns \int_epsi^epsf eps^-p ************** +c*** calling program is SAMPLE_EPS **************** +c** Date: 03/03/99 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + if (p.eq.1.D0) then + probint_pl = log(epsf/epsi) + else + p1 = 1.D0-p + probint_pl = ((epsf**p1)-(epsi**p1))/p1 + endif + + RETURN + + END + + + DOUBLE PRECISION function functs(s) + +c*** returns (s-pm^2)*sigma_Ngamma ************** +c*** calling program is SAMPLE_S **************** +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + common/input/ tbb,E0,alpha1,alpha2, + & epsm1,epsm2,epsb,L0 + + external crossection + double precision crossection + + + pm = 0.93827D0 + factor = (s-pm*pm) + epsprime = factor/2.D0/pm + sigma_pg = crossection(epsprime,3,L0) + functs = factor*sigma_pg + + RETURN + + END + + DOUBLE PRECISION FUNCTION PHOTD(EPS,TBB) +C ************************************************************** +C RETURNS THE DENSITY OF BLACKBODY RADIATION OF TEMPERATURE * +C "TBB" DEGREES (DENS1). EPS IN eV, PHOTD IN #/(cm^3.eV) * +C TSS, May '92 * +C ************************************************************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE +C CONVERT TEMPERATURE TO eV + EPH = EPS + EKT = 8.619D-5*TBB + EPHKT = EPS/EKT + IF (EPHKT .GT. 80.D0) GO TO 10 + IF (EPHKT .LT. 1.D-4) GO TO 11 + FEE = DEXP(EPHKT) - 1.D0 + GO TO 12 + 11 FEE = EPHKT + 12 BB = 1.318D13*EPH*EPH/FEE + GO TO 15 + 10 BB = 0.D0 + 15 PHOTD = BB + END + + + DOUBLE PRECISION function plinterpol(alpha) + +c*** interpolates p(Ep) to give the max. probability p(eps) for *** +c*** a given initial proton energy *** +c** Date: 20/01/98 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + SAVE + + DIMENSION AINDEX(4), A(4) + DATA A / 0.D0,1.D0,2.D0,3.D0/ + DATA AINDEX / 8.D8,5.D8,5.D8,1.D9/ + + plinterpol = 0.D0 + + do 1 ni=1,3 + p1 = A(ni) + p2 = A(ni+1) + if (alpha.le.p2.and.alpha.gt.p1) then + tang = (log10(AINDEX(ni+1))-log10(AINDEX(ni)))/(p2-p1) + plinterpol = log10(AINDEX(ni))+(alpha-p1)*tang + plinterpol = 10.D0**plinterpol + endif + 1 continue + + if (alpha.eq.0.D0) plinterpol = 5.D8 + + if (plinterpol.eq.0.D0) then + print*,'interpolation not sucessful !' + pause + endif + + END + + DOUBLE PRECISION function f_epspl(eps) + +c*** gives energy density law of power law photon field *** +c*** f(epsilon) = eps^-alpha, eps=[epsm1,epsm2], eps in eV ************* +c** Date: 14/03/99 ** +c** author: A.Muecke ** +c********************** + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + SAVE + + common/input/ tbb,E0,alpha1,alpha2, + & epsm1,epsm2,epsb,L0 + + + alpha12 = alpha2-alpha1 + ampl = epsb**alpha12 + if (eps.lt.epsb) then + f_epspl = eps*(eps**(-alpha1)) + else + f_epspl = eps*ampl*(eps**(-alpha2)) + endif + + RETURN + + END + + diff --git a/src/external/nr b/src/external/nr new file mode 160000 index 0000000..0e6af50 --- /dev/null +++ b/src/external/nr @@ -0,0 +1 @@ +Subproject commit 0e6af5083b426ca9423bc6da60372eba49f6ab6c